packages feed

accelerate 1.1.1.0 → 1.2.0.0

raw patch · 198 files changed

+42528/−32404 lines, 198 filesdep +acceleratedep +ansi-terminaldep +bytestringdep −fclabelsdep −timedep ~basedep ~hashtablesbuild-type:Customsetup-changedbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: accelerate, ansi-terminal, bytestring, constraints, cryptonite, doctest, half, hedgehog, lens, tasty, tasty-expected-failure, tasty-hedgehog, tasty-hunit, terminal-size, vector

Dependencies removed: fclabels, time

Dependency ranges changed: base, hashtables

API changes (from Hackage documentation)

- Data.Array.Accelerate: data (:.) tail head
- Data.Array.Accelerate.Data.Complex: instance (Data.Array.Accelerate.Classes.FromIntegral.FromIntegral a b, Data.Array.Accelerate.Classes.Num.Num b) => Data.Array.Accelerate.Classes.FromIntegral.FromIntegral a (Data.Complex.Complex b)
- Data.Array.Accelerate.Data.Complex: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a)) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex a)
- Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex a)
- Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Lift.Unlift Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex (Data.Array.Accelerate.Smart.Exp a))
- Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Classes.Eq.Eq a => Data.Array.Accelerate.Classes.Eq.Eq (Data.Complex.Complex a)
- Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Classes.RealFloat.RealFloat a => GHC.Float.Floating (Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex a))
- Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Classes.RealFloat.RealFloat a => GHC.Num.Num (Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex a))
- Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Classes.RealFloat.RealFloat a => GHC.Real.Fractional (Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex a))
- Data.Array.Accelerate.Data.Monoid: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a)) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (Data.Monoid.Product a)
- Data.Array.Accelerate.Data.Monoid: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a)) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (Data.Monoid.Sum a)
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Array.Sugar.Elt (Data.Monoid.Product a)
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Array.Sugar.Elt (Data.Monoid.Sum a)
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Lift.Unlift Data.Array.Accelerate.Smart.Exp (Data.Monoid.Product (Data.Array.Accelerate.Smart.Exp a))
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Lift.Unlift Data.Array.Accelerate.Smart.Exp (Data.Monoid.Sum (Data.Array.Accelerate.Smart.Exp a))
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Product.IsProduct Data.Array.Accelerate.Array.Sugar.Elt (Data.Monoid.Product a)
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Product.IsProduct Data.Array.Accelerate.Array.Sugar.Elt (Data.Monoid.Sum a)
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Eq.Eq a => Data.Array.Accelerate.Classes.Eq.Eq (Data.Monoid.Product a)
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Eq.Eq a => Data.Array.Accelerate.Classes.Eq.Eq (Data.Monoid.Sum a)
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Base.Monoid (Data.Array.Accelerate.Smart.Exp (Data.Monoid.Product a))
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Base.Monoid (Data.Array.Accelerate.Smart.Exp (Data.Monoid.Sum a))
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Num.Num (Data.Array.Accelerate.Smart.Exp (Data.Monoid.Product a))
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Num.Num (Data.Array.Accelerate.Smart.Exp (Data.Monoid.Sum a))
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Ord.Ord a => Data.Array.Accelerate.Classes.Ord.Ord (Data.Monoid.Product a)
- Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Ord.Ord a => Data.Array.Accelerate.Classes.Ord.Ord (Data.Monoid.Sum a)
+ Data.Array.Accelerate: EQ :: Ordering
+ Data.Array.Accelerate: GT :: Ordering
+ Data.Array.Accelerate: Half :: CUShort -> Half
+ Data.Array.Accelerate: LT :: Ordering
+ Data.Array.Accelerate: [getHalf] :: Half -> CUShort
+ Data.Array.Accelerate: arrayReshape :: (Shape sh, Shape sh', Elt e) => sh -> Array sh' e -> Array sh e
+ Data.Array.Accelerate: compare :: Ord a => Exp a -> Exp a -> Exp Ordering
+ Data.Array.Accelerate: concatOn :: (Shape sh, Elt e) => Lens' (Exp sh) (Exp Int) -> Acc (Array sh e) -> Acc (Array sh e) -> Acc (Array sh e)
+ Data.Array.Accelerate: data Ordering
+ Data.Array.Accelerate: data tail (:.) head
+ Data.Array.Accelerate: dropOn :: (Shape sh, Elt e) => Lens' (Exp sh) (Exp Int) -> Exp Int -> Acc (Array sh e) -> Acc (Array sh e)
+ Data.Array.Accelerate: fromFunctionM :: (Shape sh, Elt e) => sh -> (sh -> IO e) -> IO (Array sh e)
+ Data.Array.Accelerate: infixl 6 -
+ Data.Array.Accelerate: infixl 7 /
+ Data.Array.Accelerate: initOn :: (Shape sh, Elt e) => Lens' (Exp sh) (Exp Int) -> Acc (Array sh e) -> Acc (Array sh e)
+ Data.Array.Accelerate: linearIndexArray :: Array sh e -> Int -> e
+ Data.Array.Accelerate: newtype Half
+ Data.Array.Accelerate: pred :: Enum a => a -> a
+ Data.Array.Accelerate: reverseOn :: (Shape sh, Elt e) => Lens' (Exp sh) (Exp Int) -> Acc (Array sh e) -> Acc (Array sh e)
+ Data.Array.Accelerate: slitOn :: (Shape sh, Elt e) => Lens' (Exp sh) (Exp Int) -> Exp Int -> Exp Int -> Acc (Array sh e) -> Acc (Array sh e)
+ Data.Array.Accelerate: succ :: Enum a => a -> a
+ Data.Array.Accelerate: tailOn :: (Shape sh, Elt e) => Lens' (Exp sh) (Exp Int) -> Acc (Array sh e) -> Acc (Array sh e)
+ Data.Array.Accelerate: takeOn :: (Shape sh, Elt e) => Lens' (Exp sh) (Exp Int) -> Exp Int -> Acc (Array sh e) -> Acc (Array sh e)
+ Data.Array.Accelerate: transposeOn :: (Shape sh, Elt e) => Lens' (Exp sh) (Exp Int) -> Lens' (Exp sh) (Exp Int) -> Acc (Array sh e) -> Acc (Array sh e)
+ Data.Array.Accelerate: type Enum a = Enum (Exp a)
+ Data.Array.Accelerate: type Matrix = Array DIM2
+ Data.Array.Accelerate.Data.Complex: instance (Data.Array.Accelerate.Array.Sugar.Elt a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex a)) => Data.Array.Accelerate.Lift.Unlift Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex (Data.Array.Accelerate.Smart.Exp a))
+ Data.Array.Accelerate.Data.Complex: instance (Data.Array.Accelerate.Classes.Eq.Eq a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex a)) => Data.Array.Accelerate.Classes.Eq.Eq (Data.Complex.Complex a)
+ Data.Array.Accelerate.Data.Complex: instance (Data.Array.Accelerate.Classes.FromIntegral.FromIntegral a b, Data.Array.Accelerate.Classes.Num.Num b, Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex b)) => Data.Array.Accelerate.Classes.FromIntegral.FromIntegral a (Data.Complex.Complex b)
+ Data.Array.Accelerate.Data.Complex: instance (Data.Array.Accelerate.Classes.RealFloat.RealFloat a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex a)) => GHC.Float.Floating (Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex a))
+ Data.Array.Accelerate.Data.Complex: instance (Data.Array.Accelerate.Classes.RealFloat.RealFloat a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex a)) => GHC.Num.Num (Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex a))
+ Data.Array.Accelerate.Data.Complex: instance (Data.Array.Accelerate.Classes.RealFloat.RealFloat a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex a)) => GHC.Real.Fractional (Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex a))
+ Data.Array.Accelerate.Data.Complex: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a), Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex (Data.Array.Accelerate.Lift.Plain a))) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (Data.Complex.Complex a)
+ Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex Foreign.C.Types.CDouble)
+ Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex Foreign.C.Types.CFloat)
+ Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex GHC.Types.Double)
+ Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex GHC.Types.Float)
+ Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Array.Sugar.Elt (Data.Complex.Complex Numeric.Half.Half)
+ Data.Array.Accelerate.Data.Complex: instance Data.Array.Accelerate.Data.Functor.Functor Data.Complex.Complex
+ Data.Array.Accelerate.Data.Either: Left :: a -> Either a b
+ Data.Array.Accelerate.Data.Either: Right :: b -> Either a b
+ Data.Array.Accelerate.Data.Either: data Either a b
+ Data.Array.Accelerate.Data.Either: either :: (Elt a, Elt b, Elt c) => (Exp a -> Exp c) -> (Exp b -> Exp c) -> Exp (Either a b) -> Exp c
+ Data.Array.Accelerate.Data.Either: fromLeft :: (Elt a, Elt b) => Exp (Either a b) -> Exp a
+ Data.Array.Accelerate.Data.Either: fromRight :: (Elt a, Elt b) => Exp (Either a b) -> Exp b
+ Data.Array.Accelerate.Data.Either: instance (Data.Array.Accelerate.Array.Sugar.Elt a, Data.Array.Accelerate.Array.Sugar.Elt b) => Data.Array.Accelerate.Array.Sugar.Elt (Data.Either.Either a b)
+ Data.Array.Accelerate.Data.Either: instance (Data.Array.Accelerate.Array.Sugar.Elt a, Data.Array.Accelerate.Array.Sugar.Elt b) => Data.Array.Accelerate.Product.IsProduct Data.Array.Accelerate.Array.Sugar.Elt (Data.Either.Either a b)
+ Data.Array.Accelerate.Data.Either: instance (Data.Array.Accelerate.Array.Sugar.Elt a, Data.Array.Accelerate.Array.Sugar.Elt b) => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (Data.Either.Either a b))
+ Data.Array.Accelerate.Data.Either: instance (Data.Array.Accelerate.Classes.Eq.Eq a, Data.Array.Accelerate.Classes.Eq.Eq b) => Data.Array.Accelerate.Classes.Eq.Eq (Data.Either.Either a b)
+ Data.Array.Accelerate.Data.Either: instance (Data.Array.Accelerate.Classes.Ord.Ord a, Data.Array.Accelerate.Classes.Ord.Ord b) => Data.Array.Accelerate.Classes.Ord.Ord (Data.Either.Either a b)
+ Data.Array.Accelerate.Data.Either: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp b, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a), Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain b)) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (Data.Either.Either a b)
+ Data.Array.Accelerate.Data.Either: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Data.Functor.Functor (Data.Either.Either a)
+ Data.Array.Accelerate.Data.Either: isLeft :: (Elt a, Elt b) => Exp (Either a b) -> Exp Bool
+ Data.Array.Accelerate.Data.Either: isRight :: (Elt a, Elt b) => Exp (Either a b) -> Exp Bool
+ Data.Array.Accelerate.Data.Either: left :: forall a b. (Elt a, Elt b) => Exp a -> Exp (Either a b)
+ Data.Array.Accelerate.Data.Either: lefts :: (Shape sh, Slice sh, Elt a, Elt b) => Acc (Array (sh :. Int) (Either a b)) -> Acc (Vector a, Array sh Int)
+ Data.Array.Accelerate.Data.Either: right :: forall a b. (Elt a, Elt b) => Exp b -> Exp (Either a b)
+ Data.Array.Accelerate.Data.Either: rights :: (Shape sh, Slice sh, Elt a, Elt b) => Acc (Array (sh :. Int) (Either a b)) -> Acc (Vector b, Array sh Int)
+ Data.Array.Accelerate.Data.Functor: ($>) :: (Functor f, Elt a, Elt b, Elt (f a), Elt (f b)) => Exp (f a) -> Exp b -> Exp (f b)
+ Data.Array.Accelerate.Data.Functor: (<$) :: (Functor f, Elt a, Elt b, Elt (f a), Elt (f b)) => Exp a -> Exp (f b) -> Exp (f a)
+ Data.Array.Accelerate.Data.Functor: (<$>) :: (Functor f, Elt a, Elt b, Elt (f a), Elt (f b)) => (Exp a -> Exp b) -> Exp (f a) -> Exp (f b)
+ Data.Array.Accelerate.Data.Functor: class Functor f
+ Data.Array.Accelerate.Data.Functor: fmap :: (Functor f, Elt a, Elt b, Elt (f a), Elt (f b)) => (Exp a -> Exp b) -> Exp (f a) -> Exp (f b)
+ Data.Array.Accelerate.Data.Functor: infixl 4 $>
+ Data.Array.Accelerate.Data.Functor: instance Data.Array.Accelerate.Data.Functor.Functor Data.Semigroup.Internal.Product
+ Data.Array.Accelerate.Data.Functor: instance Data.Array.Accelerate.Data.Functor.Functor Data.Semigroup.Internal.Sum
+ Data.Array.Accelerate.Data.Functor: instance Data.Array.Accelerate.Data.Functor.Functor Data.Semigroup.Max
+ Data.Array.Accelerate.Data.Functor: instance Data.Array.Accelerate.Data.Functor.Functor Data.Semigroup.Min
+ Data.Array.Accelerate.Data.Functor: void :: (Functor f, Elt a, Elt (f a), Elt (f ())) => Exp (f a) -> Exp (f ())
+ Data.Array.Accelerate.Data.Maybe: Just :: a -> Maybe a
+ Data.Array.Accelerate.Data.Maybe: Nothing :: Maybe a
+ Data.Array.Accelerate.Data.Maybe: data Maybe a
+ Data.Array.Accelerate.Data.Maybe: fromJust :: Elt a => Exp (Maybe a) -> Exp a
+ Data.Array.Accelerate.Data.Maybe: fromMaybe :: Elt a => Exp a -> Exp (Maybe a) -> Exp a
+ Data.Array.Accelerate.Data.Maybe: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a)) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (GHC.Base.Maybe a)
+ Data.Array.Accelerate.Data.Maybe: instance (GHC.Base.Monoid (Data.Array.Accelerate.Smart.Exp a), Data.Array.Accelerate.Array.Sugar.Elt a) => GHC.Base.Monoid (Data.Array.Accelerate.Smart.Exp (GHC.Base.Maybe a))
+ Data.Array.Accelerate.Data.Maybe: instance (GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp a), Data.Array.Accelerate.Array.Sugar.Elt a) => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (GHC.Base.Maybe a))
+ Data.Array.Accelerate.Data.Maybe: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Array.Sugar.Elt (GHC.Base.Maybe a)
+ Data.Array.Accelerate.Data.Maybe: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Product.IsProduct Data.Array.Accelerate.Array.Sugar.Elt (GHC.Base.Maybe a)
+ Data.Array.Accelerate.Data.Maybe: instance Data.Array.Accelerate.Classes.Eq.Eq a => Data.Array.Accelerate.Classes.Eq.Eq (GHC.Base.Maybe a)
+ Data.Array.Accelerate.Data.Maybe: instance Data.Array.Accelerate.Classes.Ord.Ord a => Data.Array.Accelerate.Classes.Ord.Ord (GHC.Base.Maybe a)
+ Data.Array.Accelerate.Data.Maybe: instance Data.Array.Accelerate.Data.Functor.Functor GHC.Base.Maybe
+ Data.Array.Accelerate.Data.Maybe: isJust :: Elt a => Exp (Maybe a) -> Exp Bool
+ Data.Array.Accelerate.Data.Maybe: isNothing :: Elt a => Exp (Maybe a) -> Exp Bool
+ Data.Array.Accelerate.Data.Maybe: just :: Elt a => Exp a -> Exp (Maybe a)
+ Data.Array.Accelerate.Data.Maybe: justs :: (Shape sh, Slice sh, Elt a) => Acc (Array (sh :. Int) (Maybe a)) -> Acc (Vector a, Array sh Int)
+ Data.Array.Accelerate.Data.Maybe: maybe :: (Elt a, Elt b) => Exp b -> (Exp a -> Exp b) -> Exp (Maybe a) -> Exp b
+ Data.Array.Accelerate.Data.Maybe: nothing :: forall a. Elt a => Exp (Maybe a)
+ Data.Array.Accelerate.Data.Monoid: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a)) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Product a)
+ Data.Array.Accelerate.Data.Monoid: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a)) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Sum a)
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Array.Sugar.Elt (Data.Semigroup.Internal.Product a)
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Array.Sugar.Elt (Data.Semigroup.Internal.Sum a)
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Lift.Unlift Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Product (Data.Array.Accelerate.Smart.Exp a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Lift.Unlift Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Sum (Data.Array.Accelerate.Smart.Exp a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Product.IsProduct Data.Array.Accelerate.Array.Sugar.Elt (Data.Semigroup.Internal.Product a)
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Product.IsProduct Data.Array.Accelerate.Array.Sugar.Elt (Data.Semigroup.Internal.Sum a)
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Bounded.Bounded a => GHC.Enum.Bounded (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Product a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Bounded.Bounded a => GHC.Enum.Bounded (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Sum a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Eq.Eq a => Data.Array.Accelerate.Classes.Eq.Eq (Data.Semigroup.Internal.Product a)
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Eq.Eq a => Data.Array.Accelerate.Classes.Eq.Eq (Data.Semigroup.Internal.Sum a)
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Base.Monoid (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Product a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Base.Monoid (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Sum a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Product a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Sum a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Num.Num (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Product a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Num.Num (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Internal.Sum a))
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Ord.Ord a => Data.Array.Accelerate.Classes.Ord.Ord (Data.Semigroup.Internal.Product a)
+ Data.Array.Accelerate.Data.Monoid: instance Data.Array.Accelerate.Classes.Ord.Ord a => Data.Array.Accelerate.Classes.Ord.Ord (Data.Semigroup.Internal.Sum a)
+ Data.Array.Accelerate.Data.Semigroup: (<>) :: Semigroup a => a -> a -> a
+ Data.Array.Accelerate.Data.Semigroup: Max :: a -> Max a
+ Data.Array.Accelerate.Data.Semigroup: Min :: a -> Min a
+ Data.Array.Accelerate.Data.Semigroup: [getMax] :: Max a -> a
+ Data.Array.Accelerate.Data.Semigroup: [getMin] :: Min a -> a
+ Data.Array.Accelerate.Data.Semigroup: class Semigroup a
+ Data.Array.Accelerate.Data.Semigroup: instance (Data.Array.Accelerate.Array.Sugar.Elt a, Data.Array.Accelerate.Array.Sugar.Elt b, Data.Array.Accelerate.Array.Sugar.Elt c, Data.Array.Accelerate.Array.Sugar.Elt d, Data.Array.Accelerate.Array.Sugar.Elt e, GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp a), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp b), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp c), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp d), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp e)) => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (a, b, c, d, e))
+ Data.Array.Accelerate.Data.Semigroup: instance (Data.Array.Accelerate.Array.Sugar.Elt a, Data.Array.Accelerate.Array.Sugar.Elt b, Data.Array.Accelerate.Array.Sugar.Elt c, Data.Array.Accelerate.Array.Sugar.Elt d, GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp a), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp b), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp c), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp d)) => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (a, b, c, d))
+ Data.Array.Accelerate.Data.Semigroup: instance (Data.Array.Accelerate.Array.Sugar.Elt a, Data.Array.Accelerate.Array.Sugar.Elt b, Data.Array.Accelerate.Array.Sugar.Elt c, GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp a), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp b), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp c)) => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (a, b, c))
+ Data.Array.Accelerate.Data.Semigroup: instance (Data.Array.Accelerate.Array.Sugar.Elt a, Data.Array.Accelerate.Array.Sugar.Elt b, GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp a), GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp b)) => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (a, b))
+ Data.Array.Accelerate.Data.Semigroup: instance (Data.Array.Accelerate.Classes.Ord.Ord a, Data.Array.Accelerate.Classes.Bounded.Bounded a) => GHC.Base.Monoid (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Max a))
+ Data.Array.Accelerate.Data.Semigroup: instance (Data.Array.Accelerate.Classes.Ord.Ord a, Data.Array.Accelerate.Classes.Bounded.Bounded a) => GHC.Base.Monoid (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Min a))
+ Data.Array.Accelerate.Data.Semigroup: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a)) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Max a)
+ Data.Array.Accelerate.Data.Semigroup: instance (Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp a, Data.Array.Accelerate.Array.Sugar.Elt (Data.Array.Accelerate.Lift.Plain a)) => Data.Array.Accelerate.Lift.Lift Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Min a)
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Array.Sugar.Elt (Data.Semigroup.Max a)
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Array.Sugar.Elt (Data.Semigroup.Min a)
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Lift.Unlift Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Max (Data.Array.Accelerate.Smart.Exp a))
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Lift.Unlift Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Min (Data.Array.Accelerate.Smart.Exp a))
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Product.IsProduct Data.Array.Accelerate.Array.Sugar.Elt (Data.Semigroup.Max a)
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Array.Sugar.Elt a => Data.Array.Accelerate.Product.IsProduct Data.Array.Accelerate.Array.Sugar.Elt (Data.Semigroup.Min a)
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Bounded.Bounded a => GHC.Enum.Bounded (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Max a))
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Bounded.Bounded a => GHC.Enum.Bounded (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Min a))
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Eq.Eq a => Data.Array.Accelerate.Classes.Eq.Eq (Data.Semigroup.Max a)
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Eq.Eq a => Data.Array.Accelerate.Classes.Eq.Eq (Data.Semigroup.Min a)
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Num.Num (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Max a))
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Num.Num a => GHC.Num.Num (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Min a))
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Ord.Ord a => Data.Array.Accelerate.Classes.Ord.Ord (Data.Semigroup.Max a)
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Ord.Ord a => Data.Array.Accelerate.Classes.Ord.Ord (Data.Semigroup.Min a)
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Ord.Ord a => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Max a))
+ Data.Array.Accelerate.Data.Semigroup: instance Data.Array.Accelerate.Classes.Ord.Ord a => GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp (Data.Semigroup.Min a))
+ Data.Array.Accelerate.Data.Semigroup: instance GHC.Base.Semigroup (Data.Array.Accelerate.Smart.Exp ())
+ Data.Array.Accelerate.Data.Semigroup: newtype Max a
+ Data.Array.Accelerate.Data.Semigroup: newtype Min a
+ Data.Array.Accelerate.Data.Semigroup: sconcat :: Semigroup a => NonEmpty a -> a
+ Data.Array.Accelerate.Data.Semigroup: stimes :: (Semigroup a, Integral b) => b -> a -> a
+ Data.Array.Accelerate.Unsafe: coerce :: (Elt a, Elt b) => Exp a -> Exp b
+ Data.Array.Accelerate.Unsafe: undef :: Elt t => Exp t
- Data.Array.Accelerate: ($) :: (a -> b) -> a -> b
+ Data.Array.Accelerate: ($) :: () => a -> b -> a -> b
- Data.Array.Accelerate: (.) :: (b -> c) -> (a -> b) -> a -> c
+ Data.Array.Accelerate: (.) :: () => b -> c -> a -> b -> a -> c
- Data.Array.Accelerate: bitcast :: (Elt a, Elt b, IsScalar a, IsScalar b, BitSizeEq a b) => Exp a -> Exp b
+ Data.Array.Accelerate: bitcast :: (Elt a, Elt b, IsScalar (EltRepr a), IsScalar (EltRepr b), BitSizeEq (EltRepr a) (EltRepr b)) => Exp a -> Exp b
- Data.Array.Accelerate: class Elt a => Eq a where x == y = mkLNot (x /= y) x /= y = mkLNot (x == y)
+ Data.Array.Accelerate: class Elt a => Eq a
- Data.Array.Accelerate: class IfThenElse t where type EltT t a :: Constraint where {
+ Data.Array.Accelerate: class IfThenElse t where {
- Data.Array.Accelerate: class (Floating a, IsScalar a, IsNum a) => IsFloating a
+ Data.Array.Accelerate: class (Floating a, IsSingle a, IsNum a) => IsFloating a
- Data.Array.Accelerate: class (IsScalar a, IsNum a, IsBounded a) => IsIntegral a
+ Data.Array.Accelerate: class (IsSingle a, IsNum a, IsBounded a) => IsIntegral a
- Data.Array.Accelerate: class (Num a, IsScalar a) => IsNum a
+ Data.Array.Accelerate: class (Num a, IsSingle a) => IsNum a
- Data.Array.Accelerate: class Lift c e where type Plain e where {
+ Data.Array.Accelerate: class Lift c e where {
- Data.Array.Accelerate: class Eq a => Ord a where x < y = x /= y && x <= y x > y = not (x <= y) x <= y = not (x > y) x >= y = x == y || not (x <= y) min x y = Exp $ Cond (x <= y) x y max x y = Exp $ Cond (x <= y) y x
+ Data.Array.Accelerate: class Eq a => Ord a
- Data.Array.Accelerate: class (RealFrac a, Floating a) => RealFloat a where floatRadix _ = fromInteger (floatRadix (undefined :: a)) floatDigits _ = constant (floatDigits (undefined :: a)) floatRange _ = let (m, n) = floatRange (undefined :: a) in (constant m, constant n) encodeFloat x e = fromIntegral x * (fromIntegral (floatRadix (undefined :: Exp a)) ** fromIntegral e) exponent x = let (m, n) = decodeFloat x in Exp $ Cond (m == 0) 0 (n + floatDigits x) significand x = let (m, _) = decodeFloat x in encodeFloat m (negate (floatDigits x)) scaleFloat k x = Exp $ Cond (k == 0 || isFix) x $ encodeFloat m (n + clamp b) where isFix = x == 0 || isNaN x || isInfinite x (m, n) = decodeFloat x (l, h) = floatRange x d = floatDigits x b = h - l + 4 * d clamp bd = max (- bd) (min bd k) isIEEE _ = constant (isIEEE (undefined :: Float))
+ Data.Array.Accelerate: class (RealFrac a, Floating a) => RealFloat a
- Data.Array.Accelerate: class (Elt sh, Elt (Any sh), Shape (EltRepr sh), FullShape sh ~ sh, CoSliceShape sh ~ sh, SliceShape sh ~ Z) => Shape sh where rank = rank . fromElt size = size . fromElt empty = toElt empty ignore = toElt ignore intersect sh1 sh2 = toElt (intersect (fromElt sh1) (fromElt sh2)) union sh1 sh2 = toElt (union (fromElt sh1) (fromElt sh2)) fromIndex sh ix = toElt (fromIndex (fromElt sh) ix) toIndex sh ix = toIndex (fromElt sh) (fromElt ix) iter sh f c r = iter (fromElt sh) (f . toElt) c r iter1 sh f r = iter1 (fromElt sh) (f . toElt) r rangeToShape (low, high) = toElt (rangeToShape (fromElt low, fromElt high)) shapeToRange ix = let (low, high) = shapeToRange (fromElt ix) in (toElt low, toElt high) shapeToList = shapeToList . fromElt listToShape = toElt . listToShape
+ Data.Array.Accelerate: class (Elt sh, Elt (Any sh), Shape (EltRepr sh), FullShape sh ~ sh, CoSliceShape sh ~ sh, SliceShape sh ~ Z) => Shape sh
- Data.Array.Accelerate: class (Elt sl, Shape (SliceShape sl), Shape (CoSliceShape sl), Shape (FullShape sl)) => Slice sl where type SliceShape sl :: * type CoSliceShape sl :: * type FullShape sl :: * where {
+ Data.Array.Accelerate: class (Elt sl, Shape (SliceShape sl), Shape (CoSliceShape sl), Shape (FullShape sl)) => Slice sl where {
- Data.Array.Accelerate: const :: a -> b -> a
+ Data.Array.Accelerate: const :: () => a -> b -> a
- Data.Array.Accelerate: data Bool :: *
+ Data.Array.Accelerate: data Bool
- Data.Array.Accelerate: data CChar :: *
+ Data.Array.Accelerate: data CChar
- Data.Array.Accelerate: data CDouble :: *
+ Data.Array.Accelerate: data CDouble
- Data.Array.Accelerate: data CFloat :: *
+ Data.Array.Accelerate: data CFloat
- Data.Array.Accelerate: data CInt :: *
+ Data.Array.Accelerate: data CInt
- Data.Array.Accelerate: data CLLong :: *
+ Data.Array.Accelerate: data CLLong
- Data.Array.Accelerate: data CLong :: *
+ Data.Array.Accelerate: data CLong
- Data.Array.Accelerate: data CSChar :: *
+ Data.Array.Accelerate: data CSChar
- Data.Array.Accelerate: data CShort :: *
+ Data.Array.Accelerate: data CShort
- Data.Array.Accelerate: data CUChar :: *
+ Data.Array.Accelerate: data CUChar
- Data.Array.Accelerate: data CUInt :: *
+ Data.Array.Accelerate: data CUInt
- Data.Array.Accelerate: data CULLong :: *
+ Data.Array.Accelerate: data CULLong
- Data.Array.Accelerate: data CULong :: *
+ Data.Array.Accelerate: data CULong
- Data.Array.Accelerate: data CUShort :: *
+ Data.Array.Accelerate: data CUShort
- Data.Array.Accelerate: data Char :: *
+ Data.Array.Accelerate: data Char
- Data.Array.Accelerate: data Double :: *
+ Data.Array.Accelerate: data Double
- Data.Array.Accelerate: data Float :: *
+ Data.Array.Accelerate: data Float
- Data.Array.Accelerate: data Int :: *
+ Data.Array.Accelerate: data Int
- Data.Array.Accelerate: data Int16 :: *
+ Data.Array.Accelerate: data Int16
- Data.Array.Accelerate: data Int32 :: *
+ Data.Array.Accelerate: data Int32
- Data.Array.Accelerate: data Int64 :: *
+ Data.Array.Accelerate: data Int64
- Data.Array.Accelerate: data Int8 :: *
+ Data.Array.Accelerate: data Int8
- Data.Array.Accelerate: data Word :: *
+ Data.Array.Accelerate: data Word
- Data.Array.Accelerate: data Word16 :: *
+ Data.Array.Accelerate: data Word16
- Data.Array.Accelerate: data Word32 :: *
+ Data.Array.Accelerate: data Word32
- Data.Array.Accelerate: data Word64 :: *
+ Data.Array.Accelerate: data Word64
- Data.Array.Accelerate: data Word8 :: *
+ Data.Array.Accelerate: data Word8
- Data.Array.Accelerate: fromInteger :: Num a => Integer -> a
+ Data.Array.Accelerate: fromInteger :: Num a => Integer -> Exp a
- Data.Array.Accelerate: fromRational :: Fractional a => Rational -> a
+ Data.Array.Accelerate: fromRational :: Fractional a => Rational -> Exp a
- Data.Array.Accelerate: index2 :: (Elt i, Slice (Z :. i)) => Exp i -> Exp i -> Exp ((Z :. i) :. i)
+ Data.Array.Accelerate: index2 :: (Elt i, Slice (Z :. i)) => Exp i -> Exp i -> Exp (Z :. i :. i)
- Data.Array.Accelerate: index3 :: (Elt i, Slice (Z :. i), Slice ((Z :. i) :. i)) => Exp i -> Exp i -> Exp i -> Exp (((Z :. i) :. i) :. i)
+ Data.Array.Accelerate: index3 :: (Elt i, Slice (Z :. i), Slice (Z :. i :. i)) => Exp i -> Exp i -> Exp i -> Exp (Z :. i :. i :. i)
- Data.Array.Accelerate: type Scalar e = Array DIM0 e
+ Data.Array.Accelerate: type Scalar = Array DIM0
- Data.Array.Accelerate: type Segments i = Vector i
+ Data.Array.Accelerate: type Segments = Vector
- Data.Array.Accelerate: type Vector e = Array DIM1 e
+ Data.Array.Accelerate: type Vector = Array DIM1
- Data.Array.Accelerate: unindex2 :: forall i. (Elt i, Slice (Z :. i)) => Exp ((Z :. i) :. i) -> Exp (i, i)
+ Data.Array.Accelerate: unindex2 :: forall i. (Elt i, Slice (Z :. i)) => Exp (Z :. i :. i) -> Exp (i, i)
- Data.Array.Accelerate: unindex3 :: forall i. (Elt i, Slice (Z :. i), Slice ((Z :. i) :. i)) => Exp (((Z :. i) :. i) :. i) -> Exp (i, i, i)
+ Data.Array.Accelerate: unindex3 :: forall i. (Elt i, Slice (Z :. i), Slice (Z :. i :. i)) => Exp (Z :. i :. i :. i) -> Exp (i, i, i)
- Data.Array.Accelerate.Data.Bits: class Eq a => Bits a where shift x i = cond (i < 0) (x `shiftR` (- i)) $ cond (i > 0) (x `shiftL` i) $ x rotate x i = cond (i < 0) (x `rotateR` (- i)) $ cond (i > 0) (x `rotateL` i) $ x zeroBits = clearBit (bit 0) 0 setBit x i = x .|. bit i clearBit x i = x .&. complement (bit i) complementBit x i = x `xor` bit i shiftL x i = x `shift` i unsafeShiftL = shiftL shiftR x i = x `shift` (- i) unsafeShiftR = shiftR rotateL x i = x `rotate` i rotateR x i = x `rotate` (- i)
+ Data.Array.Accelerate.Data.Bits: class Eq a => Bits a
- Data.Array.Accelerate.Data.Complex: (:+) :: ~a -> ~a -> Complex a
+ Data.Array.Accelerate.Data.Complex: (:+) :: !a -> !a -> Complex a
- Data.Array.Accelerate.Data.Complex: cis :: forall a. Floating a => Exp a -> Exp (Complex a)
+ Data.Array.Accelerate.Data.Complex: cis :: forall a. (Floating a, Elt (Complex a)) => Exp a -> Exp (Complex a)
- Data.Array.Accelerate.Data.Complex: conjugate :: Num a => Exp (Complex a) -> Exp (Complex a)
+ Data.Array.Accelerate.Data.Complex: conjugate :: (Num a, Elt (Complex a)) => Exp (Complex a) -> Exp (Complex a)
- Data.Array.Accelerate.Data.Complex: data Complex a :: * -> *
+ Data.Array.Accelerate.Data.Complex: data Complex a
- Data.Array.Accelerate.Data.Complex: imag :: Elt a => Exp (Complex a) -> Exp a
+ Data.Array.Accelerate.Data.Complex: imag :: (Elt a, Elt (Complex a)) => Exp (Complex a) -> Exp a
- Data.Array.Accelerate.Data.Complex: magnitude :: RealFloat a => Exp (Complex a) -> Exp a
+ Data.Array.Accelerate.Data.Complex: magnitude :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp a
- Data.Array.Accelerate.Data.Complex: mkPolar :: forall a. Floating a => Exp a -> Exp a -> Exp (Complex a)
+ Data.Array.Accelerate.Data.Complex: mkPolar :: forall a. (Floating a, Elt (Complex a)) => Exp a -> Exp a -> Exp (Complex a)
- Data.Array.Accelerate.Data.Complex: phase :: RealFloat a => Exp (Complex a) -> Exp a
+ Data.Array.Accelerate.Data.Complex: phase :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp a
- Data.Array.Accelerate.Data.Complex: polar :: RealFloat a => Exp (Complex a) -> Exp (a, a)
+ Data.Array.Accelerate.Data.Complex: polar :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp (a, a)
- Data.Array.Accelerate.Data.Complex: real :: Elt a => Exp (Complex a) -> Exp a
+ Data.Array.Accelerate.Data.Complex: real :: (Elt a, Elt (Complex a)) => Exp (Complex a) -> Exp a
- Data.Array.Accelerate.Data.Monoid: (<>) :: Monoid m => m -> m -> m
+ Data.Array.Accelerate.Data.Monoid: (<>) :: Semigroup a => a -> a -> a
- Data.Array.Accelerate.Data.Monoid: class Monoid a
+ Data.Array.Accelerate.Data.Monoid: class Semigroup a => Monoid a
- Data.Array.Accelerate.Data.Monoid: newtype Product a :: * -> *
+ Data.Array.Accelerate.Data.Monoid: newtype Product a
- Data.Array.Accelerate.Data.Monoid: newtype Sum a :: * -> *
+ Data.Array.Accelerate.Data.Monoid: newtype Sum a

Files

CHANGELOG.md view
@@ -6,14 +6,40 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [1.2.0.0] - 2018-04-03+### Changed+  * Internal debugging/RTS options handling has been changed. Compiling this package now implies that backends are also compiled in debug mode (no need to set the `-fdebug` cabal flag for those packages as well).+  * Complex numbers are stored in the C-style array-of-struct representation.+  * Improve numeric handling of complex numbers.+  * Coercions (`bitcast`) now occur between the underlying representation types+  * Front-end performance improvements +### Added+  * Support for half-precision floating-point numbers.+  * Support for struct-of-array-of-struct representations. Currently this is limited to fields of 2,3,4,8, or 16-elements wide.+  * Add equivalents for `Data.Functor`, `Data.Semigroup` (ghc-8+)+  * Add instances and helper functions for `Maybe` and `Either` types+  * Add rank generalised versions of `take`, `drop`, `head`, `tail`, `init`, `slit`, `reverse` and `transpose`.+  * Implement counters and reporting for `-ddump-gc-stats`++### Contributors++Special thanks to those who contributed patches as part of this release:++  * Trevor L. McDonell (@tmcdonell)+  * Ryan Scott (@ryanglscott)+  * Rinat Striungis (@Haskell-mouse)++ ## [1.1.1.0] - 2017-09-26 ### Changed   * Improve and colourise the pretty-printer + ## [1.1.0.0] - 2017-09-21 ### Added   * Additional EKG monitoring hooks ([#340])+   * Operations from `RealFloat`  ### Changed@@ -29,16 +55,20 @@ ### Fixed   * [#390]: Wrong number of arguments in printf + ## [1.0.0.0] - 2017-03-31   * Many API and internal changes   * Bug fixes and other enhancements + ## [0.15.1.0]   * Fix type of `allocateArray` + ## [0.15.0.0]   * Bug fixes and performance improvements. + ## [0.14.0.0]   * New iteration constructs.   * Additional Prelude-like functions.@@ -46,6 +76,7 @@   * Concurrent kernel execution in the CUDA backend.   * Bug fixes. + ## [0.13.0.0]   * New array fusion optimisation.   * New foreign function interface for array and scalar expressions.@@ -53,23 +84,27 @@   * New example programs.   * Bug fixes and performance improvements. + ## [0.12.0.0]   * Full sharing recovery in scalar expressions and array computations.   * Two new example applications in package `accelerate-examples` (both including a graphical frontend):-    * A real-time Canny edge detection +    * A real-time Canny edge detection     * An interactive fluid flow simulator   * Bug fixes. + ## [0.11.0.0]   * New Prelude-like functions `zip*`, `unzip*`, `fill`, `enumFrom*`, `tail`,     `init`, `drop`, `take`, `slit`, `gather*`, `scatter*`, and `shapeSize`.   * New simplified AST (in package `accelerate-backend-kit`) for backend writers     who want to avoid the complexities of the type-safe AST. + ## [0.10.0.0]   * Complete sharing recovery for scalar expressions (but currently disabled by default).   * Also bug fixes in array sharing recovery and a few new convenience functions. + ## [0.9.0.0]   * Streaming computations   * Precompilation@@ -79,18 +114,22 @@   * Conversions to other array formats   * Bug fixes + ## 0.8.1.0   * Bug fixes and some performance tweaks. + ## 0.8.0.0   * More collective operations supported by the CUDA backend: `replicate`,     `slice` and `foldSeg`. Frontend and interpreter support for `stencil`.   * Bug fixes. + ## [0.7.1.0]   * Initial release of the CUDA backend  +[1.2.0.0]:          https://github.com/AccelerateHS/accelerate/compare/v1.1.0.0...v1.2.0.0 [1.1.1.0]:          https://github.com/AccelerateHS/accelerate/compare/v1.1.0.0...v1.1.1.0 [1.1.0.0]:          https://github.com/AccelerateHS/accelerate/compare/1.0.0.0...v1.1.0.0 [1.0.0.0]:          https://github.com/AccelerateHS/accelerate/compare/0.15.1.0...1.0.0.0
− Data/Array/Accelerate.hs 
@@ -1,534 +0,0 @@--- |--- Module      : Data.Array.Accelerate--- 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)------ @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;--- 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:/]------ 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------ * <http://hackage.haskell.org/package/accelerate-llvm-native accelerate-llvm-native>:---   implementation supporting parallel execution on multicore CPUs (e.g. x86).------ * <http://hackage.haskell.org/package/accelerate-llvm-ptx accelerate-llvm-ptx>:---   implementation supporting parallel execution on CUDA-capable NVIDIA GPUs.------ [/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-blas accelerate-blas>: BLAS--- and LAPACK operations, 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-  -- ** Embedded array computations-  Acc,--  -- *** Arrays-  Array, Arrays, Scalar, Vector, Segments,--  -- *** Array elements-  Elt,--  -- *** Array shapes & indices-  -- $shapes_and_indices-  ---  Z(..), (:.)(..),-  DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9,-  Shape, Slice(..), All(..), Any(..),-  -- Split(..), Divide(..), Division(..),--  -- ** Array access-  -- *** Element indexing-  (!), (!!), the,--  -- *** Shape information-  null, length, shape, size, shapeSize,--  -- ** Construction-  -- *** Introduction-  use, unit,--  -- *** Initialisation-  generate, fill,--  -- *** Enumeration-  enumFromN, enumFromStepN,--  -- *** Concatenation-  (++),--  -- ** Composition-  -- *** Flow control-  (?|), acond, awhile,-  IfThenElse(..),--  -- *** Controlling execution-  (>->),-  compute,--  -- ** Element-wise operations-  -- *** Indexing-  indexed,--  -- *** Mapping-  map, imap,--  -- *** Zipping-  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-  unzip, unzip3, unzip4, unzip5, unzip6, unzip7, unzip8, unzip9,--  -- ** Modifying Arrays-  -- *** Shape manipulation-  reshape, flatten,--  -- *** Replication-  replicate,--  -- *** 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-  fold, fold1, foldAll, fold1All,--  -- *** Segmented reductions-  foldSeg, fold1Seg,--  -- *** Specialised reductions-  all, any, and, or, sum, product, minimum, maximum,--  -- ** Scans (prefix sums)-  scanl, scanl1, scanl', scanr, scanr1, scanr',-  prescanl, postscanl, prescanr, postscanr,--  -- *** Segmented scans-  scanlSeg, scanl1Seg, scanl'Seg, prescanlSeg, postscanlSeg,-  scanrSeg, scanr1Seg, scanr'Seg, prescanrSeg, postscanrSeg,--  -- ** Stencils-  stencil, stencil2,--  -- *** Stencil specification-  Stencil, Boundary,-  clamp, mirror, wrap, function,--  -- *** Common stencil patterns-  Stencil3, Stencil5, Stencil7, Stencil9,-  Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5,-  Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,-  Stencil3x5x5, Stencil5x5x5,--  -- -- ** 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-  Exp,--  -- ** Type classes-  -- *** Basic type classes-  Eq(..),-  Ord(..),-  -- Enum, -- vacuous-  Bounded, minBound, maxBound,--  -- *** 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(..),--  -- *** Numeric conversion classes-  FromIntegral(..),-  ToFloating(..),--  -- ** Lifting and Unlifting-  -- $lifting_and_unlifting-  ---  Lift(..), Unlift(..),-  lift1, lift2, lift3,-  ilift1, ilift2, ilift3,--  -- ** Scalar operations-  -- *** Introduction-  constant,--  -- *** Tuples-  fst, afst, snd, asnd, curry, uncurry,--  -- *** Flow control-  (?), caseof, cond, while, iterate,--  -- *** Scalar reduction-  sfoldl,--  -- *** Logical operations-  (&&), (||), not,--  -- *** Numeric operations-  subtract, even, odd, gcd, lcm, (^), (^^),--  -- *** Shape manipulation-  index0, index1, unindex1, index2, unindex2, index3, unindex3,-  indexHead, indexTail,-  toIndex, fromIndex,-  intersect,--  -- *** Conversions-  ord, chr, boolToInt, bitcast,--  -- ----------------------------------------------------------------------------  -- * Foreign Function Interface (FFI)-  foreignAcc,-  foreignExp,--  -- ----------------------------------------------------------------------------  -- * Plain arrays-  -- ** Operations-  arrayRank, arrayShape, arraySize, indexArray,--  -- ** Getting data in-  -- $getting_data_in--  -- *** Function-  fromFunction,--  -- *** Lists-  fromList, toList,--  -- ----------------------------------------------------------------------------  -- * 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.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---- 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.----indexArray :: Array sh e -> sh -> e-indexArray = (S.!)---- | Rank of an array.----arrayRank :: Shape sh => sh -> Int-arrayRank = S.rank---- |Array shape in plain Haskell code.----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 :: Shape sh => sh -> Int-arraySize = S.size---- Named documentation chunks--- ------------------------------ $shapes_and_indices------ 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----
− Data/Array/Accelerate/AST.hs 
@@ -1,1893 +0,0 @@-{-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE QuasiQuotes           #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeSynonymInstances  #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.AST--- 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  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ /Scalar versus collective operations/------ The embedded array processing language is a two-level language.  It--- combines a language of scalar expressions and functions with a language of--- collective array operations.  Scalar expressions are used to compute--- arguments for collective operations and scalar functions are used to--- parametrise higher-order, collective array operations.  The two-level--- structure, in particular, ensures that collective operations cannot be--- parametrised with collective operations; hence, we are following a flat--- data-parallel model.  The collective operations manipulate--- multi-dimensional arrays whose shape is explicitly tracked in their types.--- In fact, collective operations cannot produce any values other than--- multi-dimensional arrays; when they yield a scalar, this is in the form of--- a 0-dimensional, singleton array.  Similarly, scalar expression can -as--- their name indicates- only produce tuples of scalar, but not arrays.------ There are, however, two expression forms that take arrays as arguments.  As--- a result scalar and array expressions are recursively dependent.  As we--- cannot and don't want to compute arrays in the middle of scalar--- computations, array computations will always be hoisted out of scalar--- expressions.  So that this is always possible, these array expressions may--- not contain any free scalar variables.  To express that condition in the--- type structure, we use separate environments for scalar and array variables.------ /Programs/------ Collective array programs comprise closed expressions of array operations.--- There is no explicit sharing in the initial AST form, but sharing is--- introduced subsequently by common subexpression elimination and floating--- of array computations.------ /Functions/------ The array expression language is first-order and only provides limited--- control structures to ensure that it can be efficiently executed on--- compute-acceleration hardware, such as GPUs.  To restrict functions to--- first-order, we separate function abstraction from the main expression--- type.  Functions are represented using de Bruijn indices.------ /Parametric and ad-hoc polymorphism/------ The array language features paramatric polymophism (e.g., pairing and--- projections) as well as ad-hoc polymorphism (e.g., arithmetic operations).--- All ad-hoc polymorphic constructs include reified dictionaries (c.f.,--- module 'Types').  Reified dictionaries also ensure that constants--- (constructor 'Const') are representable on compute acceleration hardware.------ The AST contains both reified dictionaries and type class constraints.--- Type classes are used for array-related functionality that is uniformly--- available for all supported types.  In contrast, reified dictionaries are--- used for functionality that is only available for certain types, such as--- arithmetic operations.-----module Data.Array.Accelerate.AST (--  -- * Typed de Bruijn indices-  Idx(..), idxToInt, tupleIdxToInt,--  -- * Valuation environment-  Val(..), ValElt(..), prj, prjElt,--  -- * Accelerated array expressions-  PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc,-  PreBoundary(..), Boundary, 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,--  -- TemplateHaskell-  LiftAcc,-  liftIdx, liftTupleIdx, liftArrays,-  liftConst, liftSliceIndex, liftPrimConst, liftPrimFun,-  liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp,--  -- debugging-  showPreAccOp, showPreExpOp,--) where----standard library-import Control.DeepSeq-import Data.List-import Data.Typeable-import Foreign.ForeignPtr-import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable-import GHC.Ptr                                                      ( Ptr(..) )-import System.IO.Unsafe-import Language.Haskell.TH                                          ( Q, TExp )-import qualified Language.Haskell.TH                                as TH-import qualified Language.Haskell.TH.Syntax                         as TH-#if __GLASGOW_HASKELL__ <= 708-import Instances.TH.Lift                                            () -- Int8, Int16...-#endif---- friends-import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Representation                   ( SliceIndex(..), size )-import Data.Array.Accelerate.Array.Sugar                            hiding ( size )-import Data.Array.Accelerate.Array.Unique-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Type-#if __GLASGOW_HASKELL__ < 800-import Data.Array.Accelerate.Error-#endif----- Typed de Bruijn indices--- --------------------------- De Bruijn variable index projecting a specific type from a type--- environment.  Type environments are nested pairs (..((), t1), t2, ..., tn).----data Idx env t where-  ZeroIdx ::              Idx (env, t) t-  SuccIdx :: Idx env t -> Idx (env, s) t---- de Bruijn Index to Int conversion----idxToInt :: Idx env t -> Int-idxToInt ZeroIdx       = 0-idxToInt (SuccIdx idx) = 1 + idxToInt idx--tupleIdxToInt :: TupleIdx tup e -> Int-tupleIdxToInt ZeroTupIdx       = 0-tupleIdxToInt (SuccTupIdx idx) = 1 + tupleIdxToInt idx----- Environments--- ---------------- Valuation for an environment----data Val env where-  Empty :: Val ()-  Push  :: Val env -> t -> Val (env, t)--deriving instance Typeable Val---- Valuation for an environment of array elements----data ValElt env where-  EmptyElt :: ValElt ()-  PushElt  :: Elt t-           => ValElt env -> EltRepr t -> ValElt (env, t)---- Projection of a value from a valuation using a de Bruijn index----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) = toElt v-prjElt (SuccIdx idx) (PushElt val _) = prjElt idx val-#if __GLASGOW_HASKELL__ < 800-prjElt _             _               = $internalError "prjElt" "inconsistent valuation"-#endif---- Array expressions--- --------------------- |Function abstraction over parametrised array computations----data PreOpenAfun acc aenv t where-  Abody :: Arrays t => acc             aenv      t -> PreOpenAfun acc aenv t-  Alam  :: Arrays a => PreOpenAfun acc (aenv, a) t -> PreOpenAfun acc aenv (a -> t)---- Function abstraction over vanilla open array computations----type OpenAfun = PreOpenAfun OpenAcc---- |Parametrised array-computation function without free array variables----type PreAfun acc = PreOpenAfun acc ()---- |Vanilla array-computation function without free array variables----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.------ * Scalar functions and expressions embedded in well-formed array---   computations cannot contain free scalar variable indices.  The latter---   cannot be bound in array computations, and hence, cannot appear in any---   well-formed program.------ * The let-form is used to represent the sharing discovered by common---   subexpression elimination as well as to control evaluation order.  (We---   need to hoist array expressions out of scalar expressions - they occur in---   scalar indexing and in determining an arrays shape.)------ The data type is parameterised over the surface types (not the representation--- type).------ We use a non-recursive variant parametrised over the recursive closure, to facilitate attribute--- calculation in the backend.----data PreOpenAcc acc aenv a where--  -- Local binding to represent sharing and demand explicitly; this is an-  -- eager(!) binding-  Alet        :: (Arrays bndArrs, Arrays bodyArrs)-              => acc            aenv            bndArrs         -- bound expression-              -> acc            (aenv, bndArrs) bodyArrs        -- the bound expression scope-              -> PreOpenAcc acc aenv            bodyArrs--  -- Variable bound by a 'Let', represented by a de Bruijn index-  Avar        :: Arrays arrs-              => Idx            aenv arrs-              -> PreOpenAcc acc aenv arrs--  -- Tuples of arrays-  Atuple      :: (Arrays arrs, IsAtuple arrs)-              => Atuple    (acc aenv) (TupleRepr arrs)-              -> PreOpenAcc acc aenv  arrs--  Aprj        :: (Arrays arrs, IsAtuple arrs, Arrays a)-              => TupleIdx (TupleRepr arrs) a-              ->            acc aenv arrs-              -> PreOpenAcc acc aenv a--  -- Array-function application.-  ---  -- The array function is not closed at the core level because we need access-  -- to free variables introduced by 'run1' style evaluators. See Issue#95.-  ---  Apply       :: (Arrays arrs1, Arrays arrs2)-              => PreOpenAfun acc aenv (arrs1 -> arrs2)-              -> acc             aenv arrs1-              -> PreOpenAcc  acc aenv arrs2--  -- 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 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-              => PreExp     acc aenv Bool-              -> acc            aenv arrs-              -> acc            aenv arrs-              -> PreOpenAcc acc aenv arrs--  -- Value-recursion for array-level computations-  Awhile      :: Arrays arrs-              => PreOpenAfun acc aenv (arrs -> Scalar Bool)     -- continue iteration while true-              -> PreOpenAfun acc aenv (arrs -> arrs)            -- function to iterate-              -> acc             aenv arrs                      -- initial value-              -> PreOpenAcc  acc aenv arrs---  -- Array inlet (triggers async host->device transfer if necessary)-  Use         :: Arrays arrs-              => ArrRepr arrs-              -> PreOpenAcc acc aenv arrs--  -- Capture a scalar (or a tuple of scalars) in a singleton array-  Unit        :: Elt e-              => PreExp     acc aenv e-              -> PreOpenAcc acc aenv (Scalar e)--  -- Change the shape of an array without altering its contents-  -- > precondition: size dim == size dim'-  Reshape     :: (Shape sh, Shape sh', Elt e)-              => PreExp     acc aenv sh                         -- new shape-              -> acc            aenv (Array sh' e)              -- array to be reshaped-              -> PreOpenAcc acc aenv (Array sh e)--  -- Construct a new array by applying a function to each index.-  Generate    :: (Shape sh, Elt e)-              => PreExp     acc aenv sh                         -- output shape-              -> PreFun     acc aenv (sh -> e)                  -- representation function-              -> PreOpenAcc acc aenv (Array sh e)--  -- Hybrid map/backpermute, where we separate the index and value-  -- transformations.-  Transform   :: (Elt a, Elt b, Shape sh, Shape sh')-              => PreExp     acc aenv sh'                        -- dimension of the result-              -> PreFun     acc aenv (sh' -> sh)                -- index permutation function-              -> PreFun     acc aenv (a   -> b)                 -- function to apply at each element-              ->            acc aenv (Array sh  a)              -- source array-              -> PreOpenAcc acc aenv (Array sh' b)--  -- Replicate an array across one or more dimensions as given by the first-  -- argument-  Replicate   :: (Shape sh, Shape sl, Elt slix, Elt e)-              => SliceIndex (EltRepr slix)                      -- slice type specification-                            (EltRepr sl)-                            co-                            (EltRepr sh)-              -> PreExp     acc aenv slix                       -- slice value specification-              -> acc            aenv (Array sl e)               -- data to be replicated-              -> PreOpenAcc acc aenv (Array sh e)--  -- Index a sub-array out of an array; i.e., the dimensions not indexed are-  -- returned whole-  Slice       :: (Shape sh, Shape sl, Elt slix, Elt e)-              => SliceIndex (EltRepr slix)                      -- slice type specification-                            (EltRepr sl)-                            co-                            (EltRepr sh)-              -> acc            aenv (Array sh e)               -- array to be indexed-              -> PreExp     acc aenv slix                       -- slice value specification-              -> PreOpenAcc acc aenv (Array sl e)--  -- Apply the given unary function to all elements of the given array-  Map         :: (Shape sh, Elt e, Elt e')-              => PreFun     acc aenv (e -> e')-              -> acc            aenv (Array sh e)-              -> PreOpenAcc acc aenv (Array sh e')--  -- Apply a given binary function pairwise to all elements of the given arrays.-  -- The length of the result is the length of the shorter of the two argument-  -- arrays.-  ZipWith     :: (Shape sh, Elt e1, Elt e2, Elt e3)-              => PreFun     acc aenv (e1 -> e2 -> e3)-              -> acc            aenv (Array sh e1)-              -> acc            aenv (Array sh e2)-              -> PreOpenAcc acc aenv (Array sh e3)--  -- Fold along the innermost dimension of an array with a given /associative/ function.-  Fold        :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- default value-              -> acc            aenv (Array (sh:.Int) e)        -- folded array-              -> PreOpenAcc acc aenv (Array sh e)--  -- 'Fold' without a default value-  Fold1       :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Array (sh:.Int) e)        -- folded array-              -> PreOpenAcc acc aenv (Array sh e)--  -- Segmented fold along the innermost dimension of an array with a given /associative/ function-  FoldSeg     :: (Shape sh, Elt e, Elt i, IsIntegral i)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- default value-              -> acc            aenv (Array (sh:.Int) e)        -- folded array-              -> acc            aenv (Segments i)               -- segment descriptor-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- 'FoldSeg' without a default value-  Fold1Seg    :: (Shape sh, Elt e, Elt i, IsIntegral i)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Array (sh:.Int) e)        -- folded array-              -> acc            aenv (Segments i)               -- segment descriptor-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- 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       :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- initial value-              -> 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'      :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e, Array sh e)--  -- Haskell-style scan without an initial value-  Scanl1      :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- Right-to-left version of 'Scanl'-  Scanr       :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e)--  -- Right-to-left version of 'Scanl\''-  Scanr'      :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> PreExp     acc aenv e                          -- initial value-              -> acc            aenv (Array (sh:.Int) e)-              -> PreOpenAcc acc aenv (Array (sh:.Int) e, Array sh e)--  -- Right-to-left version of 'Scanl1'-  Scanr1      :: (Shape sh, Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> 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-  -- the output. The permutation can be between arrays of varying shape and-  -- dimensionality.-  ---  -- Other characteristics of the permutation function 'f':-  ---  --   1. 'f' is a partial function: if it evaluates to the magic value 'ignore'-  --      (i.e. a tuple of -1 values) then those elements of the domain are-  --      dropped.-  ---  --   2. 'f' is not surjective: positions in the target array need not be-  --      picked up by the permutation function, so the target array must first-  --      be initialised from an array of default values.-  ---  --   3. 'f' is not injective: distinct elements of the domain may map to the-  --      same position in the target array. In this case the combination-  --      function is used to combine elements, which needs to be /associative/-  --      and /commutative/.-  ---  Permute     :: (Shape sh, Shape sh', Elt e)-              => PreFun     acc aenv (e -> e -> e)              -- combination function-              -> acc            aenv (Array sh' e)              -- default values-              -> PreFun     acc aenv (sh -> sh')                -- permutation function-              -> acc            aenv (Array sh e)               -- source array-              -> PreOpenAcc acc aenv (Array sh' e)--  -- Generalised multi-dimensional backwards permutation; the permutation can-  -- be between arrays of varying shape; the permutation function must be total-  Backpermute :: (Shape sh, Shape sh', Elt e)-              => PreExp     acc aenv sh'                        -- dimensions of the result-              -> PreFun     acc aenv (sh' -> sh)                -- permutation function-              -> acc            aenv (Array sh e)               -- source array-              -> PreOpenAcc acc aenv (Array sh' e)--  -- Map a stencil over an array.  In contrast to 'map', the domain of a stencil function is an-  -- entire /neighbourhood/ of each array element.-  Stencil     :: (Elt e, Elt e', Stencil sh e stencil)-              => PreFun      acc aenv (stencil -> e')           -- stencil function-              -> PreBoundary acc aenv (Array sh e)              -- boundary condition-              -> acc             aenv (Array sh e)              -- source array-              -> PreOpenAcc  acc aenv (Array sh e')--  -- Map a binary stencil over an array.-  Stencil2    :: (Elt a, Elt b, Elt c, Stencil sh a stencil1, Stencil sh b stencil2)-              => PreFun      acc aenv (stencil1 -> stencil2 -> c) -- stencil function-              -> PreBoundary acc aenv (Array sh a)                -- boundary condition #1-              -> acc             aenv (Array sh a)                -- source array #1-              -> PreBoundary acc aenv (Array sh b)                -- boundary condition #2-              -> acc             aenv (Array sh b)                -- source array #2-              -> PreOpenAcc acc  aenv (Array sh c)--  -- A sequence of operations.-  -- Collect     :: Arrays arrs-  --             => PreOpenSeq acc aenv () arrs-  --             -> PreOpenAcc acc aenv arrs--{---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--  Consumer :: Arrays arrs-           => Consumer acc aenv senv arrs-           -> PreOpenSeq acc aenv senv arrs--  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 Seq = PreOpenSeq OpenAcc () ()---}----- | Vanilla stencil boundary condition----type Boundary = PreBoundary OpenAcc---- | Boundary condition specification for stencil operations----data PreBoundary (acc :: * -> * -> *) aenv t where-  -- Clamp coordinates to the extent of the array-  Clamp     :: PreBoundary acc aenv t--  -- Mirror coordinates beyond the array extent-  Mirror    :: PreBoundary acc aenv t--  -- Wrap coordinates around on each dimension-  Wrap      :: PreBoundary acc aenv t--  -- Use a constant value for outlying coordinates-  Constant  :: Elt e-            => EltRepr e-            -> PreBoundary acc aenv (Array sh e)--  -- Apply the given function to outlying coordinates-  Function  :: (Shape sh, Elt e)-            => PreFun acc aenv (sh -> e)-            -> PreBoundary acc aenv (Array sh e)----- | Operations on stencils----class (Shape sh, Elt e, IsTuple stencil, Elt stencil) => Stencil sh e stencil where-  stencil :: StencilR sh e stencil---- | GADT reifying the 'Stencil' class----data StencilR sh e pat where-  StencilRunit3 :: Elt e => StencilR DIM1 e (e,e,e)-  StencilRunit5 :: Elt e => StencilR DIM1 e (e,e,e,e,e)-  StencilRunit7 :: Elt e => StencilR DIM1 e (e,e,e,e,e,e,e)-  StencilRunit9 :: Elt e => StencilR DIM1 e (e,e,e,e,e,e,e,e,e)--  StencilRtup3  :: (Shape sh, Elt e)-                => StencilR sh e pat1-                -> StencilR sh e pat2-                -> StencilR sh e pat3-                -> StencilR (sh:.Int) e (pat1,pat2,pat3)--  StencilRtup5  :: (Shape sh, Elt e)-                => StencilR sh e pat1-                -> StencilR sh e pat2-                -> StencilR sh e pat3-                -> StencilR sh e pat4-                -> StencilR sh e pat5-                -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5)--  StencilRtup7  :: (Shape sh, Elt e)-                => StencilR sh e pat1-                -> StencilR sh e pat2-                -> StencilR sh e pat3-                -> StencilR sh e pat4-                -> StencilR sh e pat5-                -> StencilR sh e pat6-                -> StencilR sh e pat7-                -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7)--  StencilRtup9  :: (Shape sh, Elt e)-                => StencilR sh e pat1-                -> StencilR sh e pat2-                -> StencilR sh e pat3-                -> StencilR sh e pat4-                -> StencilR sh e pat5-                -> StencilR sh e pat6-                -> StencilR sh e pat7-                -> StencilR sh e pat8-                -> StencilR sh e pat9-                -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7,pat8,pat9)----- Note: [Stencil reification class]------ We cannot start with 'DIM0'.  The 'IsTuple stencil' superclass would at--- 'DIM0' imply that the types of individual array elements are in 'IsTuple'.--- (That would only possible if we could have (degenerate) 1-tuple, but we can't--- as we can't distinguish between a 1-tuple of a pair and a simple pair.)--- Hence, we need to start from 'DIM1' and use 'sh:.Int:.Int' in the recursive--- case (to avoid overlapping instances).---- DIM1-instance Elt e => Stencil DIM1 e (e, e, e) where-  stencil = StencilRunit3--instance Elt e => Stencil DIM1 e (e, e, e, e, e) where-  stencil = StencilRunit5--instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e) where-  stencil = StencilRunit7--instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e, e, e) where-  stencil = StencilRunit9---- DIM(n+1), where n>1-instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3) => Stencil (sh:.Int:.Int) a (row1, row2, row3) where-  stencil = StencilRtup3 stencil stencil stencil--instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3,-          Stencil (sh:.Int) a row4,-          Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where-  stencil = StencilRtup5 stencil stencil stencil stencil stencil--instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3,-          Stencil (sh:.Int) a row4,-          Stencil (sh:.Int) a row5,-          Stencil (sh:.Int) a row6,-          Stencil (sh:.Int) a row7)-  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where-  stencil = StencilRtup7 stencil stencil stencil stencil stencil stencil stencil--instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3,-          Stencil (sh:.Int) a row4,-          Stencil (sh:.Int) a row5,-          Stencil (sh:.Int) a row6,-          Stencil (sh:.Int) a row7,-          Stencil (sh:.Int) a row8,-          Stencil (sh:.Int) a row9)-  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where-  stencil = StencilRtup9 stencil stencil stencil stencil stencil stencil stencil stencil stencil----- Embedded expressions--- ------------------------ |Parametrised open function abstraction----data PreOpenFun (acc :: * -> * -> *) env aenv t where-  Body :: Elt t => PreOpenExp acc env      aenv t -> PreOpenFun acc env aenv t-  Lam  :: Elt a => PreOpenFun acc (env, a) aenv t -> PreOpenFun acc env aenv (a -> t)---- |Vanilla open function abstraction----type OpenFun = PreOpenFun OpenAcc---- |Parametrised function without free scalar variables----type PreFun acc = PreOpenFun acc ()---- |Vanilla function without free scalar variables----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.------ The data type is parametrised over the surface types (not the representation type).----data PreOpenExp (acc :: * -> * -> *) env aenv t where--  -- Local binding of a scalar expression-  Let           :: (Elt bnd_t, Elt body_t)-                => PreOpenExp acc env          aenv bnd_t-                -> PreOpenExp acc (env, bnd_t) aenv body_t-                -> PreOpenExp acc env          aenv body_t--  -- Variable index, ranging only over tuples or scalars-  Var           :: Elt t-                => Idx env t-                -> PreOpenExp acc env aenv t--  -- Apply a backend-specific foreign function-  Foreign       :: (Foreign asm, Elt x, Elt y)-                => asm           (x -> y)-                -> PreFun acc () (x -> y)-                -> PreOpenExp acc env aenv x-                -> PreOpenExp acc env aenv y--  -- Constant values-  Const         :: Elt t-                => EltRepr t-                -> PreOpenExp acc env aenv t--  -- Tuples-  Tuple         :: (Elt t, IsTuple t)-                => Tuple (PreOpenExp acc env aenv) (TupleRepr t)-                -> PreOpenExp acc env aenv t--  Prj           :: (Elt t, IsTuple t, Elt e)-                => TupleIdx (TupleRepr t) e-                -> PreOpenExp acc env aenv t-                -> PreOpenExp acc env aenv e--  -- Array indices & shapes-  IndexNil      :: PreOpenExp acc env aenv Z--  IndexCons     :: (Slice sl, Elt a)-                => PreOpenExp acc env aenv sl-                -> PreOpenExp acc env aenv a-                -> PreOpenExp acc env aenv (sl:.a)--  IndexHead     :: (Slice sl, Elt a)-                => PreOpenExp acc env aenv (sl:.a)-                -> PreOpenExp acc env aenv a--  IndexTail     :: (Slice sl, Elt a)-                => PreOpenExp acc env aenv (sl:.a)-                -> PreOpenExp acc env aenv sl--  IndexAny      :: Shape sh-                => PreOpenExp acc env aenv (Any sh)--  IndexSlice    :: (Shape sh, Shape sl, Elt slix)-                => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-                -> PreOpenExp acc env aenv slix-                -> PreOpenExp acc env aenv sh-                -> PreOpenExp acc env aenv sl--  IndexFull     :: (Shape sh, Shape sl, Elt slix)-                => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-                -> PreOpenExp acc env aenv slix-                -> PreOpenExp acc env aenv sl-                -> PreOpenExp acc env aenv sh--  -- Shape and index conversion-  ToIndex       :: Shape sh-                => PreOpenExp acc env aenv sh           -- shape of the array-                -> PreOpenExp acc env aenv sh           -- index into the array-                -> PreOpenExp acc env aenv Int--  FromIndex     :: Shape sh-                => PreOpenExp acc env aenv sh           -- shape of the array-                -> PreOpenExp acc env aenv Int          -- index into linear representation-                -> PreOpenExp acc env aenv sh--  -- Conditional expression (non-strict in 2nd and 3rd argument)-  Cond          :: Elt t-                => PreOpenExp acc env aenv Bool-                -> PreOpenExp acc env aenv t-                -> PreOpenExp acc env aenv t-                -> PreOpenExp acc env aenv t--  -- Value recursion-  While         :: Elt a-                => PreOpenFun acc env aenv (a -> Bool)  -- continue while true-                -> PreOpenFun acc env aenv (a -> a)     -- function to iterate-                -> PreOpenExp acc env aenv a            -- initial value-                -> PreOpenExp acc env aenv a--  -- Primitive constants-  PrimConst     :: Elt t-                => PrimConst t-                -> PreOpenExp acc env aenv t--  -- Primitive scalar operations-  PrimApp       :: (Elt a, Elt r)-                => PrimFun (a -> r)-                -> PreOpenExp acc env aenv a-                -> PreOpenExp acc env aenv r--  -- Project a single scalar from an array.-  -- The array expression can not contain any free scalar variables.-  Index         :: (Shape dim, Elt t)-                => acc                aenv (Array dim t)-                -> PreOpenExp acc env aenv dim-                -> PreOpenExp acc env aenv t--  LinearIndex   :: (Shape dim, Elt t)-                => acc                aenv (Array dim t)-                -> PreOpenExp acc env aenv Int-                -> PreOpenExp acc env aenv t--  -- Array shape.-  -- The array expression can not contain any free scalar variables.-  Shape         :: (Shape dim, Elt e)-                => acc                aenv (Array dim e)-                -> PreOpenExp acc env aenv dim--  -- Number of elements of an array given its shape-  ShapeSize     :: Shape dim-                => PreOpenExp acc env aenv dim-                -> PreOpenExp acc env aenv Int--  -- Intersection of two shapes-  Intersect     :: Shape dim-                => PreOpenExp acc env aenv dim-                -> 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----- |Primitive constant values----data PrimConst ty where--  -- constants from Bounded-  PrimMinBound  :: BoundedType a -> PrimConst a-  PrimMaxBound  :: BoundedType a -> PrimConst a--  -- constant from Floating-  PrimPi        :: FloatingType a -> PrimConst a---- |Primitive scalar operations----data PrimFun sig where--  -- operators from Num-  PrimAdd  :: NumType a -> PrimFun ((a, a) -> a)-  PrimSub  :: NumType a -> PrimFun ((a, a) -> a)-  PrimMul  :: NumType a -> PrimFun ((a, a) -> a)-  PrimNeg  :: NumType a -> PrimFun (a      -> a)-  PrimAbs  :: NumType a -> PrimFun (a      -> a)-  PrimSig  :: NumType a -> PrimFun (a      -> a)--  -- 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)-  PrimDivMod   :: IntegralType a -> PrimFun ((a, a)   -> (a, a))--  -- 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)-  PrimCos         :: FloatingType a -> PrimFun (a      -> a)-  PrimTan         :: FloatingType a -> PrimFun (a      -> a)-  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)-  PrimExpFloating :: FloatingType a -> PrimFun (a      -> a)-  PrimSqrt        :: FloatingType a -> PrimFun (a      -> a)-  PrimLog         :: FloatingType a -> PrimFun (a      -> a)-  PrimFPow        :: FloatingType a -> PrimFun ((a, a) -> a)-  PrimLogBase     :: FloatingType a -> PrimFun ((a, a) -> a)--  -- 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-  PrimAtan2          :: FloatingType a -> PrimFun ((a, a) -> a)-  PrimIsNaN          :: FloatingType a -> PrimFun (a -> Bool)-  PrimIsInfinite     :: FloatingType a -> PrimFun (a -> Bool)-  -- 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)-  -- 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)-  PrimLtEq :: ScalarType a -> PrimFun ((a, a) -> Bool)-  PrimGtEq :: ScalarType a -> PrimFun ((a, a) -> Bool)-  PrimEq   :: ScalarType a -> PrimFun ((a, a) -> Bool)-  PrimNEq  :: ScalarType a -> PrimFun ((a, a) -> Bool)-  PrimMax  :: ScalarType a -> PrimFun ((a, a) -> a   )-  PrimMin  :: ScalarType a -> PrimFun ((a, a) -> a   )--  -- logical operators-  PrimLAnd :: PrimFun ((Bool, Bool) -> Bool)-  PrimLOr  :: PrimFun ((Bool, Bool) -> Bool)-  PrimLNot :: PrimFun (Bool         -> Bool)--  -- character conversions-  -- FIXME: use IntegralType?-  PrimOrd  :: PrimFun (Char -> Int)-  PrimChr  :: PrimFun (Int  -> Char)--  -- 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)--  -- 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 :: PreBoundary acc aenv' (Array sh e) -> ()-      rnfB = rnfBoundary rnfA-  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 b  `seq` rnfA a-    Stencil2 f b1 a1 b2 a2    -> rnfF f `seq` rnfB b1 `seq` rnfB 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 :: forall acc aenv sh e. NFDataAcc acc -> PreBoundary acc aenv (Array sh e) -> ()-rnfBoundary _    Clamp        = ()-rnfBoundary _    Mirror       = ()-rnfBoundary _    Wrap         = ()-rnfBoundary _    (Constant c) = rnfConst (eltType (undefined::e)) c-rnfBoundary rnfA (Function f) = rnfPreOpenFun rnfA f---{----- 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 (PrimIsInfinite 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) = ()----- Template Haskell--- ================--type LiftAcc acc = forall aenv a. acc aenv a -> Q (TExp (acc aenv a))--liftIdx :: Idx env t -> Q (TExp (Idx env t))-liftIdx ZeroIdx      = [|| ZeroIdx ||]-liftIdx (SuccIdx ix) = [|| SuccIdx $$(liftIdx ix) ||]--liftTupleIdx :: TupleIdx t e -> Q (TExp (TupleIdx t e))-liftTupleIdx ZeroTupIdx       = [|| ZeroTupIdx ||]-liftTupleIdx (SuccTupIdx tix) = [|| SuccTupIdx $$(liftTupleIdx tix) ||]---liftPreOpenAfun :: LiftAcc acc -> PreOpenAfun acc aenv t -> Q (TExp (PreOpenAfun acc aenv t))-liftPreOpenAfun liftA (Alam f)  = [|| Alam  $$(liftPreOpenAfun liftA f) ||]-liftPreOpenAfun liftA (Abody b) = [|| Abody $$(liftA b) ||]--liftPreOpenAcc-    :: forall acc aenv a.-       LiftAcc acc-    -> PreOpenAcc acc aenv a-    -> Q (TExp (PreOpenAcc acc aenv a))-liftPreOpenAcc liftA pacc =-  let-      liftE :: PreOpenExp acc env aenv t -> Q (TExp (PreOpenExp acc env aenv t))-      liftE = liftPreOpenExp liftA--      liftF :: PreOpenFun acc env aenv t -> Q (TExp (PreOpenFun acc env aenv t))-      liftF = liftPreOpenFun liftA--      liftAF :: PreOpenAfun acc aenv f -> Q (TExp (PreOpenAfun acc aenv f))-      liftAF = liftPreOpenAfun liftA--      liftB :: PreBoundary acc aenv (Array sh e) -> Q (TExp (PreBoundary acc aenv (Array sh e)))-      liftB = liftBoundary liftA--      liftAtuple :: Atuple (acc aenv) t -> Q (TExp (Atuple (acc aenv) t))-      liftAtuple NilAtup          = [|| NilAtup ||]-      liftAtuple (SnocAtup tup a) = [|| SnocAtup $$(liftAtuple tup) $$(liftA a) ||]-  in-  case pacc of-    Alet bnd body             -> [|| Alet $$(liftA bnd) $$(liftA body) ||]-    Avar ix                   -> [|| Avar $$(liftIdx ix) ||]-    Atuple tup                -> [|| Atuple $$(liftAtuple tup) ||]-    Aprj tix a                -> [|| Aprj $$(liftTupleIdx tix) $$(liftA a) ||]-    Apply f a                 -> [|| Apply $$(liftAF f) $$(liftA a) ||]-    Aforeign asm f a          -> [|| Aforeign $$(liftForeign asm) $$(liftPreOpenAfun liftA f) $$(liftA a) ||]-    Acond p t e               -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||]-    Awhile p f a              -> [|| Awhile $$(liftAF p) $$(liftAF f) $$(liftA a) ||]-    Use a                     -> [|| Use $$(liftArrays (arrays (undefined::a)) a) ||]-    Unit e                    -> [|| Unit $$(liftE e) ||]-    Reshape sh a              -> [|| Reshape $$(liftE sh) $$(liftA a) ||]-    Generate sh f             -> [|| Generate $$(liftE sh) $$(liftF f) ||]-    Transform sh p f a        -> [|| Transform $$(liftE sh) $$(liftF p) $$(liftF f) $$(liftA a) ||]-    Replicate slix sl a       -> [|| Replicate $$(liftSliceIndex slix) $$(liftE sl) $$(liftA a) ||]-    Slice slix a sh           -> [|| Slice $$(liftSliceIndex slix) $$(liftA a) $$(liftE sh) ||]-    Map f a                   -> [|| Map $$(liftF f) $$(liftA a) ||]-    ZipWith f a b             -> [|| ZipWith $$(liftF f) $$(liftA a) $$(liftA b) ||]-    Fold f z a                -> [|| Fold $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Fold1 f a                 -> [|| Fold1 $$(liftF f) $$(liftA a) ||]-    FoldSeg f z a s           -> [|| FoldSeg $$(liftF f) $$(liftE z) $$(liftA a) $$(liftA s) ||]-    Fold1Seg f a s            -> [|| Fold1Seg $$(liftF f) $$(liftA a) $$(liftA s) ||]-    Scanl f z a               -> [|| Scanl $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Scanl1 f a                -> [|| Scanl1 $$(liftF f) $$(liftA a) ||]-    Scanl' f z a              -> [|| Scanl' $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Scanr f z a               -> [|| Scanr $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Scanr1 f a                -> [|| Scanr1 $$(liftF f) $$(liftA a) ||]-    Scanr' f z a              -> [|| Scanr' $$(liftF f) $$(liftE z) $$(liftA a) ||]-    Permute f d p a           -> [|| Permute $$(liftF f) $$(liftA d) $$(liftF p) $$(liftA a) ||]-    Backpermute sh p a        -> [|| Backpermute $$(liftE sh) $$(liftF p) $$(liftA a) ||]-    Stencil f b a             -> [|| Stencil $$(liftF f) $$(liftB b) $$(liftA a) ||]-    Stencil2 f b1 a1 b2 a2    -> [|| Stencil2 $$(liftF f) $$(liftB b1) $$(liftA a1) $$(liftB b2) $$(liftA a2) ||]---liftPreOpenFun-    :: LiftAcc acc-    -> PreOpenFun acc env aenv t-    -> Q (TExp (PreOpenFun acc env aenv t))-liftPreOpenFun liftA (Lam f)  = [|| Lam  $$(liftPreOpenFun liftA f) ||]-liftPreOpenFun liftA (Body b) = [|| Body $$(liftPreOpenExp liftA b) ||]--liftPreOpenExp-    :: forall acc env aenv t.-       LiftAcc acc-    -> PreOpenExp acc env aenv t-    -> Q (TExp (PreOpenExp acc env aenv t))-liftPreOpenExp liftA pexp =-  let-      liftE :: PreOpenExp acc env aenv e -> Q (TExp (PreOpenExp acc env aenv e))-      liftE = liftPreOpenExp liftA--      liftF :: PreOpenFun acc env aenv f -> Q (TExp (PreOpenFun acc env aenv f))-      liftF = liftPreOpenFun liftA--      liftT :: Tuple (PreOpenExp acc env aenv) e -> Q (TExp (Tuple (PreOpenExp acc env aenv) e))-      liftT NilTup          = [|| NilTup ||]-      liftT (SnocTup tup e) = [|| SnocTup $$(liftT tup) $$(liftE e) ||]-  in-  case pexp of-    Let bnd body              -> [|| Let $$(liftPreOpenExp liftA bnd) $$(liftPreOpenExp liftA body) ||]-    Var ix                    -> [|| Var $$(liftIdx ix) ||]-    Foreign asm f x           -> [|| Foreign $$(liftForeign asm) $$(liftPreOpenFun liftA f) $$(liftE x) ||]-    Const c                   -> [|| Const $$(liftConst (eltType (undefined::t)) c) ||]-    Tuple tup                 -> [|| Tuple $$(liftT tup) ||]-    Prj tix e                 -> [|| Prj $$(liftTupleIdx tix) $$(liftE e) ||]-    IndexNil                  -> [|| IndexNil ||]-    IndexCons sh sz           -> [|| IndexCons $$(liftE sh) $$(liftE sz) ||]-    IndexHead sh              -> [|| IndexHead $$(liftE sh) ||]-    IndexTail sh              -> [|| IndexTail $$(liftE sh) ||]-    IndexAny                  -> [|| IndexAny ||]-    IndexSlice slice slix sh  -> [|| IndexSlice $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sh) ||]-    IndexFull slice slix sl   -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||]-    ToIndex sh ix             -> [|| ToIndex $$(liftE sh) $$(liftE ix) ||]-    FromIndex sh ix           -> [|| FromIndex $$(liftE sh) $$(liftE ix) ||]-    Cond p t e                -> [|| Cond $$(liftE p) $$(liftE t) $$(liftE e) ||]-    While p f x               -> [|| While $$(liftF p) $$(liftF f) $$(liftE x) ||]-    PrimConst t               -> [|| PrimConst $$(liftPrimConst t) ||]-    PrimApp f x               -> [|| PrimApp $$(liftPrimFun f) $$(liftE x) ||]-    Index a ix                -> [|| Index $$(liftA a) $$(liftE ix) ||]-    LinearIndex a ix          -> [|| LinearIndex $$(liftA a) $$(liftE ix) ||]-    Shape a                   -> [|| Shape $$(liftA a) ||]-    ShapeSize ix              -> [|| ShapeSize $$(liftE ix) ||]-    Intersect sh1 sh2         -> [|| Intersect $$(liftE sh1) $$(liftE sh2) ||]-    Union sh1 sh2             -> [|| Union $$(liftE sh1) $$(liftE sh2) ||]---liftArrays :: ArraysR arr -> arr -> Q (TExp arr)-liftArrays ArraysRunit ()              = [|| () ||]-liftArrays ArraysRarray arr            = [|| $$(liftArray arr) ||]-liftArrays (ArraysRpair r1 r2) (a1,a2) = [|| ($$(liftArrays r1 a1), $$(liftArrays r2 a2)) ||]--liftArray :: forall sh e. Array sh e -> Q (TExp (Array sh e))-liftArray (Array sh adata) =-  [|| Array $$(liftConst (eltType (undefined::sh)) sh) $$(go arrayElt adata) ||] `sigE` typeRepToType (typeOf (undefined::Array sh e))-  where-    sz :: Int-    sz = size sh--    sigE :: Q (TExp t) -> Q TH.Type -> Q (TExp t)-    sigE e t = TH.unsafeTExpCoerce $ TH.sigE (TH.unTypeQ e) t--    typeRepToType :: TypeRep -> Q TH.Type-    typeRepToType trep = do-      let (con, args)     = splitTyConApp trep-          name            = TH.Name (TH.OccName (tyConName con)) (TH.NameG TH.TcClsName (TH.PkgName (tyConPackage con)) (TH.ModName (tyConModule con)))-          ---          appsT x []      = x-          appsT x (y:xs)  = appsT (TH.AppT x y) xs-          ---      resultArgs <- mapM typeRepToType args-      return (appsT (TH.ConT name) resultArgs)--    -- TODO: make sure that the resulting array is 16-byte aligned...-    arr :: forall a. (ArrayElt a, Storable a) => UniqueArray a -> Q (TExp (UniqueArray a))-    arr ua = do-      bytes <- TH.runIO $ peekArray (sizeOf (undefined::a) * sz) (castPtr (unsafeUniqueArrayPtr ua) :: Ptr Word8)-      [|| unsafePerformIO $ do-           fp  <- newForeignPtr_ $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |] )-           ua' <- newUniqueArray (castForeignPtr fp)-           return ua'-       ||]--    go :: ArrayEltR e' -> ArrayData e' -> Q (TExp (ArrayData e'))-    go ArrayEltRunit         AD_Unit         = [|| AD_Unit ||]-    go ArrayEltRint          (AD_Int ua)     = [|| AD_Int $$(arr ua) ||]-    go ArrayEltRint8         (AD_Int8 ua)    = [|| AD_Int8 $$(arr ua) ||]-    go ArrayEltRint16        (AD_Int16 ua)   = [|| AD_Int16 $$(arr ua) ||]-    go ArrayEltRint32        (AD_Int32 ua)   = [|| AD_Int32 $$(arr ua) ||]-    go ArrayEltRint64        (AD_Int64 ua)   = [|| AD_Int64 $$(arr ua) ||]-    go ArrayEltRword         (AD_Word ua)    = [|| AD_Word $$(arr ua) ||]-    go ArrayEltRword8        (AD_Word8 ua)   = [|| AD_Word8 $$(arr ua) ||]-    go ArrayEltRword16       (AD_Word16 ua)  = [|| AD_Word16 $$(arr ua) ||]-    go ArrayEltRword32       (AD_Word32 ua)  = [|| AD_Word32 $$(arr ua) ||]-    go ArrayEltRword64       (AD_Word64 ua)  = [|| AD_Word64 $$(arr ua) ||]-    go ArrayEltRcshort       (AD_CShort ua)  = [|| AD_CShort $$(arr ua) ||]-    go ArrayEltRcushort      (AD_CUShort ua) = [|| AD_CUShort $$(arr ua) ||]-    go ArrayEltRcint         (AD_CInt ua)    = [|| AD_CInt $$(arr ua) ||]-    go ArrayEltRcuint        (AD_CUInt ua)   = [|| AD_CUInt $$(arr ua) ||]-    go ArrayEltRclong        (AD_CLong ua)   = [|| AD_CLong $$(arr ua) ||]-    go ArrayEltRculong       (AD_CULong ua)  = [|| AD_CULong $$(arr ua) ||]-    go ArrayEltRcllong       (AD_CLLong ua)  = [|| AD_CLLong $$(arr ua) ||]-    go ArrayEltRcullong      (AD_CULLong ua) = [|| AD_CULLong $$(arr ua) ||]-    go ArrayEltRfloat        (AD_Float ua)   = [|| AD_Float $$(arr ua) ||]-    go ArrayEltRdouble       (AD_Double ua)  = [|| AD_Double $$(arr ua) ||]-    go ArrayEltRcfloat       (AD_CFloat ua)  = [|| AD_CFloat $$(arr ua) ||]-    go ArrayEltRcdouble      (AD_CDouble ua) = [|| AD_CDouble $$(arr ua) ||]-    go ArrayEltRbool         (AD_Bool ua)    = [|| AD_Bool $$(arr ua) ||]-    go ArrayEltRchar         (AD_Char ua)    = [|| AD_Char $$(arr ua) ||]-    go ArrayEltRcchar        (AD_CChar ua)   = [|| AD_CChar $$(arr ua) ||]-    go ArrayEltRcschar       (AD_CSChar ua)  = [|| AD_CSChar $$(arr ua) ||]-    go ArrayEltRcuchar       (AD_CUChar ua)  = [|| AD_CUChar $$(arr ua) ||]-    go (ArrayEltRpair r1 r2) (AD_Pair a1 a2) = [|| AD_Pair $$(go r1 a1) $$(go r2 a2) ||]---liftBoundary-    :: forall acc aenv sh e.-       LiftAcc acc-    -> PreBoundary acc aenv (Array sh e)-    -> Q (TExp (PreBoundary acc aenv (Array sh e)))-liftBoundary _     Clamp        = [|| Clamp ||]-liftBoundary _     Mirror       = [|| Mirror ||]-liftBoundary _     Wrap         = [|| Wrap ||]-liftBoundary _     (Constant v) = [|| Constant $$(liftConst (eltType (undefined::e)) v) ||]-liftBoundary liftA (Function f) = [|| Function $$(liftPreOpenFun liftA f) ||]--liftSliceIndex :: SliceIndex ix slice coSlice sliceDim -> Q (TExp (SliceIndex ix slice coSlice sliceDim))-liftSliceIndex SliceNil          = [|| SliceNil ||]-liftSliceIndex (SliceAll rest)   = [|| SliceAll $$(liftSliceIndex rest) ||]-liftSliceIndex (SliceFixed rest) = [|| SliceFixed $$(liftSliceIndex rest) ||]--liftPrimConst :: PrimConst c -> Q (TExp (PrimConst c))-liftPrimConst (PrimMinBound t) = [|| PrimMinBound $$(liftBoundedType t) ||]-liftPrimConst (PrimMaxBound t) = [|| PrimMaxBound $$(liftBoundedType t) ||]-liftPrimConst (PrimPi t)       = [|| PrimPi $$(liftFloatingType t) ||]--liftPrimFun :: PrimFun f -> Q (TExp (PrimFun f))-liftPrimFun (PrimAdd t)                = [|| PrimAdd $$(liftNumType t) ||]-liftPrimFun (PrimSub t)                = [|| PrimSub $$(liftNumType t) ||]-liftPrimFun (PrimMul t)                = [|| PrimMul $$(liftNumType t) ||]-liftPrimFun (PrimNeg t)                = [|| PrimNeg $$(liftNumType t) ||]-liftPrimFun (PrimAbs t)                = [|| PrimAbs $$(liftNumType t) ||]-liftPrimFun (PrimSig t)                = [|| PrimSig $$(liftNumType t) ||]-liftPrimFun (PrimQuot t)               = [|| PrimQuot $$(liftIntegralType t) ||]-liftPrimFun (PrimRem t)                = [|| PrimRem $$(liftIntegralType t) ||]-liftPrimFun (PrimQuotRem t)            = [|| PrimQuotRem $$(liftIntegralType t) ||]-liftPrimFun (PrimIDiv t)               = [|| PrimIDiv $$(liftIntegralType t) ||]-liftPrimFun (PrimMod t)                = [|| PrimMod $$(liftIntegralType t) ||]-liftPrimFun (PrimDivMod t)             = [|| PrimDivMod $$(liftIntegralType t) ||]-liftPrimFun (PrimBAnd t)               = [|| PrimBAnd $$(liftIntegralType t) ||]-liftPrimFun (PrimBOr t)                = [|| PrimBOr $$(liftIntegralType t) ||]-liftPrimFun (PrimBXor t)               = [|| PrimBXor $$(liftIntegralType t) ||]-liftPrimFun (PrimBNot t)               = [|| PrimBNot $$(liftIntegralType t) ||]-liftPrimFun (PrimBShiftL t)            = [|| PrimBShiftL $$(liftIntegralType t) ||]-liftPrimFun (PrimBShiftR t)            = [|| PrimBShiftR $$(liftIntegralType t) ||]-liftPrimFun (PrimBRotateL t)           = [|| PrimBRotateL $$(liftIntegralType t) ||]-liftPrimFun (PrimBRotateR t)           = [|| PrimBRotateR $$(liftIntegralType t) ||]-liftPrimFun (PrimPopCount t)           = [|| PrimPopCount $$(liftIntegralType t) ||]-liftPrimFun (PrimCountLeadingZeros t)  = [|| PrimCountLeadingZeros $$(liftIntegralType t) ||]-liftPrimFun (PrimCountTrailingZeros t) = [|| PrimCountTrailingZeros $$(liftIntegralType t) ||]-liftPrimFun (PrimFDiv t)               = [|| PrimFDiv $$(liftFloatingType t) ||]-liftPrimFun (PrimRecip t)              = [|| PrimRecip $$(liftFloatingType t) ||]-liftPrimFun (PrimSin t)                = [|| PrimSin $$(liftFloatingType t) ||]-liftPrimFun (PrimCos t)                = [|| PrimCos $$(liftFloatingType t) ||]-liftPrimFun (PrimTan t)                = [|| PrimTan $$(liftFloatingType t) ||]-liftPrimFun (PrimAsin t)               = [|| PrimAsin $$(liftFloatingType t) ||]-liftPrimFun (PrimAcos t)               = [|| PrimAcos $$(liftFloatingType t) ||]-liftPrimFun (PrimAtan t)               = [|| PrimAtan $$(liftFloatingType t) ||]-liftPrimFun (PrimSinh t)               = [|| PrimSinh $$(liftFloatingType t) ||]-liftPrimFun (PrimCosh t)               = [|| PrimCosh $$(liftFloatingType t) ||]-liftPrimFun (PrimTanh t)               = [|| PrimTanh $$(liftFloatingType t) ||]-liftPrimFun (PrimAsinh t)              = [|| PrimAsinh $$(liftFloatingType t) ||]-liftPrimFun (PrimAcosh t)              = [|| PrimAcosh $$(liftFloatingType t) ||]-liftPrimFun (PrimAtanh t)              = [|| PrimAtanh $$(liftFloatingType t) ||]-liftPrimFun (PrimExpFloating t)        = [|| PrimExpFloating $$(liftFloatingType t) ||]-liftPrimFun (PrimSqrt t)               = [|| PrimSqrt $$(liftFloatingType t) ||]-liftPrimFun (PrimLog t)                = [|| PrimLog $$(liftFloatingType t) ||]-liftPrimFun (PrimFPow t)               = [|| PrimFPow $$(liftFloatingType t) ||]-liftPrimFun (PrimLogBase t)            = [|| PrimLogBase $$(liftFloatingType t) ||]-liftPrimFun (PrimTruncate ta tb)       = [|| PrimTruncate $$(liftFloatingType ta) $$(liftIntegralType tb) ||]-liftPrimFun (PrimRound ta tb)          = [|| PrimRound $$(liftFloatingType ta) $$(liftIntegralType tb) ||]-liftPrimFun (PrimFloor ta tb)          = [|| PrimFloor $$(liftFloatingType ta) $$(liftIntegralType tb) ||]-liftPrimFun (PrimCeiling ta tb)        = [|| PrimCeiling $$(liftFloatingType ta) $$(liftIntegralType tb) ||]-liftPrimFun (PrimIsNaN t)              = [|| PrimIsNaN $$(liftFloatingType t) ||]-liftPrimFun (PrimIsInfinite t)         = [|| PrimIsInfinite $$(liftFloatingType t) ||]-liftPrimFun (PrimAtan2 t)              = [|| PrimAtan2 $$(liftFloatingType t) ||]-liftPrimFun (PrimLt t)                 = [|| PrimLt $$(liftScalarType t) ||]-liftPrimFun (PrimGt t)                 = [|| PrimGt $$(liftScalarType t) ||]-liftPrimFun (PrimLtEq t)               = [|| PrimLtEq $$(liftScalarType t) ||]-liftPrimFun (PrimGtEq t)               = [|| PrimGtEq $$(liftScalarType t) ||]-liftPrimFun (PrimEq t)                 = [|| PrimEq $$(liftScalarType t) ||]-liftPrimFun (PrimNEq t)                = [|| PrimNEq $$(liftScalarType t) ||]-liftPrimFun (PrimMax t)                = [|| PrimMax $$(liftScalarType t) ||]-liftPrimFun (PrimMin t)                = [|| PrimMin $$(liftScalarType t) ||]-liftPrimFun PrimLAnd                   = [|| PrimLAnd ||]-liftPrimFun PrimLOr                    = [|| PrimLOr ||]-liftPrimFun PrimLNot                   = [|| PrimLNot ||]-liftPrimFun PrimOrd                    = [|| PrimOrd ||]-liftPrimFun PrimChr                    = [|| PrimChr ||]-liftPrimFun PrimBoolToInt              = [|| PrimBoolToInt ||]-liftPrimFun (PrimFromIntegral ta tb)   = [|| PrimFromIntegral $$(liftIntegralType ta) $$(liftNumType tb) ||]-liftPrimFun (PrimToFloating ta tb)     = [|| PrimToFloating $$(liftNumType ta) $$(liftFloatingType tb) ||]-liftPrimFun (PrimCoerce ta tb)         = [|| PrimCoerce $$(liftScalarType ta) $$(liftScalarType tb) ||]---liftConst :: TupleType t -> t -> Q (TExp t)-liftConst UnitTuple         ()    = [|| () ||]-liftConst (SingleTuple t)   x     = [|| $$(liftScalar t x) ||]-liftConst (PairTuple ta tb) (a,b) = [|| ($$(liftConst ta a), $$(liftConst tb b)) ||]--liftScalar :: ScalarType t -> t -> Q (TExp t)-liftScalar (NumScalarType t)    x = liftNum t x-liftScalar (NonNumScalarType t) x = liftNonNum t x--liftNum :: NumType t -> t -> Q (TExp t)-liftNum (IntegralNumType t) x = liftIntegral t x-liftNum (FloatingNumType t) x = liftFloating t x--liftNonNum :: NonNumType t -> t -> Q (TExp t)-liftNonNum TypeBool{}   x = [|| x ||]-liftNonNum TypeChar{}   x = [|| x ||]-liftNonNum TypeCChar{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftNonNum TypeCSChar{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftNonNum TypeCUChar{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))--liftIntegral :: IntegralType t -> t -> Q (TExp t)-liftIntegral TypeInt{}     x = [|| x ||]-liftIntegral TypeInt8{}    x = [|| x ||]-liftIntegral TypeInt16{}   x = [|| x ||]-liftIntegral TypeInt32{}   x = [|| x ||]-liftIntegral TypeInt64{}   x = [|| x ||]-#if __GLASGOW_HASKELL__ >= 710-liftIntegral TypeWord{}    x = [|| x ||]-#else-liftIntegral TypeWord{}    x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-#endif-liftIntegral TypeWord8{}   x = [|| x ||]-liftIntegral TypeWord16{}  x = [|| x ||]-liftIntegral TypeWord32{}  x = [|| x ||]-liftIntegral TypeWord64{}  x = [|| x ||]-liftIntegral TypeCShort{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCUShort{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCInt{}    x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCUInt{}   x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCLong{}   x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCULong{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCLLong{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))-liftIntegral TypeCULLong{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))--liftFloating :: FloatingType t -> t -> Q (TExp t)-liftFloating TypeFloat{}   x = [|| x ||]-liftFloating TypeDouble{}  x = [|| x ||]-liftFloating TypeCFloat{}  x = return (TH.TExp (TH.LitE (TH.RationalL (toRational x))))-liftFloating TypeCDouble{} x = return (TH.TExp (TH.LitE (TH.RationalL (toRational x))))---liftIntegralType :: IntegralType t -> Q (TExp (IntegralType t))-liftIntegralType TypeInt{}     = [|| TypeInt IntegralDict ||]-liftIntegralType TypeInt8{}    = [|| TypeInt8 IntegralDict ||]-liftIntegralType TypeInt16{}   = [|| TypeInt16 IntegralDict ||]-liftIntegralType TypeInt32{}   = [|| TypeInt32 IntegralDict ||]-liftIntegralType TypeInt64{}   = [|| TypeInt64 IntegralDict ||]-liftIntegralType TypeWord{}    = [|| TypeWord IntegralDict ||]-liftIntegralType TypeWord8{}   = [|| TypeWord8 IntegralDict ||]-liftIntegralType TypeWord16{}  = [|| TypeWord16 IntegralDict ||]-liftIntegralType TypeWord32{}  = [|| TypeWord32 IntegralDict ||]-liftIntegralType TypeWord64{}  = [|| TypeWord64 IntegralDict ||]-liftIntegralType TypeCShort{}  = [|| TypeCShort IntegralDict ||]-liftIntegralType TypeCUShort{} = [|| TypeCUShort IntegralDict ||]-liftIntegralType TypeCInt{}    = [|| TypeCInt IntegralDict ||]-liftIntegralType TypeCUInt{}   = [|| TypeCUInt IntegralDict ||]-liftIntegralType TypeCLong{}   = [|| TypeCLong IntegralDict ||]-liftIntegralType TypeCULong{}  = [|| TypeCULong IntegralDict ||]-liftIntegralType TypeCLLong{}  = [|| TypeCLLong IntegralDict ||]-liftIntegralType TypeCULLong{} = [|| TypeCULLong IntegralDict ||]--liftFloatingType :: FloatingType t -> Q (TExp (FloatingType t))-liftFloatingType TypeFloat{}   = [|| TypeFloat FloatingDict ||]-liftFloatingType TypeDouble{}  = [|| TypeDouble FloatingDict ||]-liftFloatingType TypeCFloat{}  = [|| TypeCFloat FloatingDict ||]-liftFloatingType TypeCDouble{} = [|| TypeCDouble FloatingDict ||]--liftNonNumType :: NonNumType t -> Q (TExp (NonNumType t))-liftNonNumType TypeBool{}   = [|| TypeBool NonNumDict ||]-liftNonNumType TypeChar{}   = [|| TypeChar NonNumDict ||]-liftNonNumType TypeCChar{}  = [|| TypeCChar NonNumDict ||]-liftNonNumType TypeCSChar{} = [|| TypeCSChar NonNumDict ||]-liftNonNumType TypeCUChar{} = [|| TypeCUChar NonNumDict ||]--liftNumType :: NumType t -> Q (TExp (NumType t))-liftNumType (IntegralNumType t) = [|| IntegralNumType $$(liftIntegralType t) ||]-liftNumType (FloatingNumType t) = [|| FloatingNumType $$(liftFloatingType t) ||]--liftBoundedType :: BoundedType t -> Q (TExp (BoundedType t))-liftBoundedType (IntegralBoundedType t) = [|| IntegralBoundedType $$(liftIntegralType t) ||]-liftBoundedType (NonNumBoundedType t)   = [|| NonNumBoundedType $$(liftNonNumType t) ||]--liftScalarType :: ScalarType t -> Q (TExp (ScalarType t))-liftScalarType (NumScalarType t)    = [|| NumScalarType $$(liftNumType t) ||]-liftScalarType (NonNumScalarType t) = [|| NonNumScalarType $$(liftNonNumType t) ||]----- Debugging--- =========--showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String-showPreAccOp Alet{}             = "Alet"-showPreAccOp (Avar ix)          = "Avar a" ++ show (idxToInt ix)-showPreAccOp (Use a)            = "Use "  ++ showArrays (toArr a :: arrs)-showPreAccOp Apply{}            = "Apply"-showPreAccOp Aforeign{}         = "Aforeign"-showPreAccOp Acond{}            = "Acond"-showPreAccOp Awhile{}           = "Awhile"-showPreAccOp Atuple{}           = "Atuple"-showPreAccOp Aprj{}             = "Aprj"-showPreAccOp Unit{}             = "Unit"-showPreAccOp Generate{}         = "Generate"-showPreAccOp Transform{}        = "Transform"-showPreAccOp Reshape{}          = "Reshape"-showPreAccOp Replicate{}        = "Replicate"-showPreAccOp Slice{}            = "Slice"-showPreAccOp Map{}              = "Map"-showPreAccOp ZipWith{}          = "ZipWith"-showPreAccOp Fold{}             = "Fold"-showPreAccOp Fold1{}            = "Fold1"-showPreAccOp FoldSeg{}          = "FoldSeg"-showPreAccOp Fold1Seg{}         = "Fold1Seg"-showPreAccOp Scanl{}            = "Scanl"-showPreAccOp Scanl'{}           = "Scanl'"-showPreAccOp Scanl1{}           = "Scanl1"-showPreAccOp Scanr{}            = "Scanr"-showPreAccOp Scanr'{}           = "Scanr'"-showPreAccOp Scanr1{}           = "Scanr1"-showPreAccOp Permute{}          = "Permute"-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-  where-    collect :: ArraysR a -> a -> [String]-    collect ArraysRunit         _        = []-    collect ArraysRarray        arr      = [showShortendArr arr]-    collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2-    ---    display []  = []-    display [x] = x-    display xs  = "(" ++ intercalate ", " xs ++ ")"---showShortendArr :: Elt e => Array sh e -> String-showShortendArr arr-  = show (take cutoff l) ++ if length l > cutoff then ".." else ""-  where-    l      = toList arr-    cutoff = 5---showPreExpOp :: forall acc env aenv t. PreOpenExp acc env aenv t -> String-showPreExpOp Let{}              = "Let"-showPreExpOp (Var ix)           = "Var x" ++ show (idxToInt ix)-showPreExpOp (Const c)          = "Const " ++ show (toElt c :: t)-showPreExpOp Foreign{}          = "Foreign"-showPreExpOp Tuple{}            = "Tuple"-showPreExpOp Prj{}              = "Prj"-showPreExpOp IndexNil           = "IndexNil"-showPreExpOp IndexCons{}        = "IndexCons"-showPreExpOp IndexHead{}        = "IndexHead"-showPreExpOp IndexTail{}        = "IndexTail"-showPreExpOp IndexAny           = "IndexAny"-showPreExpOp IndexSlice{}       = "IndexSlice"-showPreExpOp IndexFull{}        = "IndexFull"-showPreExpOp ToIndex{}          = "ToIndex"-showPreExpOp FromIndex{}        = "FromIndex"-showPreExpOp Cond{}             = "Cond"-showPreExpOp While{}            = "While"-showPreExpOp PrimConst{}        = "PrimConst"-showPreExpOp PrimApp{}          = "PrimApp"-showPreExpOp Index{}            = "Index"-showPreExpOp LinearIndex{}      = "LinearIndex"-showPreExpOp Shape{}            = "Shape"-showPreExpOp ShapeSize{}        = "ShapeSize"-showPreExpOp Intersect{}        = "Intersect"-showPreExpOp Union{}            = "Union"-
− Data/Array/Accelerate/Analysis/Hash.hs 
@@ -1,506 +0,0 @@-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Analysis.Hash--- Copyright   : [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.Hash (--  -- hashing expressions-  HashAcc,-  hashPreOpenAcc, hashOpenAcc,-  hashPreOpenExp, hashOpenExp,-  hashPreOpenFun,--  -- auxiliary-  hashQ,-  commutes,--) where--import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Analysis.Hash.TH-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Array.Representation                   ( SliceIndex(..) )-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Type--import Data.Hashable-import Foreign.C.Types-import Data.Maybe                                                   ( fromMaybe )-import System.Mem.StableName                                        ( hashStableName, makeStableName )-import System.IO.Unsafe                                             ( unsafePerformIO )-import Prelude                                                      hiding ( exp )----- 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 :: forall aenv' a. Arrays a => Int -> acc aenv' a -> Int-    hashA salt-      = hashWithSalt salt-      . hashWithSalt (hashArraysType (arrays (undefined::a)))-      . 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--    hashB :: Int -> PreBoundary acc aenv' (Array sh e) -> Int-    hashB salt = hashWithSalt salt . hashPreBoundary hashAcc--    -- hashS :: Int -> PreOpenSeq acc aenv senv arrs -> Int-    -- hashS salt = hashWithSalt salt . hashPreOpenSeq hashAcc--    nacl :: Arrays arrs => Int-    nacl = hashArraysType (arrays (undefined::arrs))--  in case pacc of-    Alet bnd body               -> $(hashQ "Alet")        `hashA` bnd `hashA` body-    Avar v                      -> $(hashQ "Avar")        `hashWithSalt` nacl `hashWithSalt` hashIdx v-    Atuple t                    -> $(hashQ "Atuple")      `hashWithSalt` nacl `hashWithSalt` hashAtuple hashAcc t-    Aprj ix a                   -> $(hashQ "Aprj")        `hashWithSalt` nacl `hashWithSalt` hashTupleIdx ix    `hashA` a-    Apply f a                   -> $(hashQ "Apply")       `hashWithSalt` nacl `hashWithSalt` hashAfun hashAcc f `hashA` a-    Aforeign _ f a              -> $(hashQ "Aforeign")    `hashWithSalt` nacl `hashWithSalt` hashAfun hashAcc f `hashA` a-    Use a                       -> $(hashQ "Use")         `hashWithSalt` hashArrays (arrays (undefined::arrs)) a-    Awhile p f a                -> $(hashQ "Awhile")      `hashWithSalt` hashAfun hashAcc f `hashWithSalt` hashAfun hashAcc p `hashA` a-    Unit e                      -> $(hashQ "Unit")        `hashE` e-    Generate e f                -> $(hashQ "Generate")    `hashE` e  `hashF` f-    Acond e a1 a2               -> $(hashQ "Acond")       `hashE` e  `hashA` a1 `hashA` a2-    Reshape sh a                -> $(hashQ "Reshape")     `hashE` sh `hashA` a-    Transform sh f1 f2 a        -> $(hashQ "Transform")   `hashE` sh `hashF` f1 `hashF` f2 `hashA` a-    Replicate spec ix a         -> $(hashQ "Replicate")   `hashE` ix `hashA` a  `hashWithSalt` hashSliceIndex spec-    Slice spec a ix             -> $(hashQ "Slice")       `hashE` ix `hashA` a  `hashWithSalt` hashSliceIndex spec-    Map f a                     -> $(hashQ "Map")         `hashF` f  `hashA` a-    ZipWith f a1 a2             -> $(hashQ "ZipWith")     `hashF` f  `hashA` a1 `hashA` a2-    Fold f e a                  -> $(hashQ "Fold")        `hashF` f  `hashE` e  `hashA` a-    Fold1 f a                   -> $(hashQ "Fold1")       `hashF` f  `hashA` a-    FoldSeg f e a s             -> $(hashQ "FoldSeg")     `hashF` f  `hashE` e  `hashA` a  `hashA` s-    Fold1Seg f a s              -> $(hashQ "Fold1Seg")    `hashF` f  `hashA` a  `hashA` s-    Scanl f e a                 -> $(hashQ "Scanl")       `hashF` f  `hashE` e  `hashA` a-    Scanl' f e a                -> $(hashQ "Scanl'")      `hashF` f  `hashE` e  `hashA` a-    Scanl1 f a                  -> $(hashQ "Scanl1")      `hashF` f  `hashA` a-    Scanr f e a                 -> $(hashQ "Scanr")       `hashF` f  `hashE` e  `hashA` a-    Scanr' f e a                -> $(hashQ "Scanr'")      `hashF` f  `hashE` e  `hashA` a-    Scanr1 f a                  -> $(hashQ "Scanr1")      `hashF` f  `hashA` a-    Backpermute sh f a          -> $(hashQ "Backpermute") `hashF` f  `hashE` sh `hashA` a-    Permute f1 a1 f2 a2         -> $(hashQ "Permute")     `hashF` f1 `hashA` a1 `hashF` f2 `hashA` a2-    Stencil f b a               -> $(hashQ "Stencil")     `hashF` f  `hashB` b  `hashA` a-    Stencil2 f b1 a1 b2 a2      -> $(hashQ "Stencil2")    `hashF` f  `hashB` b1 `hashA` a1 `hashB` b2 `hashA` a2--{---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---}---hashIdx :: Idx env t -> Int-hashIdx = hash . idxToInt--hashTupleIdx :: TupleIdx tup e -> Int-hashTupleIdx = hash . tupleIdxToInt---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--hashArraysType :: forall a. ArraysR a -> Int-hashArraysType ArraysRunit         = $(hashQ "ArraysRunit")-hashArraysType (ArraysRpair r1 r2) = $(hashQ "ArraysRpair")  `hashWithSalt` hashArraysType r1 `hashWithSalt` hashArraysType r2-hashArraysType ArraysRarray        = $(hashQ "ArraysRarray") `hashWithSalt` hashArrayType (undefined::a)-  where-    hashArrayType :: forall sh e. (Shape sh, Elt e) => Array sh e -> Int-    hashArrayType _ = hashTupleType (eltType (undefined::sh)) `hashWithSalt` hashTupleType (eltType (undefined::e))--hashAtuple :: HashAcc acc -> Atuple (acc aenv) a -> Int-hashAtuple _ NilAtup            = $(hashQ "NilAtup")-hashAtuple h (SnocAtup t a)     = $(hashQ "SnocAtup") `hashWithSalt` hashAtuple h t `hashWithSalt` h a--hashAfun :: forall acc aenv f. HashAcc acc -> PreOpenAfun acc aenv f -> Int-hashAfun hashAcc afun =-  let-    hashA :: forall aenv' a. Arrays a => Int -> acc aenv' a -> Int-    hashA salt-      = hashWithSalt salt-      . hashWithSalt (hashArraysType (arrays (undefined::a)))-      . hashAcc--    hashL :: forall aenv' a b. Arrays a => Int -> PreOpenAfun acc (aenv',a) b -> Int-    hashL salt-       = hashWithSalt salt-       . hashWithSalt (hashArraysType (arrays (undefined::a)))-       . hashAfun hashAcc--  in case afun of-    Abody b -> $(hashQ "Abody") `hashA` b-    Alam  l -> $(hashQ "Alam")  `hashL` l---hashPreBoundary :: forall acc aenv sh e. HashAcc acc -> PreBoundary acc aenv (Array sh e) -> Int-hashPreBoundary _ Wrap          = $(hashQ "Wrap")-hashPreBoundary _ Clamp         = $(hashQ "Clamp")-hashPreBoundary _ Mirror        = $(hashQ "Mirror")-hashPreBoundary _ (Constant c)  = $(hashQ "Constant") `hashWithSalt` hashConst (eltType (undefined::e)) c-hashPreBoundary h (Function f)  = $(hashQ "Function") `hashWithSalt` hashPreOpenFun h f--hashSliceIndex :: SliceIndex slix sl co sh -> Int-hashSliceIndex SliceNil         = $(hashQ "SliceNil")-hashSliceIndex (SliceAll r)     = $(hashQ "SliceAll")   `hashWithSalt` hashSliceIndex r-hashSliceIndex (SliceFixed r)   = $(hashQ "sliceFixed") `hashWithSalt` hashSliceIndex r----- 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-    hashE :: forall env' aenv' e. Elt e => Int -> PreOpenExp acc env' aenv' e -> Int-    hashE salt-      = hashWithSalt salt-      . hashWithSalt (hashTupleType (eltType (undefined::e)))-      . hashPreOpenExp hashAcc--    hashA :: Int -> acc aenv' a -> Int-    hashA salt = hashWithSalt salt . hashAcc--    hashF :: Int -> PreOpenFun acc env' aenv' f -> Int-    hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc--    nacl :: Elt exp => Int-    nacl = hashTupleType (eltType (undefined::exp))--  in case exp of-    Let bnd body                -> $(hashQ "Let")         `hashE` bnd `hashE` body-    Const c                     -> $(hashQ "Const")       `hashWithSalt` hashConst (eltType (undefined::exp)) c-    Var ix                      -> $(hashQ "Var")         `hashWithSalt` nacl `hashWithSalt` hashIdx ix-    Tuple t                     -> $(hashQ "Tuple")       `hashWithSalt` nacl `hashWithSalt` hashTuple hashAcc t-    Prj i e                     -> $(hashQ "Prj")         `hashWithSalt` nacl `hashWithSalt` hashTupleIdx i `hashE` e-    IndexAny                    -> $(hashQ "IndexAny")    `hashWithSalt` nacl-    IndexNil                    -> $(hashQ "IndexNil")-    IndexCons sl a              -> $(hashQ "IndexCons")   `hashE` sl `hashE` a-    IndexHead sl                -> $(hashQ "IndexHead")   `hashE` sl-    IndexTail sl                -> $(hashQ "IndexTail")   `hashE` sl-    IndexSlice spec ix sh       -> $(hashQ "IndexSlice")  `hashE` ix `hashE` sh `hashWithSalt` hashSliceIndex spec-    IndexFull  spec ix sl       -> $(hashQ "IndexFull")   `hashE` ix `hashE` sl `hashWithSalt` hashSliceIndex spec-    ToIndex sh i                -> $(hashQ "ToIndex")     `hashE` sh `hashE` i-    FromIndex sh i              -> $(hashQ "FromIndex")   `hashE` sh `hashE` i-    Cond c t e                  -> $(hashQ "Cond")        `hashE` c  `hashE` t  `hashE` e-    While p f x                 -> $(hashQ "While")       `hashF` p  `hashF` f  `hashE` x-    PrimApp f x                 -> $(hashQ "PrimApp")     `hashWithSalt` hashPrimFun f `hashE` fromMaybe x (commutes hashAcc f x)-    PrimConst c                 -> $(hashQ "PrimConst")   `hashWithSalt` hashPrimConst c-    Index a ix                  -> $(hashQ "Index")       `hashA` a  `hashE` ix-    LinearIndex a ix            -> $(hashQ "LinearIndex") `hashA` a  `hashE` ix-    Shape a                     -> $(hashQ "Shape")       `hashA` a-    ShapeSize sh                -> $(hashQ "ShapeSize")   `hashE` sh-    Intersect sa sb             -> $(hashQ "Intersect")   `hashE` sa `hashE` sb-    Union sa sb                 -> $(hashQ "Union")       `hashE` sa `hashE` sb-    Foreign _ f e               -> $(hashQ "Foreign")     `hashF` f  `hashE` e---hashPreOpenFun :: forall acc env aenv f. HashAcc acc -> PreOpenFun acc env aenv f -> Int-hashPreOpenFun hashAcc fun =-  let-    hashE :: forall env' aenv' e. Elt e => Int -> PreOpenExp acc env' aenv' e -> Int-    hashE salt-      = hashWithSalt salt-      . hashWithSalt (hashTupleType (eltType (undefined::e)))-      . hashPreOpenExp hashAcc--    hashL :: forall env' aenv' a b. Elt a => Int -> PreOpenFun acc (env',a) aenv' b -> Int-    hashL salt-      = hashWithSalt salt-      . hashWithSalt (hashTupleType (eltType (undefined::a)))-      . hashPreOpenFun hashAcc--  in case fun of-    Body b -> $(hashQ "Body") `hashE` b-    Lam f  -> $(hashQ "Lam")  `hashL` f---hashTuple :: HashAcc acc -> Tuple (PreOpenExp acc env aenv) e -> Int-hashTuple _ NilTup              = $(hashQ "NilTup")-hashTuple h (SnocTup t e)       = $(hashQ "SnocTup") `hashWithSalt` hashTuple h t `hashWithSalt` hashPreOpenExp h e---hashConst :: TupleType t -> t -> Int-hashConst UnitTuple         ()    = hash ()-hashConst (PairTuple ta tb) (a,b) = hash (hashConst ta a, hashConst tb b)-hashConst (SingleTuple t)   c     = hashScalarConst t c--hashScalarConst :: ScalarType t -> t -> Int-hashScalarConst (NumScalarType t)    = hashNumConst t-hashScalarConst (NonNumScalarType t) = hashNonNumConst t--hashNonNumConst :: NonNumType t -> t -> Int-hashNonNumConst TypeBool{}   x          = $(hashQ "Bool")   `hashWithSalt` x-hashNonNumConst TypeChar{}   x          = $(hashQ "Char")   `hashWithSalt` x-hashNonNumConst TypeCChar{}  (CChar  x) = $(hashQ "CChar")  `hashWithSalt` x-hashNonNumConst TypeCSChar{} (CSChar x) = $(hashQ "CSChar") `hashWithSalt` x-hashNonNumConst TypeCUChar{} (CUChar x) = $(hashQ "CUChar") `hashWithSalt` x--hashNumConst :: NumType t -> t -> Int-hashNumConst (IntegralNumType t) = hashIntegralConst t-hashNumConst (FloatingNumType t) = hashFloatingConst t--hashIntegralConst :: IntegralType t -> t -> Int-hashIntegralConst TypeInt{}     x           = $(hashQ "Int")     `hashWithSalt` x-hashIntegralConst TypeInt8{}    x           = $(hashQ "Int8")    `hashWithSalt` x-hashIntegralConst TypeInt16{}   x           = $(hashQ "Int16")   `hashWithSalt` x-hashIntegralConst TypeInt32{}   x           = $(hashQ "Int32")   `hashWithSalt` x-hashIntegralConst TypeInt64{}   x           = $(hashQ "Int64")   `hashWithSalt` x-hashIntegralConst TypeWord{}    x           = $(hashQ "Word")    `hashWithSalt` x-hashIntegralConst TypeWord8{}   x           = $(hashQ "Word8")   `hashWithSalt` x-hashIntegralConst TypeWord16{}  x           = $(hashQ "Word16")  `hashWithSalt` x-hashIntegralConst TypeWord32{}  x           = $(hashQ "Word32")  `hashWithSalt` x-hashIntegralConst TypeWord64{}  x           = $(hashQ "Word64")  `hashWithSalt` x-hashIntegralConst TypeCShort{}  (CShort x)  = $(hashQ "CShort")  `hashWithSalt` x-hashIntegralConst TypeCUShort{} (CUShort x) = $(hashQ "CUShort") `hashWithSalt` x-hashIntegralConst TypeCInt{}    (CInt x)    = $(hashQ "CInt")    `hashWithSalt` x-hashIntegralConst TypeCUInt{}   (CUInt x)   = $(hashQ "CUInt")   `hashWithSalt` x-hashIntegralConst TypeCLong{}   (CLong x)   = $(hashQ "CLong")   `hashWithSalt` x-hashIntegralConst TypeCULong{}  (CULong x)  = $(hashQ "CULong")  `hashWithSalt` x-hashIntegralConst TypeCLLong{}  (CLLong x)  = $(hashQ "CLLong")  `hashWithSalt` x-hashIntegralConst TypeCULLong{} (CULLong x) = $(hashQ "CULLong") `hashWithSalt` x--hashFloatingConst :: FloatingType t -> t -> Int-hashFloatingConst TypeFloat{}   x           = $(hashQ "Float")   `hashWithSalt` x-hashFloatingConst TypeDouble{}  x           = $(hashQ "Double")  `hashWithSalt` x-hashFloatingConst TypeCFloat{}  (CFloat x)  = $(hashQ "CFloat")  `hashWithSalt` x-hashFloatingConst TypeCDouble{} (CDouble x) = $(hashQ "CDouble") `hashWithSalt` x--hashPrimConst :: PrimConst c -> Int-hashPrimConst (PrimMinBound t)  = $(hashQ "PrimMinBound") `hashWithSalt` hashBoundedType t-hashPrimConst (PrimMaxBound t)  = $(hashQ "PrimMaxBound") `hashWithSalt` hashBoundedType t-hashPrimConst (PrimPi t)        = $(hashQ "PrimPi")       `hashWithSalt` hashFloatingType t---hashPrimFun :: PrimFun f -> Int-hashPrimFun (PrimAdd a)                = $(hashQ "PrimAdd")                `hashWithSalt` hashNumType a-hashPrimFun (PrimSub a)                = $(hashQ "PrimSub")                `hashWithSalt` hashNumType a-hashPrimFun (PrimMul a)                = $(hashQ "PrimMul")                `hashWithSalt` hashNumType a-hashPrimFun (PrimNeg a)                = $(hashQ "PrimNeg")                `hashWithSalt` hashNumType a-hashPrimFun (PrimAbs a)                = $(hashQ "PrimAbs")                `hashWithSalt` hashNumType a-hashPrimFun (PrimSig a)                = $(hashQ "PrimSig")                `hashWithSalt` hashNumType a-hashPrimFun (PrimQuot a)               = $(hashQ "PrimQuot")               `hashWithSalt` hashIntegralType a-hashPrimFun (PrimRem a)                = $(hashQ "PrimRem")                `hashWithSalt` hashIntegralType a-hashPrimFun (PrimQuotRem a)            = $(hashQ "PrimQuotRem")            `hashWithSalt` hashIntegralType a-hashPrimFun (PrimIDiv a)               = $(hashQ "PrimIDiv")               `hashWithSalt` hashIntegralType a-hashPrimFun (PrimMod a)                = $(hashQ "PrimMod")                `hashWithSalt` hashIntegralType a-hashPrimFun (PrimDivMod a)             = $(hashQ "PrimDivMod")             `hashWithSalt` hashIntegralType a-hashPrimFun (PrimBAnd a)               = $(hashQ "PrimBAnd")               `hashWithSalt` hashIntegralType a-hashPrimFun (PrimBOr a)                = $(hashQ "PrimBOr")                `hashWithSalt` hashIntegralType a-hashPrimFun (PrimBXor a)               = $(hashQ "PrimBXor")               `hashWithSalt` hashIntegralType a-hashPrimFun (PrimBNot a)               = $(hashQ "PrimBNot")               `hashWithSalt` hashIntegralType a-hashPrimFun (PrimBShiftL a)            = $(hashQ "PrimBShiftL")            `hashWithSalt` hashIntegralType a-hashPrimFun (PrimBShiftR a)            = $(hashQ "PrimBShiftR")            `hashWithSalt` hashIntegralType a-hashPrimFun (PrimBRotateL a)           = $(hashQ "PrimBRotateL")           `hashWithSalt` hashIntegralType a-hashPrimFun (PrimBRotateR a)           = $(hashQ "PrimBRotateR")           `hashWithSalt` hashIntegralType a-hashPrimFun (PrimPopCount a)           = $(hashQ "PrimPopCount")           `hashWithSalt` hashIntegralType a-hashPrimFun (PrimCountLeadingZeros a)  = $(hashQ "PrimCountLeadingZeros")  `hashWithSalt` hashIntegralType a-hashPrimFun (PrimCountTrailingZeros a) = $(hashQ "PrimCountTrailingZeros") `hashWithSalt` hashIntegralType a-hashPrimFun (PrimFDiv a)               = $(hashQ "PrimFDiv")               `hashWithSalt` hashFloatingType a-hashPrimFun (PrimRecip a)              = $(hashQ "PrimRecip")              `hashWithSalt` hashFloatingType a-hashPrimFun (PrimSin a)                = $(hashQ "PrimSin")                `hashWithSalt` hashFloatingType a-hashPrimFun (PrimCos a)                = $(hashQ "PrimCos")                `hashWithSalt` hashFloatingType a-hashPrimFun (PrimTan a)                = $(hashQ "PrimTan")                `hashWithSalt` hashFloatingType a-hashPrimFun (PrimAsin a)               = $(hashQ "PrimAsin")               `hashWithSalt` hashFloatingType a-hashPrimFun (PrimAcos a)               = $(hashQ "PrimAcos")               `hashWithSalt` hashFloatingType a-hashPrimFun (PrimAtan a)               = $(hashQ "PrimAtan")               `hashWithSalt` hashFloatingType a-hashPrimFun (PrimSinh a)               = $(hashQ "PrimSinh")               `hashWithSalt` hashFloatingType a-hashPrimFun (PrimCosh a)               = $(hashQ "PrimCosh")               `hashWithSalt` hashFloatingType a-hashPrimFun (PrimTanh a)               = $(hashQ "PrimTanh")               `hashWithSalt` hashFloatingType a-hashPrimFun (PrimAsinh a)              = $(hashQ "PrimAsinh")              `hashWithSalt` hashFloatingType a-hashPrimFun (PrimAcosh a)              = $(hashQ "PrimAcosh")              `hashWithSalt` hashFloatingType a-hashPrimFun (PrimAtanh a)              = $(hashQ "PrimAtanh")              `hashWithSalt` hashFloatingType a-hashPrimFun (PrimExpFloating a)        = $(hashQ "PrimExpFloating")        `hashWithSalt` hashFloatingType a-hashPrimFun (PrimSqrt a)               = $(hashQ "PrimSqrt")               `hashWithSalt` hashFloatingType a-hashPrimFun (PrimLog a)                = $(hashQ "PrimLog")                `hashWithSalt` hashFloatingType a-hashPrimFun (PrimFPow a)               = $(hashQ "PrimFPow")               `hashWithSalt` hashFloatingType a-hashPrimFun (PrimLogBase a)            = $(hashQ "PrimLogBase")            `hashWithSalt` hashFloatingType a-hashPrimFun (PrimAtan2 a)              = $(hashQ "PrimAtan2")              `hashWithSalt` hashFloatingType a-hashPrimFun (PrimTruncate a b)         = $(hashQ "PrimTruncate")           `hashWithSalt` hashFloatingType a `hashWithSalt` hashIntegralType b-hashPrimFun (PrimRound a b)            = $(hashQ "PrimRound")              `hashWithSalt` hashFloatingType a `hashWithSalt` hashIntegralType b-hashPrimFun (PrimFloor a b)            = $(hashQ "PrimFloor")              `hashWithSalt` hashFloatingType a `hashWithSalt` hashIntegralType b-hashPrimFun (PrimCeiling a b)          = $(hashQ "PrimCeiling")            `hashWithSalt` hashFloatingType a `hashWithSalt` hashIntegralType b-hashPrimFun (PrimIsNaN a)              = $(hashQ "PrimIsNaN")              `hashWithSalt` hashFloatingType a-hashPrimFun (PrimIsInfinite a)         = $(hashQ "PrimIsInfinite")         `hashWithSalt` hashFloatingType a-hashPrimFun (PrimLt a)                 = $(hashQ "PrimLt")                 `hashWithSalt` hashScalarType a-hashPrimFun (PrimGt a)                 = $(hashQ "PrimGt")                 `hashWithSalt` hashScalarType a-hashPrimFun (PrimLtEq a)               = $(hashQ "PrimLtEq")               `hashWithSalt` hashScalarType a-hashPrimFun (PrimGtEq a)               = $(hashQ "PrimGtEq")               `hashWithSalt` hashScalarType a-hashPrimFun (PrimEq a)                 = $(hashQ "PrimEq")                 `hashWithSalt` hashScalarType a-hashPrimFun (PrimNEq a)                = $(hashQ "PrimNEq")                `hashWithSalt` hashScalarType a-hashPrimFun (PrimMax a)                = $(hashQ "PrimMax")                `hashWithSalt` hashScalarType a-hashPrimFun (PrimMin a)                = $(hashQ "PrimMin")                `hashWithSalt` hashScalarType a-hashPrimFun (PrimFromIntegral a b)     = $(hashQ "PrimFromIntegral")       `hashWithSalt` hashIntegralType a `hashWithSalt` hashNumType b-hashPrimFun (PrimToFloating a b)       = $(hashQ "PrimToFloating")         `hashWithSalt` hashNumType a      `hashWithSalt` hashFloatingType b-hashPrimFun (PrimCoerce a b)           = $(hashQ "PrimCoerce")             `hashWithSalt` hashScalarType a   `hashWithSalt` hashScalarType b-hashPrimFun PrimLAnd                   = $(hashQ "PrimLAnd")-hashPrimFun PrimLOr                    = $(hashQ "PrimLOr")-hashPrimFun PrimLNot                   = $(hashQ "PrimLNot")-hashPrimFun PrimOrd                    = $(hashQ "PrimOrd")-hashPrimFun PrimChr                    = $(hashQ "PrimChr")-hashPrimFun PrimBoolToInt              = $(hashQ "PrimBoolToInt")----- TLM: We need to include the depth of the branches in the pair case, otherwise---      we are getting a collision at @hash t == hash (t,(t,t))@.----hashTupleType :: TupleType t -> Int-hashTupleType UnitTuple       = $(hashQ "UnitTuple")-hashTupleType (SingleTuple t) = $(hashQ "SingleTuple") `hashWithSalt` hashScalarType t-hashTupleType (PairTuple a b) = $(hashQ "PairTuple")   `hashWithSalt` hashTupleType a `hashWithSalt` depthTupleType a-                                                       `hashWithSalt` hashTupleType b `hashWithSalt` depthTupleType b--depthTupleType :: TupleType t -> Int-depthTupleType UnitTuple       = 0-depthTupleType SingleTuple{}   = 1-depthTupleType (PairTuple a b) = depthTupleType a + depthTupleType b--hashScalarType :: ScalarType t -> Int-hashScalarType (NumScalarType t)    = $(hashQ "NumScalarType")    `hashWithSalt` hashNumType t-hashScalarType (NonNumScalarType t) = $(hashQ "NonNumScalarType") `hashWithSalt` hashNonNumType t--hashBoundedType :: BoundedType t -> Int-hashBoundedType (IntegralBoundedType t) = $(hashQ "IntegralBoundedType") `hashWithSalt` hashIntegralType t-hashBoundedType (NonNumBoundedType t)   = $(hashQ "NonNumBoundedType")   `hashWithSalt` hashNonNumType t--hashNonNumType :: NonNumType t -> Int-hashNonNumType TypeBool{}   = $(hashQ "Bool")-hashNonNumType TypeChar{}   = $(hashQ "Char")-hashNonNumType TypeCChar{}  = $(hashQ "CChar")-hashNonNumType TypeCSChar{} = $(hashQ "CSChar")-hashNonNumType TypeCUChar{} = $(hashQ "CUChar")--hashNumType :: NumType t -> Int-hashNumType (IntegralNumType t) = $(hashQ "IntegralNumType") `hashWithSalt` hashIntegralType t-hashNumType (FloatingNumType t) = $(hashQ "FloatingNumType") `hashWithSalt` hashFloatingType t--hashIntegralType :: IntegralType t -> Int-hashIntegralType TypeInt{}     = $(hashQ "Int")-hashIntegralType TypeInt8{}    = $(hashQ "Int8")-hashIntegralType TypeInt16{}   = $(hashQ "Int16")-hashIntegralType TypeInt32{}   = $(hashQ "Int32")-hashIntegralType TypeInt64{}   = $(hashQ "Int64")-hashIntegralType TypeWord{}    = $(hashQ "Word")-hashIntegralType TypeWord8{}   = $(hashQ "Word8")-hashIntegralType TypeWord16{}  = $(hashQ "Word16")-hashIntegralType TypeWord32{}  = $(hashQ "Word32")-hashIntegralType TypeWord64{}  = $(hashQ "Word64")-hashIntegralType TypeCShort{}  = $(hashQ "CShort")-hashIntegralType TypeCUShort{} = $(hashQ "CUShort")-hashIntegralType TypeCInt{}    = $(hashQ "CInt")-hashIntegralType TypeCUInt{}   = $(hashQ "CUInt")-hashIntegralType TypeCLong{}   = $(hashQ "CLong")-hashIntegralType TypeCULong{}  = $(hashQ "CULong")-hashIntegralType TypeCLLong{}  = $(hashQ "CLLong")-hashIntegralType TypeCULLong{} = $(hashQ "CULLong")--hashFloatingType :: FloatingType t -> Int-hashFloatingType TypeFloat{}   = $(hashQ "Float")-hashFloatingType TypeDouble{}  = $(hashQ "Double")-hashFloatingType TypeCFloat{}  = $(hashQ "CFloat")-hashFloatingType TypeCDouble{} = $(hashQ "CDouble")----- Auxiliary--- ------------- 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-
− Data/Array/Accelerate/Analysis/Hash/TH.hs 
@@ -1,30 +0,0 @@--- |--- Module      : Data.Array.Accelerate.Analysis.Hash.TH--- Copyright   : [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.Hash.TH (--  hashQ,-  hashWithSaltQ,--) where--import Data.Hashable-import Language.Haskell.TH---hashQ :: Hashable a => a -> ExpQ-hashQ = intE . hash--hashWithSaltQ :: Hashable a => Int -> a -> ExpQ-hashWithSaltQ s x = intE (hashWithSalt s x)--intE :: Int -> ExpQ-intE = litE . integerL . fromIntegral-
− Data/Array/Accelerate/Analysis/Match.hs 
@@ -1,934 +0,0 @@-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators       #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Analysis.Match--- 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,--) where---- standard library-import Data.Maybe-import Data.Typeable-import System.IO.Unsafe                                 ( unsafePerformIO )-import System.Mem.StableName-import Prelude                                          hiding ( exp )---- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Analysis.Hash-import Data.Array.Accelerate.Array.Representation       ( SliceIndex(..) )-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Type----- 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) (Stencil f2 b2 a2)-      | Just Refl <- matchFun f1 f2-      , Just Refl <- matchAcc a1 a2-      , matchBoundary matchAcc hashAcc b1 b2-      = Just Refl--    match (Stencil2 f1 b1  a1  b2  a2) (Stencil2 f2 b1' a1' b2' a2')-      | Just Refl <- matchFun f1 f2-      , Just Refl <- matchAcc a1 a1'-      , Just Refl <- matchAcc a2 a2'-      , matchBoundary matchAcc hashAcc b1 b1'-      , matchBoundary matchAcc hashAcc 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-    :: forall acc aenv sh t. Elt t-    => MatchAcc acc-    -> HashAcc acc-    -> PreBoundary acc aenv (Array sh t)-    -> PreBoundary acc aenv (Array sh t)-    -> Bool-matchBoundary _ _ Clamp        Clamp        = True-matchBoundary _ _ Mirror       Mirror       = True-matchBoundary _ _ Wrap         Wrap         = True-matchBoundary _ _ (Constant s) (Constant t) = matchConst (eltType (undefined::t)) s t-matchBoundary m h (Function f) (Function g)-  | Just Refl <- matchPreOpenFun m h f g-  = 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 (PrimIsInfinite _)         (PrimIsInfinite _)         = 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' (PrimIsInfinite s)         (PrimIsInfinite 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-
− Data/Array/Accelerate/Analysis/Shape.hs 
@@ -1,124 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Analysis.Shape--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] 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.Shape (--  -- * query AST dimensionality-  AccDim, accDim, delayedDim, preAccDim,-  expDim,--) where--import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Trafo.Base-import Data.Array.Accelerate.Array.Sugar---type AccDim acc  = forall aenv sh e. acc aenv (Array sh e) -> Int---- |Reify the dimensionality of the result type of an array computation----accDim :: AccDim OpenAcc-accDim (OpenAcc acc) = preAccDim accDim acc--delayedDim :: AccDim DelayedOpenAcc-delayedDim (Manifest acc)   = preAccDim delayedDim acc-delayedDim (Delayed sh _ _) = expDim sh----- |Reify dimensionality of a computation parameterised over a recursive closure----preAccDim :: forall acc aenv sh e. AccDim acc -> PreOpenAcc acc aenv (Array sh e) -> Int-preAccDim k pacc =-  case pacc of-    Alet  _ acc          -> k acc-    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-                              ArraysRarray -> ndim (eltType (undefined::sh))-#if __GLASGOW_HASKELL__ < 800-                              _            -> error "umm, hello"-#endif--    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-                              ArraysRarray -> ndim (eltType (undefined::sh))-#if __GLASGOW_HASKELL__ < 800-                              _            -> error "can we keep him?"-#endif--    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))-    Unit _               -> 0-    Generate _ _         -> ndim (eltType (undefined::sh))-    Transform _ _ _ _    -> ndim (eltType (undefined::sh))-    Reshape _ _          -> ndim (eltType (undefined::sh))-    Replicate _ _ _      -> ndim (eltType (undefined::sh))-    Slice _ _ _          -> ndim (eltType (undefined::sh))-    Map _ acc            -> k acc-    ZipWith _ _ acc      -> k acc-    Fold _ _ acc         -> k acc - 1-    Fold1 _ acc          -> k acc - 1-    FoldSeg _ _ acc _    -> k acc-    Fold1Seg _ acc _     -> k acc-    Scanl _ _ acc        -> k acc-    Scanl1 _ acc         -> k acc-    Scanr _ _ acc        -> k acc-    Scanr1 _ acc         -> k acc-    Permute _ acc _ _    -> k acc-    Backpermute _ _ _    -> ndim (eltType (undefined::sh))-    Stencil _ _ acc      -> k acc-    Stencil2 _ _ acc _ _ -> k acc----- |Reify dimensionality of a scalar expression yielding a shape----expDim :: forall acc env aenv sh. Elt sh => PreOpenExp acc env aenv sh -> Int-expDim _ = ndim (eltType (undefined :: sh))----- Count the number of components to a tuple type----ndim :: TupleType a -> Int-ndim UnitTuple       = 0-ndim (SingleTuple _) = 1-ndim (PairTuple a b) = ndim a + ndim b-
− Data/Array/Accelerate/Analysis/Stencil.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators       #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Analysis.Stencil--- Copyright   : [2010..2011] Ben Lever---               [2010..2017] 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.Stencil (offsets, offsets2) where--import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Array.Sugar----- |Calculate the offset coordinates for each stencil element relative to the--- focal point. The coordinates are returned as a flattened list from the--- bottom-left element to the top-right. This ordering matches the Var indexing--- order.----offsets :: forall a b sh aenv stencil. Stencil sh a stencil-        => {- dummy -} Fun aenv (stencil -> b)-        -> {- dummy -} OpenAcc aenv (Array sh a)-        -> [sh]-offsets _ _ = positionsR (stencil :: StencilR sh a stencil)--offsets2 :: forall a b c sh aenv stencil1 stencil2. (Stencil sh a stencil1, Stencil sh b stencil2)-         => {- dummy -} Fun aenv (stencil1 -> stencil2 -> c)-         -> {- dummy -} OpenAcc aenv (Array sh a)-         -> {- dummy -} OpenAcc aenv (Array sh b)-         -> ([sh], [sh])-offsets2 _ _ _ =-  ( positionsR (stencil :: StencilR sh a stencil1)-  , positionsR (stencil :: StencilR sh b stencil2) )----- |Position calculation on reified stencil values.----positionsR :: StencilR sh e pat -> [sh]-positionsR StencilRunit3 = map (Z:.) [         -1, 0, 1          ]-positionsR StencilRunit5 = map (Z:.) [      -2,-1, 0, 1, 2       ]-positionsR StencilRunit7 = map (Z:.) [   -3,-2,-1, 0, 1, 2, 3    ]-positionsR StencilRunit9 = map (Z:.) [-4,-3,-2,-1, 0, 1, 2, 3, 4 ]--positionsR (StencilRtup3 c b a) = concat-  [ map (innermost (:. -1)) $ positionsR c-  , map (innermost (:.  0)) $ positionsR b-  , map (innermost (:.  1)) $ positionsR a ]--positionsR (StencilRtup5 e d c b a) = concat-  [ map (innermost (:. -2)) $ positionsR e-  , map (innermost (:. -1)) $ positionsR d-  , map (innermost (:.  0)) $ positionsR c-  , map (innermost (:.  1)) $ positionsR b-  , map (innermost (:.  2)) $ positionsR a ]--positionsR (StencilRtup7 g f e d c b a) = concat-  [ map (innermost (:. -3)) $ positionsR g-  , map (innermost (:. -2)) $ positionsR f-  , map (innermost (:. -1)) $ positionsR e-  , map (innermost (:.  0)) $ positionsR d-  , map (innermost (:.  1)) $ positionsR c-  , map (innermost (:.  2)) $ positionsR b-  , map (innermost (:.  3)) $ positionsR a ]--positionsR (StencilRtup9 i h g f e d c b a) = concat-  [ map (innermost (:. -4)) $ positionsR i-  , map (innermost (:. -3)) $ positionsR h-  , map (innermost (:. -2)) $ positionsR g-  , map (innermost (:. -1)) $ positionsR f-  , map (innermost (:.  0)) $ positionsR e-  , map (innermost (:.  1)) $ positionsR d-  , map (innermost (:.  2)) $ positionsR c-  , map (innermost (:.  3)) $ positionsR b-  , map (innermost (:.  4)) $ positionsR a ]----- Inject a dimension component inner-most----innermost :: Shape sh => (sh -> sh :. Int) -> sh -> sh :. Int-innermost f = invertShape . f . invertShape--invertShape :: Shape sh => sh -> sh-invertShape =  listToShape . reverse . shapeToList-
− Data/Array/Accelerate/Analysis/Type.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Analysis.Type--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ The Accelerate AST does not explicitly store much type information.  Most of--- it is only indirectly through type class constraints -especially, 'Elt'--- constraints- available.  This module provides functions that reify that--- type information in the form of a 'TupleType' value.  This is, for example,--- needed to emit type information in a backend.-----module Data.Array.Accelerate.Analysis.Type (--  -- * Query AST types-  AccType, arrayType, sizeOf,-  accType, expType, delayedAccType, delayedExpType,-  preAccType, preExpType--) where---- standard library-import qualified Foreign.Storable as F---- friends-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Trafo------ |Determine an array type--- ---------------------------- |Reify the element type of an array.----arrayType :: forall sh e. Array sh e -> TupleType (EltRepr e)-arrayType (Array _ _) = eltType (undefined::e)----- |Determine the type of an expressions--- ---------------------------------------type AccType  acc = forall aenv sh e. acc aenv (Array sh e) -> TupleType (EltRepr e)---- |Reify the element type of the result of an array computation.----accType :: AccType OpenAcc-accType (OpenAcc acc) = preAccType accType acc--delayedAccType :: AccType DelayedOpenAcc-delayedAccType (Manifest acc) = preAccType delayedAccType acc-delayedAccType (Delayed _ f _)-  | Lam (Body e) <- f   = delayedExpType e-  | otherwise           = error "my favourite place in the world is wherever you happen to be"----- |Reify the element type of the result of an array computation using the array computation AST--- before tying the knot.----preAccType :: forall acc aenv sh e.-              AccType acc-           -> PreOpenAcc acc aenv (Array sh e)-           -> TupleType (EltRepr e)-preAccType k pacc =-  case pacc of-    Alet  _ acc         -> k acc--    -- The following all contain impossible pattern matches, but GHC's type-    -- checker does no grok that-    ---    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-                             ArraysRarray -> eltType (undefined::e)-#if __GLASGOW_HASKELL__ < 800-                             _            -> error "TRUE STORY."-#endif--    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-                             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-                             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-    Unit _              -> eltType (undefined::e)-    Generate _ _        -> eltType (undefined::e)-    Transform _ _ _ _   -> eltType (undefined::e)-    Reshape _ acc       -> k acc-    Replicate _ _ acc   -> k acc-    Slice _ acc _       -> k acc-    Map _ _             -> eltType (undefined::e)-    ZipWith _ _ _       -> eltType (undefined::e)-    Fold _ _ acc        -> k acc-    FoldSeg _ _ acc _   -> k acc-    Fold1 _ acc         -> k acc-    Fold1Seg _ acc _    -> k acc-    Scanl _ _ acc       -> k acc-    Scanl1 _ acc        -> k acc-    Scanr _ _ acc       -> k acc-    Scanr1 _ acc        -> k acc-    Permute _ _ _ acc   -> k acc-    Backpermute _ _ acc -> k acc-    Stencil _ _ _       -> eltType (undefined::e)-    Stencil2 _ _ _ _ _  -> eltType (undefined::e)----- |Reify the result type of a scalar expression.----expType :: OpenExp env aenv t -> TupleType (EltRepr t)-expType = preExpType accType--delayedExpType :: DelayedOpenExp env aenv t -> TupleType (EltRepr t)-delayedExpType = preExpType delayedAccType---- |Reify the result types of of a scalar expression using the expression AST before tying the--- knot.----preExpType :: forall acc aenv env t.-              AccType acc-           -> PreOpenExp acc aenv env t-           -> TupleType (EltRepr t)-preExpType k e =-  case e of-    Let _ _           -> eltType (undefined::t)-    Var _             -> eltType (undefined::t)-    Const _           -> eltType (undefined::t)-    Tuple _           -> eltType (undefined::t)-    Prj _ _           -> eltType (undefined::t)-    IndexNil          -> eltType (undefined::t)-    IndexCons _ _     -> eltType (undefined::t)-    IndexHead _       -> eltType (undefined::t)-    IndexTail _       -> eltType (undefined::t)-    IndexAny          -> eltType (undefined::t)-    IndexSlice _ _ _  -> eltType (undefined::t)-    IndexFull _ _ _   -> eltType (undefined::t)-    ToIndex _ _       -> eltType (undefined::t)-    FromIndex _ _     -> eltType (undefined::t)-    Cond _ t _        -> preExpType k t-    While _ _ _       -> eltType (undefined::t)-    PrimConst _       -> eltType (undefined::t)-    PrimApp _ _       -> eltType (undefined::t)-    Index acc _       -> k acc-    LinearIndex acc _ -> k acc-    Shape _           -> eltType (undefined::t)-    ShapeSize _       -> eltType (undefined::t)-    Intersect _ _     -> eltType (undefined::t)-    Union _ _         -> eltType (undefined::t)-    Foreign _ _ _     -> eltType (undefined::t)----- |Size of a tuple type, in bytes----sizeOf :: TupleType a -> Int-sizeOf UnitTuple       = 0-sizeOf (PairTuple a b) = sizeOf a + sizeOf b--sizeOf (SingleTuple (NumScalarType (IntegralNumType t)))-  | IntegralDict <- integralDict t = F.sizeOf $ (undefined :: IntegralType a -> a) t-sizeOf (SingleTuple (NumScalarType (FloatingNumType t)))-  | FloatingDict <- floatingDict t = F.sizeOf $ (undefined :: FloatingType a -> a) t-sizeOf (SingleTuple (NonNumScalarType t))-  | NonNumDict   <- nonNumDict t   = F.sizeOf $ (undefined :: NonNumType a   -> a) t-
− Data/Array/Accelerate/Array/Data.hs 
@@ -1,810 +0,0 @@-{-# LANGUAGE DeriveDataTypeable  #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE UnboxedTuples       #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Array.Data--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ This module fixes the concrete representation of Accelerate arrays.  We--- allocate all arrays using pinned memory to enable safe direct-access by--- non-Haskell code in multi-threaded code.  In particular, we can safely pass--- pointers to an array's payload to foreign code.-----module Data.Array.Accelerate.Array.Data (--  -- * Array operations and representations-  ArrayElt(..), ArrayData, MutableArrayData, runArrayData,-  ArrayEltR(..), GArrayData(..),--  -- * Array tuple operations-  fstArrayData, sndArrayData, pairArrayData,--  -- * 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.Monitoring-import Data.Array.Accelerate.Debug.Trace---- standard libraries-import Control.Applicative-import Control.Monad-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--import GHC.Base                                                     ( Int(..), IO(..), unsafeCoerce#, newAlignedPinnedByteArray#, byteArrayContents# )-import GHC.ForeignPtr                                               ( ForeignPtr(..), ForeignPtrContents(..) )----- Determine the underlying type of a Haskell CLong or CULong.----$( runQ [d| type HTYPE_INT = $(-              case finiteBitSize (undefined::Int) of-                32 -> [t| Int32 |]-                64 -> [t| Int64 |]-                _  -> error "I don't know what architecture I am" ) |] )--$( runQ [d| type HTYPE_WORD = $(-              case finiteBitSize (undefined::Word) of-                32 -> [t| Word32 |]-                64 -> [t| Word64 |]-                _  -> error "I don't know what architecture I am" ) |] )--$( runQ [d| type HTYPE_LONG = $(-              case finiteBitSize (undefined::CLong) of-                32 -> [t| Int32 |]-                64 -> [t| Int64 |]-                _  -> error "I don't know what architecture I am" ) |] )--$( runQ [d| type HTYPE_UNSIGNED_LONG = $(-              case finiteBitSize (undefined::CULong) of-                32 -> [t| Word32 |]-                64 -> [t| Word64 |]-                _  -> error "I don't know what architecture I am" ) |] )--$( runQ [d| type HTYPE_CCHAR = $(-              case isSigned (undefined::CChar) of-                True  -> [t| Int8  |]-                False -> [t| Word8 |] ) |] )----- Array representation--- ------------------------ |Immutable array representation----type ArrayData e = MutableArrayData e---- |Mutable array representation----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)----data family GArrayData :: (* -> *) -> * -> *-data instance GArrayData ba ()      = AD_Unit-data instance GArrayData ba Int     = AD_Int     (ba Int)-data instance GArrayData ba Int8    = AD_Int8    (ba Int8)-data instance GArrayData ba Int16   = AD_Int16   (ba Int16)-data instance GArrayData ba Int32   = AD_Int32   (ba Int32)-data instance GArrayData ba Int64   = AD_Int64   (ba Int64)-data instance GArrayData ba Word    = AD_Word    (ba Word)-data instance GArrayData ba Word8   = AD_Word8   (ba Word8)-data instance GArrayData ba Word16  = AD_Word16  (ba Word16)-data instance GArrayData ba Word32  = AD_Word32  (ba Word32)-data instance GArrayData ba Word64  = AD_Word64  (ba Word64)-data instance GArrayData ba CShort  = AD_CShort  (ba Int16)-data instance GArrayData ba CUShort = AD_CUShort (ba Word16)-data instance GArrayData ba CInt    = AD_CInt    (ba Int32)-data instance GArrayData ba CUInt   = AD_CUInt   (ba Word32)-data instance GArrayData ba CLong   = AD_CLong   (ba HTYPE_LONG)-data instance GArrayData ba CULong  = AD_CULong  (ba HTYPE_UNSIGNED_LONG)-data instance GArrayData ba CLLong  = AD_CLLong  (ba Int64)-data instance GArrayData ba CULLong = AD_CULLong (ba Word64)-data instance GArrayData ba Float   = AD_Float   (ba Float)-data instance GArrayData ba Double  = AD_Double  (ba Double)-data instance GArrayData ba CFloat  = AD_CFloat  (ba Float)-data instance GArrayData ba CDouble = AD_CDouble (ba Double)-data instance GArrayData ba Bool    = AD_Bool    (ba Word8)-data instance GArrayData ba Char    = AD_Char    (ba Char)-data instance GArrayData ba CChar   = AD_CChar   (ba HTYPE_CCHAR)-data instance GArrayData ba CSChar  = AD_CSChar  (ba Int8)-data instance GArrayData ba CUChar  = AD_CUChar  (ba Word8)-data instance GArrayData ba (a, b)  = AD_Pair (GArrayData ba a)-                                              (GArrayData ba b)--deriving instance Typeable GArrayData----- | GADT to reify the 'ArrayElt' class.----data ArrayEltR a where-  ArrayEltRunit    :: ArrayEltR ()-  ArrayEltRint     :: ArrayEltR Int-  ArrayEltRint8    :: ArrayEltR Int8-  ArrayEltRint16   :: ArrayEltR Int16-  ArrayEltRint32   :: ArrayEltR Int32-  ArrayEltRint64   :: ArrayEltR Int64-  ArrayEltRword    :: ArrayEltR Word-  ArrayEltRword8   :: ArrayEltR Word8-  ArrayEltRword16  :: ArrayEltR Word16-  ArrayEltRword32  :: ArrayEltR Word32-  ArrayEltRword64  :: ArrayEltR Word64-  ArrayEltRcshort  :: ArrayEltR CShort-  ArrayEltRcushort :: ArrayEltR CUShort-  ArrayEltRcint    :: ArrayEltR CInt-  ArrayEltRcuint   :: ArrayEltR CUInt-  ArrayEltRclong   :: ArrayEltR CLong-  ArrayEltRculong  :: ArrayEltR CULong-  ArrayEltRcllong  :: ArrayEltR CLLong-  ArrayEltRcullong :: ArrayEltR CULLong-  ArrayEltRfloat   :: ArrayEltR Float-  ArrayEltRdouble  :: ArrayEltR Double-  ArrayEltRcfloat  :: ArrayEltR CFloat-  ArrayEltRcdouble :: ArrayEltR CDouble-  ArrayEltRbool    :: ArrayEltR Bool-  ArrayEltRchar    :: ArrayEltR Char-  ArrayEltRcchar   :: ArrayEltR CChar-  ArrayEltRcschar  :: ArrayEltR CSChar-  ArrayEltRcuchar  :: ArrayEltR CUChar-  ArrayEltRpair    :: (ArrayElt a, ArrayElt b)-                   => ArrayEltR a -> ArrayEltR b -> ArrayEltR (a,b)---- Array operations--- ---------------------- TLM: do we need to INLINE these functions to get good performance interfacing---      to external libraries, especially Repa?--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)-  ptrsOfMutableArrayData :: MutableArrayData e -> IO (ArrayPtrs e)-  ---  {-# INLINE unsafeFreezeArrayData  #-}-  {-# INLINE ptrsOfMutableArrayData #-}-  unsafeFreezeArrayData  = return-  ptrsOfMutableArrayData = return . ptrsOfArrayData--instance ArrayElt () where-  type ArrayPtrs () = ()-  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-  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-  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-  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-  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-  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-  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-  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-  {-# 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--instance ArrayElt Word32 where-  type ArrayPtrs Word32 = Ptr Word32-  arrayElt              = ArrayEltRword32-  {-# INLINE unsafeIndexArrayData #-}-  unsafeIndexArrayData (AD_Word32 ba) i   = unsafeIndexArray ba i-  {-# 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--instance ArrayElt Word64 where-  type ArrayPtrs Word64 = Ptr Word64-  arrayElt              = ArrayEltRword64-  {-# INLINE unsafeIndexArrayData #-}-  unsafeIndexArrayData (AD_Word64 ba) i   = unsafeIndexArray ba i-  {-# 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--instance ArrayElt CShort where-  type ArrayPtrs CShort = Ptr Int16-  arrayElt              = ArrayEltRcshort-  {-# INLINE unsafeIndexArrayData #-}-  unsafeIndexArrayData (AD_CShort ba) i   = CShort $ unsafeIndexArray ba i-  {-# 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--instance ArrayElt CUShort where-  type ArrayPtrs CUShort = Ptr Word16-  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--instance ArrayElt CInt where-  type ArrayPtrs CInt = Ptr Int32-  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--instance ArrayElt CUInt where-  type ArrayPtrs CUInt = Ptr Word32-  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--instance ArrayElt CLong where-  type ArrayPtrs CLong = Ptr HTYPE_LONG-  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--instance ArrayElt CULong where-  type ArrayPtrs CULong = Ptr HTYPE_UNSIGNED_LONG-  arrayElt              = ArrayEltRculong-  {-# INLINE unsafeIndexArrayData #-}-  unsafeIndexArrayData (AD_CULong ba) i   = CULong $ unsafeIndexArray ba i-  {-# 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--instance ArrayElt CLLong where-  type ArrayPtrs CLLong = Ptr Int64-  arrayElt              = ArrayEltRcllong-  {-# INLINE unsafeIndexArrayData #-}-  unsafeIndexArrayData (AD_CLLong ba) i   = CLLong $ unsafeIndexArray ba i-  {-# 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--instance ArrayElt CULLong where-  type ArrayPtrs CULLong = Ptr Word64-  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--instance ArrayElt Float where-  type ArrayPtrs Float = Ptr Float-  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-  {-# 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--instance ArrayElt CFloat where-  type ArrayPtrs CFloat = Ptr Float-  arrayElt              = ArrayEltRcfloat-  {-# INLINE unsafeIndexArrayData #-}-  unsafeIndexArrayData (AD_CFloat ba) i   = CFloat $ unsafeIndexArray ba i-  {-# 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--instance ArrayElt CDouble where-  type ArrayPtrs CDouble = Ptr Double-  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---- Bool arrays are stored as arrays of bytes. While this is memory inefficient,--- it is better suited to parallel backends than a packed bit-vector--- representation.----instance ArrayElt Bool where-  type ArrayPtrs Bool = Ptr Word8-  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-  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-  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--instance ArrayElt CSChar where-  type ArrayPtrs CSChar = Ptr Int8-  arrayElt              = ArrayEltRcschar-  {-# INLINE unsafeIndexArrayData #-}-  unsafeIndexArrayData (AD_CSChar ba) i   = CSChar $ unsafeIndexArray ba i-  {-# 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--instance ArrayElt CUChar where-  type ArrayPtrs CUChar = Ptr Word8-  arrayElt              = ArrayEltRcuchar-  {-# INLINE unsafeIndexArrayData #-}-  unsafeIndexArrayData (AD_CUChar ba) i   = CUChar $ unsafeIndexArray ba i-  {-# 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--instance (ArrayElt a, ArrayElt b) => ArrayElt (a, b) where-  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----- 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--- ---------------------{-# 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.----{-# 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 :: Storable e => UniqueArray e -> Int -> e-unsafeIndexArray ua i = unsafePerformIO $! unsafeReadArray ua i---- Read an element from a mutable array at the given index. This does no bounds--- checking.----{-# INLINE unsafeReadArray #-}-unsafeReadArray :: Storable e => UniqueArray e -> Int -> IO e-unsafeReadArray ua i =-  withUniqueArrayPtr ua $ \ptr -> peekElemOff ptr i---- Write an element into a mutable array at the given index. This does no bounds--- checking.----{-# INLINE unsafeWriteArray #-}-unsafeWriteArray :: Storable e => UniqueArray e -> Int -> e -> IO ()-unsafeWriteArray ua i e =-  withUniqueArrayPtr ua $ \ptr -> pokeElemOff ptr i e---- Allocate a new array with enough storage to hold the given number of--- elements.------ 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)-      didAllocateBytesLocal (fromIntegral bytes)-      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----{-# INLINE mallocPlainForeignPtrBytesAligned #-}-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#) #)-
− Data/Array/Accelerate/Array/Lifted.hs 
@@ -1,283 +0,0 @@-{-# 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--}-
− Data/Array/Accelerate/Array/Remote.hs 
@@ -1,26 +0,0 @@-{-# 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-
− Data/Array/Accelerate/Array/Remote/Class.hs 
@@ -1,81 +0,0 @@-{-# 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-
− Data/Array/Accelerate/Array/Remote/LRU.hs 
@@ -1,405 +0,0 @@-{-# 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 Control.Concurrent.MVar                                  ( MVar, newMVar, takeMVar, putMVar, mkWeakMVar )-import Control.Monad                                            ( filterM )-import Control.Monad.Catch-import Control.Monad.IO.Class                                   ( MonadIO, liftIO )-import Data.Functor-import Data.Int                                                 ( Int64 )-import Data.Maybe                                               ( isNothing )-import Data.Proxy-import Foreign.Storable                                         ( sizeOf )-import System.CPUTime-import System.Mem.Weak                                          ( Weak, deRefWeak, finalize )-import Prelude                                                  hiding ( lookup )-import qualified Data.HashTable.IO                              as HT--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 Data.Array.Accelerate.Error                              ( internalError )-import qualified Data.Array.Accelerate.Array.Remote.Table       as Basic-import qualified Data.Array.Accelerate.Debug                    as D----- 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 that the array 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 this function is called on an array that is already contained within the--- cache, this is 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                              -- ^ Was the array allocated successfully?-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 $ D.didEvictBytes (remoteBytes n weak_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--    remoteBytes :: forall e a. PrimElt e a => Int -> Weak (ArrayData e) -> Int64-    remoteBytes n _ = fromIntegral n * fromIntegral (sizeOf (undefined::a))--    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)-
− Data/Array/Accelerate/Array/Remote/Nursery.hs 
@@ -1,127 +0,0 @@-{-# 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 Debug---- libraries-import Control.Concurrent.MVar-import Data.Int-import Data.IntMap                                              ( IntMap )-import Data.Sequence                                            ( Seq )-import Data.Word-import System.Mem.Weak                                          ( Weak )-import Prelude                                                  hiding ( lookup )-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.:< _) -> let sz' = sz - fromIntegral key in do-                           Debug.setCurrentBytesNursery sz'-                           return ( N nrs' sz', 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) -> do-    let sz' = sz + fromIntegral key-    Debug.setCurrentBytesNursery sz'-    return $! N (IM.alter f key im) sz'----- | 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)-                                     Debug.setCurrentBytesNursery 0-                                     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 = Debug.traceIO Debug.dump_gc ("gc: " ++ msg)-
− Data/Array/Accelerate/Array/Remote/Table.hs 
@@ -1,469 +0,0 @@-{-# 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-        D.decreaseCurrentBytesRemote (fromIntegral bytes)-        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  $ D.increaseCurrentBytesRemote (fromIntegral bytes)-  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.-  ---  D.didRemoteGC-  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-
− Data/Array/Accelerate/Array/Representation.hs 
@@ -1,235 +0,0 @@-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Array.Representation--- 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.Representation (--  -- * Array shapes, indices, and slices-  Shape(..), Slice(..), SliceIndex(..),--  -- * Slice shape functions-  sliceShape, enumSlices,--) where---- friends-import Data.Array.Accelerate.Error---- standard library-import GHC.Base                                         ( quotInt, remInt )----- |Index representation------- |Class of index representations (which are nested pairs)----class (Eq sh, Slice sh) => Shape sh where-  -- user-facing methods-  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)-  fromIndex :: sh -> Int -> sh -- inverse of `toIndex`--  iter      :: sh -> (sh -> a) -> (a -> a -> a) -> a -> a-                               -- iterate through the entire shape, applying the function in the-                               -- second argument; third argument combines results and fourth is an-                               -- initial value that is combined with the results; the index space-                               -- is traversed in row-major order--  iter1     :: sh -> (sh -> a) -> (a -> a -> a) -> a-                               -- variant of 'iter' without an initial value--  -- operations to facilitate conversion with IArray-  rangeToShape :: (sh, sh) -> sh   -- convert a minpoint-maxpoint index-                                   -- into a shape-  shapeToRange :: sh -> (sh, sh)   -- ...the converse---  -- other conversions-  shapeToList :: sh -> [Int]    -- convert a shape into its list of dimensions-  listToShape :: [Int] -> sh    -- convert a list of dimensions into a shape--instance Shape () where-  rank _            = 0-  empty             = ()-  ignore            = ()-  () `intersect` () = ()-  () `union` ()     = ()-  size ()           = 1-  toIndex () ()     = 0-  fromIndex () _    = ()-  iter  () f _ _    = f ()-  iter1 () f _      = f ()--  rangeToShape ((), ()) = ()-  shapeToRange ()       = ((), ())--  shapeToList () = []-  listToShape [] = ()-  listToShape _  = $internalError "listToShape" "non-empty list when converting to unit"--instance Shape sh => Shape (sh, Int) where-  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--  fromIndex (sh, sz) i              = (fromIndex sh (i `quotInt` sz), r)-    -- If we assume that the index is in range, there is no point in computing-    -- the remainder for the highest dimension since i < sz must hold.-    ---    where-      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      -> next `addDim` 0-                                        Mirror     -> next `addDim` (-i)-                                        Wrap       -> next `addDim` (sz+i)-                                        Constant e -> Left e-    | i >= sz                       = case bndy of-                                        Clamp      -> next `addDim` (sz-1)-                                        Mirror     -> next `addDim` (sz-(i-sz+2))-                                        Wrap       -> next `addDim` (i-sz)-                                        Constant e -> Left e-    | otherwise                     = next `addDim` i-    where-      -- This function is quite difficult to optimize due to the deep recursion-      -- that it 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---}--  iter (sh, sz) f c r = iter sh (\ix -> iter' (ix,0)) c r-    where-      iter' (ix,i) | i >= sz   = r-                   | otherwise = f (ix,i) `c` iter' (ix,i+1)--  iter1 (_,  0)  _ _ = $boundsError "iter1" "empty iteration space"-  iter1 (sh, sz) f c = iter1 sh (\ix -> iter1' (ix,0)) c-    where-      iter1' (ix,i) | i == sz-1 = f (ix,i)-                    | otherwise = f (ix,i) `c` iter1' (ix,i+1)--  rangeToShape ((sh1, sz1), (sh2, sz2))-    = (rangeToShape (sh1, sh2), sz2 - sz1 + 1)-  shapeToRange (sh, sz)-    = let (low, high) = shapeToRange sh-      in-      ((low, 0), (high, sz - 1))--  shapeToList (sh,sz) = sz : shapeToList sh-  listToShape []      = $internalError "listToShape" "empty list when converting to Ix"-  listToShape (x:xs)  = (listToShape xs,x)----- |Slice representation------- |Class of slice representations (which are nested pairs)----class Slice sl where-  type SliceShape    sl      -- the projected slice-  type CoSliceShape  sl      -- the complement of the slice-  type FullShape     sl      -- the combined dimension-    -- argument *value* not used; it's just a phantom value to fix the type-  sliceIndex :: {-dummy-} sl -> SliceIndex sl (SliceShape sl) (CoSliceShape sl) (FullShape sl)--instance Slice () where-  type SliceShape    () = ()-  type CoSliceShape  () = ()-  type FullShape     () = ()-  sliceIndex _ = SliceNil--instance Slice sl => Slice (sl, ()) where-  type SliceShape   (sl, ()) = (SliceShape  sl, Int)-  type CoSliceShape (sl, ()) = CoSliceShape sl-  type FullShape    (sl, ()) = (FullShape   sl, Int)-  sliceIndex _ = 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 _ = SliceFixed (sliceIndex (undefined::sl))---- |Generalised array index, which may index only in a subset of the dimensions--- of a shape.----data SliceIndex ix slice coSlice sliceDim where-  SliceNil   :: SliceIndex () () () ()-  SliceAll   ::-   SliceIndex ix slice co dim -> SliceIndex (ix, ()) (slice, Int) co (dim, Int)-  SliceFixed ::-   SliceIndex ix slice co dim -> SliceIndex (ix, Int) slice (co, Int) (dim, Int)--instance Show (SliceIndex ix slice coSlice sliceDim) where-  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]]-
− Data/Array/Accelerate/Array/Sugar.hs 
@@ -1,1294 +0,0 @@-{-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# 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 Language.Haskell.TH                                      hiding ( Foreign )-import qualified GHC.Exts                                       as GHC---- friends-import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Type-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-  strForeign _ = "<foreign>"--  -- Backends which want to support compile-time embedding must be able to lift-  -- the foreign function into Template Haskell-  liftForeign :: asm args -> Q (TExp (asm args))-  liftForeign _ = $internalError "liftForeign" "not supported by this backend"----- 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--  -- |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)--  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-
− Data/Array/Accelerate/Array/Unique.hs 
@@ -1,98 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Array.Unique--- Copyright   : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, 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.Unique (--  UniqueArray(..),-  newUniqueArray,-  withUniqueArrayPtr,-  unsafeUniqueArrayPtr,-  touchUniqueArray,--) where---- library-import Control.Applicative-import Control.Concurrent.Unique-import Control.DeepSeq-import Foreign.ForeignPtr-import Foreign.ForeignPtr.Unsafe-import Foreign.Ptr-import Prelude---- friends-import Data.Array.Accelerate.Lifetime----- | A uniquely identifiable array.------ For the purposes of memory management, we use arrays as keys in a table. For--- this reason we need a way to uniquely identify each array we create. We do--- this by attaching a unique identifier to each array.------ Note: [Unique array strictness]------ The actual array data is in many cases unnecessary. For discrete memory--- backends such as for GPUs, we require the unique identifier to track the data--- in the remote memory space, but the data will in most cases never be copied--- back to the host. Thus, the array payload field is only lazily allocated, and--- we should be careful not to make this field overly strict.----data UniqueArray e = UniqueArray-    { uniqueArrayId   :: {-# UNPACK #-} !Unique-    , uniqueArrayData :: {-# UNPACK #-} !(Lifetime (ForeignPtr e))-    }--instance NFData (UniqueArray e) where-  rnf (UniqueArray _ ad) = unsafeGetValue ad `seq` ()----- | Create a new UniqueArray----{-# INLINE newUniqueArray #-}-newUniqueArray :: ForeignPtr e -> IO (UniqueArray e)-newUniqueArray fp = UniqueArray <$> newUnique <*> newLifetime fp---- | Access the pointer backing the unique array.------ The array data is kept alive at least during the whole action, even if it is--- not directly used inside. Note that it is not safe to return the pointer from--- the action and use it after the action completes. All uses of the pointer--- should be inside the bracketed function.----{-# INLINE withUniqueArrayPtr #-}-withUniqueArrayPtr :: UniqueArray a -> (Ptr a -> IO b) -> IO b-withUniqueArrayPtr ua go =-  withLifetime (uniqueArrayData ua) $ \fp -> withForeignPtr fp go----- | Extract the pointer backing the unique array.------ This is potentially unsafe, as if the argument is the last occurrence of this--- unique array then the finalisers will be run, potentially invalidating the--- plain pointer just obtained.------ See also: 'unsafeGetValue', 'unsafeForeignPtrToPtr'.----{-# INLINE unsafeUniqueArrayPtr #-}-unsafeUniqueArrayPtr :: UniqueArray a -> Ptr a-unsafeUniqueArrayPtr = unsafeForeignPtrToPtr . unsafeGetValue . uniqueArrayData----- | Ensure that the unique array is alive at the given place in a sequence of--- IO actions. Note that this does not force the actual array payload.------ See: [Unique array strictness]----{-# INLINE touchUniqueArray #-}-touchUniqueArray :: UniqueArray a -> IO ()-touchUniqueArray = touchLifetime . uniqueArrayData-
− Data/Array/Accelerate/Async.hs 
@@ -1,103 +0,0 @@-{-# LANGUAGE CPP           #-}-{-# LANGUAGE MagicHash     #-}-{-# LANGUAGE UnboxedTuples #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Async--- Copyright   : [2009..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.Async (--  -- * Asynchronous actions-  Async,--  -- ** Spawning-  async, asyncOn, asyncBound,--  -- ** Querying 'Async's-  wait, poll, cancel,--) where--import Control.Exception-import Control.Concurrent--import GHC.Exts-import GHC.Conc-import GHC.IO----- We need to execute the main thread asynchronously to give finalisers a chance--- to run. Make sure to catch exceptions to avoid "blocked indefinitely on MVar"--- errors.----data Async a = Async {-# UNPACK #-} !ThreadId-                     {-# UNPACK #-} !(MVar (Either SomeException a))---- | Spawn an asynchronous action in a separate thread.----async :: IO a -> IO (Async a)-async = inline asyncUsing rawForkIO---- | Like 'async', but using 'forkOn' internally.----asyncOn :: Int -> IO a -> IO (Async a)-asyncOn cpu = inline asyncUsing (rawForkOn cpu)---- | Like 'async', but using 'forkOS' internally.----asyncBound :: IO a -> IO (Async a)-asyncBound = inline asyncUsing forkOS--asyncUsing :: (IO () -> IO ThreadId) -> IO a -> IO (Async a)-asyncUsing fork action = do-   var <- newEmptyMVar-   tid <- mask $ \restore ->-            fork $ try (restore action) >>= putMVar var-   return (Async tid var)---- | Block the calling thread until the computation completes, then return the--- result.----{-# INLINE wait #-}-wait :: Async a -> IO a-wait (Async _ var) = either throwIO return =<< readMVar var---- | Test whether the asynchronous computation has already completed. If so,--- return the result, else 'Nothing'.----{-# INLINE poll #-}-poll :: Async a -> IO (Maybe a)-poll (Async _ var) =-  maybe (return Nothing) (either throwIO (return . Just)) =<< tryReadMVar var---- | Cancel a running asynchronous computation.----{-# INLINE cancel #-}-cancel :: Async a -> IO ()-cancel (Async tid _) = throwTo tid ThreadKilled----- A version of 'forkIO' that does not include the outer exception handler. This--- saves a bit of time when we will be installing our own exception handler.------ Stolen from Simon Marlow's 'async' package (BSD).----{-# INLINE rawForkIO #-}-rawForkIO :: IO () -> IO ThreadId-rawForkIO action = IO $ \s ->-  case fork# action s of-    (# s', tid #) -> (# s', ThreadId tid #)--{-# INLINE rawForkOn #-}-rawForkOn :: Int -> IO () -> IO ThreadId-rawForkOn (I# cpu) action = IO $ \s ->-  case forkOn# cpu action s of-    (# s', tid #) -> (# s', ThreadId tid #)-
− Data/Array/Accelerate/Classes.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--- |--- Module      : Data.Array.Accelerate.Classes--- Copyright   : [2016..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)------ This module provides instances for standard Haskell 98 classes where--- possible, and provides new implementations of those classes where the types--- do not match.-----module Data.Array.Accelerate.Classes (--  -- *** Basic type classes-  module Eq,-  module Ord,-  module Enum,-  module Bounded,--  -- *** Numeric type classes-  module Num,-  module Real,-  module Integral,-  module Fractional,-  module Floating,-  module RealFrac,-  module RealFloat,--  -- *** Numeric conversions-  module FromIntegral,-  module ToFloating,--) where--import Data.Array.Accelerate.Classes.Bounded                        as Bounded-import Data.Array.Accelerate.Classes.Enum                           as Enum-import Data.Array.Accelerate.Classes.Eq                             as Eq-import Data.Array.Accelerate.Classes.Floating                       as Floating-import Data.Array.Accelerate.Classes.Fractional                     as Fractional-import Data.Array.Accelerate.Classes.FromIntegral                   as FromIntegral-import Data.Array.Accelerate.Classes.Integral                       as Integral-import Data.Array.Accelerate.Classes.Num                            as Num-import Data.Array.Accelerate.Classes.Ord                            as Ord-import Data.Array.Accelerate.Classes.Real                           as Real-import Data.Array.Accelerate.Classes.RealFloat                      as RealFloat-import Data.Array.Accelerate.Classes.RealFrac                       as RealFrac-import Data.Array.Accelerate.Classes.ToFloating                     as ToFloating-
− Data/Array/Accelerate/Classes/Bounded.hs 
@@ -1,214 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Classes.Bounded--- Copyright   : [2016..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.Classes.Bounded (--  Bounded,-  P.minBound, P.maxBound,--) where--import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import qualified Prelude                                            as P----- | Name the upper and lower limits of a type. Types which are not totally--- ordered may still have upper and lower bounds.----type Bounded a = (Elt a, P.Bounded (Exp a))---instance P.Bounded (Exp ()) where-  minBound = constant ()-  maxBound = constant ()--instance P.Bounded (Exp Int) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Int8) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Int16) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Int32) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Int64) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Word) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Word8) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Word16) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Word32) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Word64) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CShort) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CUShort) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CInt) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CUInt) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CLong) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CULong) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CLLong) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CULLong) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Bool) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp Char) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CChar) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CSChar) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance P.Bounded (Exp CUChar) where-  minBound = mkMinBound-  maxBound = mkMaxBound--instance ( P.Bounded (Exp a), P.Bounded (Exp b)-         , Elt a, Elt b-         ) => P.Bounded (Exp (a,b)) where-  minBound = tup2 (P.minBound, P.minBound)-  maxBound = tup2 (P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c)-         , Elt a, Elt b, Elt c-         ) => P.Bounded (Exp (a,b,c)) where-  minBound = tup3 (P.minBound, P.minBound, P.minBound)-  maxBound = tup3 (P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d)-         , Elt a, Elt b, Elt c, Elt d-         ) => P.Bounded (Exp (a,b,c,d)) where-  minBound = tup4 (P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup4 (P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e)-         , Elt a, Elt b, Elt c, Elt d, Elt e-         ) => P.Bounded (Exp (a,b,c,d,e)) where-  minBound = tup5 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup5 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f)-         , Elt a, Elt b, Elt c, Elt d, Elt e, Elt f-         ) => P.Bounded (Exp (a,b,c,d,e,f)) where-  minBound = tup6 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup6 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f), P.Bounded (Exp g)-         , Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g-         ) => P.Bounded (Exp (a,b,c,d,e,f,g)) where-  minBound = tup7 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup7 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f), P.Bounded (Exp g), P.Bounded (Exp h)-         , Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h-         ) => P.Bounded (Exp (a,b,c,d,e,f,g,h)) where-  minBound = tup8 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup8 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f), P.Bounded (Exp g), P.Bounded (Exp h), P.Bounded (Exp i)-         , Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i-         ) => P.Bounded (Exp (a,b,c,d,e,f,g,h,i)) where-  minBound = tup9 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup9 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f), P.Bounded (Exp g), P.Bounded (Exp h), P.Bounded (Exp i), P.Bounded (Exp j)-         , Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j-         ) => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j)) where-  minBound = tup10 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup10 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f), P.Bounded (Exp g), P.Bounded (Exp h), P.Bounded (Exp i), P.Bounded (Exp j), P.Bounded (Exp k)-         , Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k-         ) => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k)) where-  minBound = tup11 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup11 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f), P.Bounded (Exp g), P.Bounded (Exp h), P.Bounded (Exp i), P.Bounded (Exp j), P.Bounded (Exp k), P.Bounded (Exp l)-         , Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l-         ) => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k,l)) where-  minBound = tup12 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup12 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f), P.Bounded (Exp g), P.Bounded (Exp h), P.Bounded (Exp i), P.Bounded (Exp j), P.Bounded (Exp k), P.Bounded (Exp l), P.Bounded (Exp m)-         , 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-         ) => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k,l,m)) where-  minBound = tup13 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup13 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f), P.Bounded (Exp g), P.Bounded (Exp h), P.Bounded (Exp i), P.Bounded (Exp j), P.Bounded (Exp k), P.Bounded (Exp l), P.Bounded (Exp m), P.Bounded (Exp n)-         , 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-         ) => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) where-  minBound = tup14 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup14 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)--instance ( P.Bounded (Exp a), P.Bounded (Exp b), P.Bounded (Exp c), P.Bounded (Exp d), P.Bounded (Exp e), P.Bounded (Exp f), P.Bounded (Exp g), P.Bounded (Exp h), P.Bounded (Exp i), P.Bounded (Exp j), P.Bounded (Exp k), P.Bounded (Exp l), P.Bounded (Exp m), P.Bounded (Exp n), P.Bounded (Exp o)-         , 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-         ) => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) where-  minBound = tup15 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)-  maxBound = tup15 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)-
− Data/Array/Accelerate/Classes/Enum.hs 
@@ -1,71 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MonoLocalBinds    #-}-{-# OPTIONS_GHC -fno-warn-missing-methods #-}-{-# OPTIONS_GHC -fno-warn-orphans         #-}--- |--- Module      : Data.Array.Accelerate.Classes.Enum--- Copyright   : [2016..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.Classes.Enum (--  Enum,--) where--import Data.Array.Accelerate.Smart-import Text.Printf--import Prelude                                                      ( String, error )-import qualified Prelude                                            as P----- | Operations over sequentially ordered types----type Enum a = P.Enum (Exp a)----- Instances of 'Enum' don't make sense in Accelerate at the moment. These are--- only provided to fulfil superclass constraints; e.g. Integral.----instance P.Enum (Exp a) where-  toEnum   = preludeError "toEnum"-  fromEnum = preludeError "fromEnum"--preludeError :: String -> a-preludeError x = error (printf "Prelude.%s not supported Accelerate types" x)---- instance Enum (Exp Int8)--- instance Enum (Exp Int16)--- instance Enum (Exp Int32)--- instance Enum (Exp Int64)--- instance Enum (Exp Word)--- instance Enum (Exp Word8)--- instance Enum (Exp Word16)--- instance Enum (Exp Word32)--- instance Enum (Exp Word64)--- instance Enum (Exp CInt)--- instance Enum (Exp CUInt)--- instance Enum (Exp CLong)--- instance Enum (Exp CULong)--- instance Enum (Exp CLLong)--- instance Enum (Exp CULLong)--- instance Enum (Exp CShort)--- instance Enum (Exp CUShort)--- instance Enum (Exp Bool)--- instance Enum (Exp Char)--- instance Enum (Exp CChar)--- instance Enum (Exp CUChar)--- instance Enum (Exp CSChar)--- instance Enum (Exp Float)--- instance Enum (Exp Double)--- instance Enum (Exp CFloat)--- instance Enum (Exp CDouble)-
− Data/Array/Accelerate/Classes/Eq.hs 
@@ -1,304 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Classes.Eq--- Copyright   : [2016..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.Classes.Eq (--  Eq(..),-  (&&),-  (||),-  not,--) where--import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Text.Printf-import Prelude                                                      ( String, error)-import qualified Prelude                                            as P---infix 4 ==-infix 4 /=---- | Conjunction: True if both arguments are true. This is a short-circuit--- operator, so the second argument will be evaluated only if the first is true.----infixr 3 &&-(&&) :: Exp Bool -> Exp Bool -> Exp Bool-(&&) = mkLAnd---- | Disjunction: True if either argument is true. This is a short-circuit--- operator, so the second argument will be evaluated only if the first is--- false.----infixr 2 ||-(||) :: Exp Bool -> Exp Bool -> Exp Bool-(||) = mkLOr---- | Logical negation----not :: Exp Bool -> Exp Bool-not = mkLNot----- | The 'Eq' class defines equality '==' and inequality '/=' for scalar--- Accelerate expressions.------ For convenience, we include 'Elt' as a superclass.----class Elt a => Eq a where-  (==) :: Exp a -> Exp a -> Exp Bool-  (/=) :: Exp a -> Exp a -> Exp Bool-  {-# MINIMAL (==) | (/=) #-}-  x == y = mkLNot (x /= y)-  x /= y = mkLNot (x == y)---instance Eq () where-  _ == _ = constant True   -- force arguments?-  _ /= _ = constant False  -- force arguments?--instance Eq Int where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Int8 where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Int16 where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Int32 where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Int64 where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Word where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Word8 where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Word16 where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Word32 where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Word64 where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CInt where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CUInt where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CLong where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CULong where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CLLong where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CULLong where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CShort where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CUShort where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Bool where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Char where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CChar where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CUChar where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CSChar where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Float where-  (==) = mkEq-  (/=) = mkNEq--instance Eq Double where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CFloat where-  (==) = mkEq-  (/=) = mkNEq--instance Eq CDouble where-  (==) = mkEq-  (/=) = mkNEq--instance (Eq a, Eq b) => Eq (a, b) where-  x == y = let (a1,b1) = untup2 x-               (a2,b2) = untup2 y-           in a1 == a2 && b1 == b2-  x /= y = let (a1,b1) = untup2 x-               (a2,b2) = untup2 y-           in a1 /= a2 || b1 /= b2--instance (Eq a, Eq b, Eq c) => Eq (a, b, c) where-  x == y = let (a1,b1,c1) = untup3 x-               (a2,b2,c2) = untup3 y-           in a1 == a2 && b1 == b2 && c1 == c2-  x /= y = let (a1,b1,c1) = untup3 x-               (a2,b2,c2) = untup3 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2--instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) where-  x == y = let (a1,b1,c1,d1) = untup4 x-               (a2,b2,c2,d2) = untup4 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2-  x /= y = let (a1,b1,c1,d1) = untup4 x-               (a2,b2,c2,d2) = untup4 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2--instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e) where-  x == y = let (a1,b1,c1,d1,e1) = untup5 x-               (a2,b2,c2,d2,e2) = untup5 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2-  x /= y = let (a1,b1,c1,d1,e1) = untup5 x-               (a2,b2,c2,d2,e2) = untup5 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => Eq (a, b, c, d, e, f) where-  x == y = let (a1,b1,c1,d1,e1,f1) = untup6 x-               (a2,b2,c2,d2,e2,f2) = untup6 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2-  x /= y = let (a1,b1,c1,d1,e1,f1) = untup6 x-               (a2,b2,c2,d2,e2,f2) = untup6 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a, b, c, d, e, f, g) where-  x == y = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x-               (a2,b2,c2,d2,e2,f2,g2) = untup7 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2-  x /= y = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x-               (a2,b2,c2,d2,e2,f2,g2) = untup7 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h) => Eq (a, b, c, d, e, f, g, h) where-  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x-               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2-  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x-               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i) => Eq (a, b, c, d, e, f, g, h, i) where-  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2-  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j) => Eq (a, b, c, d, e, f, g, h, i, j) where-  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2-  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k) => Eq (a, b, c, d, e, f, g, h, i, j, k) where-  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2-  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l) => Eq (a, b, c, d, e, f, g, h, i, j, k, l) where-  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2-  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2 || l1 /= l2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m) where-  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2-  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2 || l1 /= l2 || m1 /= m2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where-  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2-  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2 || l1 /= l2 || m1 /= m2 || n1 /= n2--instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where-  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y-           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2 && o1 == o2-  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y-           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2 || l1 /= l2 || m1 /= m2 || n1 /= n2 || o1 /= o2----- Instances of 'Prelude.Eq' don't make sense with the standard signatures as--- the return type is fixed to 'Bool'. This instance is provided to provide--- a useful error message.----instance P.Eq (Exp a) where-  (==) = preludeError "Eq.==" "(==)"-  (/=) = preludeError "Eq./=" "(/=)"--preludeError :: String -> String -> a-preludeError x y = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x y)-
− Data/Array/Accelerate/Classes/Floating.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Classes.Floating--- Copyright   : [2016..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.Classes.Floating (--  Floating,-  P.pi,-  P.sin, P.cos, P.tan,-  P.asin, P.acos, P.atan,-  P.sinh, P.cosh, P.tanh,-  P.asinh, P.acosh, P.atanh,-  P.exp,-  P.sqrt,-  P.log,-  (P.**),-  P.logBase,--) where--import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.Classes.Fractional--import qualified Prelude                                            as P----- | Trigonometric and hyperbolic functions and related functions----type Floating a = (Fractional a, P.Floating (Exp a))---instance P.Floating (Exp Float) where-  pi      = mkPi-  sin     = mkSin-  cos     = mkCos-  tan     = mkTan-  asin    = mkAsin-  acos    = mkAcos-  atan    = mkAtan-  sinh    = mkSinh-  cosh    = mkCosh-  tanh    = mkTanh-  asinh   = mkAsinh-  acosh   = mkAcosh-  atanh   = mkAtanh-  exp     = mkExpFloating-  sqrt    = mkSqrt-  log     = mkLog-  (**)    = mkFPow-  logBase = mkLogBase--instance P.Floating (Exp Double) where-  pi      = mkPi-  sin     = mkSin-  cos     = mkCos-  tan     = mkTan-  asin    = mkAsin-  acos    = mkAcos-  atan    = mkAtan-  sinh    = mkSinh-  cosh    = mkCosh-  tanh    = mkTanh-  asinh   = mkAsinh-  acosh   = mkAcosh-  atanh   = mkAtanh-  exp     = mkExpFloating-  sqrt    = mkSqrt-  log     = mkLog-  (**)    = mkFPow-  logBase = mkLogBase--instance P.Floating (Exp CFloat) where-  pi      = mkPi-  sin     = mkSin-  cos     = mkCos-  tan     = mkTan-  asin    = mkAsin-  acos    = mkAcos-  atan    = mkAtan-  sinh    = mkSinh-  cosh    = mkCosh-  tanh    = mkTanh-  asinh   = mkAsinh-  acosh   = mkAcosh-  atanh   = mkAtanh-  exp     = mkExpFloating-  sqrt    = mkSqrt-  log     = mkLog-  (**)    = mkFPow-  logBase = mkLogBase--instance P.Floating (Exp CDouble) where-  pi      = mkPi-  sin     = mkSin-  cos     = mkCos-  tan     = mkTan-  asin    = mkAsin-  acos    = mkAcos-  atan    = mkAtan-  sinh    = mkSinh-  cosh    = mkCosh-  tanh    = mkTanh-  asinh   = mkAsinh-  acosh   = mkAcosh-  atanh   = mkAtanh-  exp     = mkExpFloating-  sqrt    = mkSqrt-  log     = mkLog-  (**)    = mkFPow-  logBase = mkLogBase-
− Data/Array/Accelerate/Classes/Fractional.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Classes.Fractional--- Copyright   : [2016..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.Classes.Fractional (--  Fractional,-  (P./), P.recip, P.fromRational,--) where--import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.Classes.Num--import Prelude                                                      ( (.), fromRational )-import qualified Prelude                                            as P----- | Fractional numbers, supporting real division----type Fractional a = (Num a, P.Fractional (Exp a))---instance P.Fractional (Exp Float) where-  (/)          = mkFDiv-  recip        = mkRecip-  fromRational = constant . fromRational--instance P.Fractional (Exp Double) where-  (/)          = mkFDiv-  recip        = mkRecip-  fromRational = constant . fromRational--instance P.Fractional (Exp CFloat) where-  (/)          = mkFDiv-  recip        = mkRecip-  fromRational = constant . fromRational--instance P.Fractional (Exp CDouble) where-  (/)          = mkFDiv-  recip        = mkRecip-  fromRational = constant . fromRational-
− Data/Array/Accelerate/Classes/FromIntegral.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE MonoLocalBinds        #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}--- |--- Module      : Data.Array.Accelerate.Classes.FromIntegral--- Copyright   : [2016..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.Classes.FromIntegral (--  FromIntegral(..),--) where--import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.Classes.Integral--import Language.Haskell.TH                                          hiding ( Exp )-import Prelude                                                      hiding ( Integral )----- | Accelerate lacks a most-general lossless 'Prelude.Integer' type, which the--- standard 'Prelude.fromIntegral' function uses as an intermediate value when--- coercing from integral types. Instead, we use this class to capture a direct--- coercion between two types.----class FromIntegral a b where-  -- | General coercion from integral types-  fromIntegral :: Integral a => Exp a -> Exp b---- instance {-# OVERLAPPABLE #-} (Elt a, Elt b, IsIntegral a, IsNum b) => FromIntegral a b where---   fromIntegral = mkFromIntegral----- Reify in ghci:------ $( stringE . show =<< reify ''Thing )---- Generate all the standard instances explicitly. This gives us sensible error--- messages when we don't have an instance available, rather than a "can not--- deduce IsNum..." style error (which the user can do nothing about).----$(runQ $ do-    let-        -- Get all the types that our dictionaries reify-        digItOut :: Name -> Q [Name]-        digItOut name = do-#if __GLASGOW_HASKELL__ < 800-          TyConI (DataD _ _ _   cons _) <- reify name-#else-          TyConI (DataD _ _ _ _ cons _) <- reify name-#endif-          let-            dig (NormalC _ [(_, AppT (ConT n) (VarT _))])               = digItOut n-#if __GLASGOW_HASKELL__ < 800-            dig (ForallC _ _ (NormalC _ [(_, AppT (ConT _) (ConT n))])) = return [n]-#else-            dig (GadtC _ _ (AppT (ConT _) (ConT n)))                    = return [n]-#endif-            dig _ = error "Unexpected case generating FromIntegral instances"-            ---          concat `fmap` mapM dig cons--        thFromIntegral :: Name -> Name -> Q Dec-        thFromIntegral a b =-          let-              ty  = AppT (AppT (ConT (mkName "FromIntegral")) (ConT a)) (ConT b)-              dec = ValD (VarP (mkName "fromIntegral")) (NormalB (VarE (mkName "mkFromIntegral"))) []-          in-          instanceD (return []) (return ty) [return dec]-    ---    as <- digItOut ''IntegralType-    bs <- digItOut ''NumType-    sequence [ thFromIntegral a b | a <- as, b <- bs ]- )-
− Data/Array/Accelerate/Classes/Integral.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MonoLocalBinds    #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Classes.Integral--- Copyright   : [2016..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.Classes.Integral (--  Integral,-  P.quot,-  P.rem,-  P.div,-  P.mod,-  P.quotRem,-  P.divMod,--) where--import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.Classes.Enum-import Data.Array.Accelerate.Classes.Real--import Prelude                                                      ( error )-import qualified Prelude                                            as P----- | Integral numbers, supporting integral division----type Integral a = (Enum a, Real a, P.Integral (Exp a))---instance P.Integral (Exp Int) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp Int8) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp Int16) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp Int32) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp Int64) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp Word) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp Word8) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp Word16) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp Word32) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp Word64) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp CInt) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp CUInt) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp CLong) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp CULong) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp CLLong) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp CULLong) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp CShort) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"--instance P.Integral (Exp CUShort) where-  quot      = mkQuot-  rem       = mkRem-  div       = mkIDiv-  mod       = mkMod-  quotRem   = mkQuotRem-  divMod    = mkDivMod-  toInteger = error "Prelude.toInteger not supported for Accelerate types"-
− Data/Array/Accelerate/Classes/Num.hs 
@@ -1,245 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Classes.Num--- Copyright   : [2016..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.Classes.Num (--  Num,-  (P.+), (P.-), (P.*), P.negate, P.abs, P.signum, P.fromInteger,--) where--import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Prelude                                                      ( (.) )-import qualified Prelude                                            as P----- Should we replace 'Prelude.Num' with our own version, as we did with 'Ord'--- and 'Eq'? That might require clients to enable RebindableSyntax in order to--- get the correct 'fromInteger' (or miss out on special magic and need to add--- 'constant' instead).------ I think that we should, because otherwise we require FlexibleContexts and--- constraints are going to be inconsistent, e.g.:------ f :: (P.Num (Exp a), A.Ord a) => ...------ A light-weight alternative is the following constraint kind:------- | Basic numeric class----type Num a = (Elt a, P.Num (Exp a))---instance P.Num (Exp Int) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Int8) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Int16) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Int32) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Int64) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Word) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Word8) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Word16) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Word32) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Word64) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CInt) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CUInt) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CLong) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CULong) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CLLong) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CULLong) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CShort) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CUShort) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Float) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp Double) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CFloat) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger--instance P.Num (Exp CDouble) where-  (+)         = mkAdd-  (-)         = mkSub-  (*)         = mkMul-  negate      = mkNeg-  abs         = mkAbs-  signum      = mkSig-  fromInteger = constant . P.fromInteger-
− Data/Array/Accelerate/Classes/Ord.hs 
@@ -1,493 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Classes.Ord--- Copyright   : [2016..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.Classes.Ord (--  Ord(..),--) where--import Data.Array.Accelerate.Classes.Eq-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Text.Printf-import Prelude                                                      ( ($), String, error)-import qualified Prelude                                            as P---infix 4 <-infix 4 >-infix 4 <=-infix 4 >=---- | The 'Ord' class for totally ordered datatypes----class Eq a => Ord a where-  {-# MINIMAL (<=) #-}-  (<)  :: Exp a -> Exp a -> Exp Bool-  (>)  :: Exp a -> Exp a -> Exp Bool-  (<=) :: Exp a -> Exp a -> Exp Bool-  (>=) :: Exp a -> Exp a -> Exp Bool-  min  :: Exp a -> Exp a -> Exp a-  max  :: Exp a -> Exp a -> Exp a-  ---  x <  y  = x /= y && x <= y-  x >  y  = not (x <= y)-  x <= y  = not (x > y)-  x >= y  = x == y || not (x <= y)-  min x y = Exp $ Cond (x <= y) x y-  max x y = Exp $ Cond (x <= y) y x---instance Ord () where-  (<)  _ _ = constant False-  (>)  _ _ = constant False-  (>=) _ _ = constant True-  (<=) _ _ = constant True-  min  _ _ = constant ()-  max  _ _ = constant ()--instance Ord Int where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Int8 where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Int16 where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Int32 where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Int64 where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Word where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Word8 where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Word16 where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Word32 where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Word64 where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CInt where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CUInt where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CLong where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CULong where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CLLong where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CULLong where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CShort where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CUShort where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Bool where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Char where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CChar where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CUChar where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CSChar where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Float where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord Double where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CFloat where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance Ord CDouble where-  (<)  = mkLt-  (>)  = mkGt-  (<=) = mkLtEq-  (>=) = mkGtEq-  min  = mkMin-  max  = mkMax--instance (Ord a, Ord b) => Ord (a, b) where-  x <= y = let (a1,b1) = untup2 x-               (a2,b2) = untup2 y-           in a1 < a2 || (a1 == a2 && b1 <= b2)-  x >= y = let (a1,b1) = untup2 x-               (a2,b2) = untup2 y-           in a1 > a2 || (a1 == a2 && b1 >= b2)-  x < y  = let (a1,b1) = untup2 x-               (a2,b2) = untup2 y-           in a1 < a2 || (a1 == a2 && b1 < b2)-  x > y  = let (a1,b1) = untup2 x-               (a2,b2) = untup2 y-           in a1 > a2 || (a1 == a2 && b1 > b2)--instance (Ord a, Ord b, Ord c) => Ord (a, b, c) where-  x <= y = let (a1,b1,c1) = untup3 x; x' = tup2 (b1,c1)-               (a2,b2,c2) = untup3 y; y' = tup2 (b2,c2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1) = untup3 x; x' = tup2 (b1,c1)-               (a2,b2,c2) = untup3 y; y' = tup2 (b2,c2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1) = untup3 x; x' = tup2 (b1,c1)-               (a2,b2,c2) = untup3 y; y' = tup2 (b2,c2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1) = untup3 x; x' = tup2 (b1,c1)-               (a2,b2,c2) = untup3 y; y' = tup2 (b2,c2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) where-  x <= y = let (a1,b1,c1,d1) = untup4 x; x' = tup3 (b1,c1,d1)-               (a2,b2,c2,d2) = untup4 y; y' = tup3 (b2,c2,d2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1) = untup4 x; x' = tup3 (b1,c1,d1)-               (a2,b2,c2,d2) = untup4 y; y' = tup3 (b2,c2,d2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1) = untup4 x; x' = tup3 (b1,c1,d1)-               (a2,b2,c2,d2) = untup4 y; y' = tup3 (b2,c2,d2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1) = untup4 x; x' = tup3 (b1,c1,d1)-               (a2,b2,c2,d2) = untup4 y; y' = tup3 (b2,c2,d2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e) where-  x <= y = let (a1,b1,c1,d1,e1) = untup5 x; x' = tup4 (b1,c1,d1,e1)-               (a2,b2,c2,d2,e2) = untup5 y; y' = tup4 (b2,c2,d2,e2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1) = untup5 x; x' = tup4 (b1,c1,d1,e1)-               (a2,b2,c2,d2,e2) = untup5 y; y' = tup4 (b2,c2,d2,e2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1) = untup5 x; x' = tup4 (b1,c1,d1,e1)-               (a2,b2,c2,d2,e2) = untup5 y; y' = tup4 (b2,c2,d2,e2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1) = untup5 x; x' = tup4 (b1,c1,d1,e1)-               (a2,b2,c2,d2,e2) = untup5 y; y' = tup4 (b2,c2,d2,e2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) => Ord (a, b, c, d, e, f) where-  x <= y = let (a1,b1,c1,d1,e1,f1) = untup6 x; x' = tup5 (b1,c1,d1,e1,f1)-               (a2,b2,c2,d2,e2,f2) = untup6 y; y' = tup5 (b2,c2,d2,e2,f2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1) = untup6 x; x' = tup5 (b1,c1,d1,e1,f1)-               (a2,b2,c2,d2,e2,f2) = untup6 y; y' = tup5 (b2,c2,d2,e2,f2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1) = untup6 x; x' = tup5 (b1,c1,d1,e1,f1)-               (a2,b2,c2,d2,e2,f2) = untup6 y; y' = tup5 (b2,c2,d2,e2,f2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1) = untup6 x; x' = tup5 (b1,c1,d1,e1,f1)-               (a2,b2,c2,d2,e2,f2) = untup6 y; y' = tup5 (b2,c2,d2,e2,f2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g) => Ord (a, b, c, d, e, f, g) where-  x <= y = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x; x' = tup6 (b1,c1,d1,e1,f1,g1)-               (a2,b2,c2,d2,e2,f2,g2) = untup7 y; y' = tup6 (b2,c2,d2,e2,f2,g2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x; x' = tup6 (b1,c1,d1,e1,f1,g1)-               (a2,b2,c2,d2,e2,f2,g2) = untup7 y; y' = tup6 (b2,c2,d2,e2,f2,g2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x; x' = tup6 (b1,c1,d1,e1,f1,g1)-               (a2,b2,c2,d2,e2,f2,g2) = untup7 y; y' = tup6 (b2,c2,d2,e2,f2,g2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x; x' = tup6 (b1,c1,d1,e1,f1,g1)-               (a2,b2,c2,d2,e2,f2,g2) = untup7 y; y' = tup6 (b2,c2,d2,e2,f2,g2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h) => Ord (a, b, c, d, e, f, g, h) where-  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x; x' = tup7 (b1,c1,d1,e1,f1,g1,h1)-               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y; y' = tup7 (b2,c2,d2,e2,f2,g2,h2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x; x' = tup7 (b1,c1,d1,e1,f1,g1,h1)-               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y; y' = tup7 (b2,c2,d2,e2,f2,g2,h2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x; x' = tup7 (b1,c1,d1,e1,f1,g1,h1)-               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y; y' = tup7 (b2,c2,d2,e2,f2,g2,h2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x; x' = tup7 (b1,c1,d1,e1,f1,g1,h1)-               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y; y' = tup7 (b2,c2,d2,e2,f2,g2,h2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i) => Ord (a, b, c, d, e, f, g, h, i) where-  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x; x' = tup8 (b1,c1,d1,e1,f1,g1,h1,i1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y; y' = tup8 (b2,c2,d2,e2,f2,g2,h2,i2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x; x' = tup8 (b1,c1,d1,e1,f1,g1,h1,i1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y; y' = tup8 (b2,c2,d2,e2,f2,g2,h2,i2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x; x' = tup8 (b1,c1,d1,e1,f1,g1,h1,i1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y; y' = tup8 (b2,c2,d2,e2,f2,g2,h2,i2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x; x' = tup8 (b1,c1,d1,e1,f1,g1,h1,i1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y; y' = tup8 (b2,c2,d2,e2,f2,g2,h2,i2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j) => Ord (a, b, c, d, e, f, g, h, i, j) where-  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x; x' = tup9 (b1,c1,d1,e1,f1,g1,h1,i1,j1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y; y' = tup9 (b2,c2,d2,e2,f2,g2,h2,i2,j2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x; x' = tup9 (b1,c1,d1,e1,f1,g1,h1,i1,j1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y; y' = tup9 (b2,c2,d2,e2,f2,g2,h2,i2,j2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x; x' = tup9 (b1,c1,d1,e1,f1,g1,h1,i1,j1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y; y' = tup9 (b2,c2,d2,e2,f2,g2,h2,i2,j2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x; x' = tup9 (b1,c1,d1,e1,f1,g1,h1,i1,j1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y; y' = tup9 (b2,c2,d2,e2,f2,g2,h2,i2,j2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k) => Ord (a, b, c, d, e, f, g, h, i, j, k) where-  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x; x' = tup10 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y; y' = tup10 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x; x' = tup10 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y; y' = tup10 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x; x' = tup10 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y; y' = tup10 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x; x' = tup10 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y; y' = tup10 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l) => Ord (a, b, c, d, e, f, g, h, i, j, k, l) where-  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x; x' = tup11 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y; y' = tup11 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x; x' = tup11 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y; y' = tup11 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x; x' = tup11 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y; y' = tup11 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x; x' = tup11 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y; y' = tup11 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l, Ord m) => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m) where-  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x; x' = tup12 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y; y' = tup12 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x; x' = tup12 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y; y' = tup12 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x; x' = tup12 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y; y' = tup12 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x; x' = tup12 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y; y' = tup12 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n) => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where-  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x; x' = tup13 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y; y' = tup13 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x; x' = tup13 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y; y' = tup13 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x; x' = tup13 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y; y' = tup13 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x; x' = tup13 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y; y' = tup13 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2)-           in a1 > a2 || (a1 == a2 && x' > y')--instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o) => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where-  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x; x' = tup14 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y; y' = tup14 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2)-           in a1 < a2 || (a1 == a2 && x' <= y')-  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x; x' = tup14 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y; y' = tup14 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2)-           in a1 > a2 || (a1 == a2 && x' >= y')-  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x; x' = tup14 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y; y' = tup14 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2)-           in a1 < a2 || (a1 == a2 && x' < y')-  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x; x' = tup14 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1)-               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y; y' = tup14 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2)-           in a1 > a2 || (a1 == a2 && x' > y')----- Instances of 'Prelude.Ord' (mostly) don't make sense with the standard--- signatures as the return type is fixed to 'Bool'. This instance is provided--- to provide a useful error message.------ Note that 'min' and 'max' are implementable, so we do hook those into the--- accelerate instances defined here. This allows us to use operations such as--- 'Prelude.minimum' and 'Prelude.maximum'.----instance Ord a => P.Ord (Exp a) where-  compare = error "Prelude.Ord.compare applied to EDSL types"-  (<)     = preludeError "Ord.<"  "(<)"-  (<=)    = preludeError "Ord.<=" "(<=)"-  (>)     = preludeError "Ord.>"  "(>)"-  (>=)    = preludeError "Ord.>=" "(>=)"-  min     = min-  max     = max--preludeError :: String -> String -> a-preludeError x y = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x y)-
− Data/Array/Accelerate/Classes/Real.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE MonoLocalBinds       #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-missing-methods #-}-{-# OPTIONS_GHC -fno-warn-orphans         #-}--- |--- Module      : Data.Array.Accelerate.Classes.Real--- Copyright   : [2016..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.Classes.Real (--  Real,--) where--import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Classes.Num-import Data.Array.Accelerate.Classes.Ord--import qualified Prelude                                            as P---type Real a = (Num a, Ord a, P.Real (Exp a))---- Instances of 'Real' don't make sense in Accelerate at the moment. These are--- only provided to fulfil superclass constraints; e.g. Integral.------ We won't need `toRational' until we support rational numbers in AP--- computations.----instance (Num a, Ord a) => P.Real (Exp a) where-  toRational = P.error "Prelude.toRational not supported for Accelerate types"-
− Data/Array/Accelerate/Classes/RealFloat.hs 
@@ -1,328 +0,0 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE DefaultSignatures   #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE NoImplicitPrelude   #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE ViewPatterns        #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Classes.RealFloat--- Copyright   : [2016..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.Classes.RealFloat (--  RealFloat(..),--) where--import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.Data.Bits--import Data.Array.Accelerate.Classes.Eq-import Data.Array.Accelerate.Classes.Floating-import Data.Array.Accelerate.Classes.FromIntegral-import Data.Array.Accelerate.Classes.Num-import Data.Array.Accelerate.Classes.Ord-import Data.Array.Accelerate.Classes.RealFrac--import Text.Printf-import Prelude                                                      ( (.), ($), String, error, undefined, otherwise )-import qualified Prelude                                            as P----- | Efficient, machine-independent access to the components of a floating-point--- number----class (RealFrac a, Floating a) => RealFloat a where-  -- | The radix of the representation (often 2) (constant)-  floatRadix     :: Exp a -> Exp Int64  -- Integer-  default floatRadix :: P.RealFloat a => Exp a -> Exp Int64-  floatRadix _    = P.fromInteger (P.floatRadix (undefined::a))--  -- | The number of digits of 'floatRadix' in the significand (constant)-  floatDigits    :: Exp a -> Exp Int-  default floatDigits :: P.RealFloat a => Exp a -> Exp Int-  floatDigits _   = constant (P.floatDigits (undefined::a))--  -- | The lowest and highest values the exponent may assume (constant)-  floatRange     :: Exp a -> (Exp Int, Exp Int)-  default floatRange :: P.RealFloat a => Exp a -> (Exp Int, Exp Int)-  floatRange _    = let (m,n) = P.floatRange (undefined::a)-                    in (constant m, constant n)--  -- | Return the significand and an appropriately scaled exponent. If-  -- @(m,n) = 'decodeFloat' x@ then @x = m*b^^n@, where @b@ is the-  -- floating-point radix ('floatRadix'). Furthermore, either @m@ and @n@ are-  -- both zero, or @b^(d-1) <= 'abs' m < b^d@, where @d = 'floatDigits' x@.-  decodeFloat    :: Exp a -> (Exp Int64, Exp Int)    -- Integer--  -- | Inverse of 'decodeFloat'-  encodeFloat    :: Exp Int64 -> Exp Int -> Exp a    -- Integer-  default encodeFloat :: (FromIntegral Int a, FromIntegral Int64 a) => Exp Int64 -> Exp Int -> Exp a-  encodeFloat x e = fromIntegral x * (fromIntegral (floatRadix (undefined :: Exp a)) ** fromIntegral e)--  -- | Corresponds to the second component of 'decodeFloat'-  exponent       :: Exp a -> Exp Int-  exponent x      = let (m,n) = decodeFloat x-                    in  Exp $ Cond (m == 0)-                                   0-                                   (n + floatDigits x)--  -- | Corresponds to the first component of 'decodeFloat'-  significand    :: Exp a -> Exp a-  significand x   = let (m,_) = decodeFloat x-                    in  encodeFloat m (negate (floatDigits x))--  -- | Multiply a floating point number by an integer power of the radix-  scaleFloat     :: Exp Int -> Exp a -> Exp a-  scaleFloat k x  =-    Exp $ Cond (k == 0 || isFix) x-        $ encodeFloat m (n + clamp b)-    where-      isFix = x == 0 || isNaN x || isInfinite x-      (m,n) = decodeFloat x-      (l,h) = floatRange x-      d     = floatDigits x-      b     = h - l + 4*d-      -- n+k may overflow, which would lead to incorrect results, hence we clamp-      -- the scaling parameter. If (n+k) would be larger than h, (n + clamp b k)-      -- must be too, similar for smaller than (l-d).-      clamp bd  = max (-bd) (min bd k)--  -- | 'True' if the argument is an IEEE \"not-a-number\" (NaN) value-  isNaN          :: Exp a -> Exp Bool--  -- | 'True' if the argument is an IEEE infinity or negative-infinity-  isInfinite     :: Exp a -> Exp Bool--  -- | 'True' if the argument is too small to be represented in normalized-  -- format-  isDenormalized :: Exp a -> Exp Bool--  -- | 'True' if the argument is an IEEE negative zero-  isNegativeZero :: Exp a -> Exp Bool--  -- | 'True' if the argument is an IEEE floating point number-  isIEEE         :: Exp a -> Exp Bool-  default isIEEE :: P.RealFloat a => Exp a -> Exp Bool-  isIEEE _        = constant (P.isIEEE (undefined::Float))--  -- | A version of arctangent taking two real floating-point arguments.-  -- For real floating @x@ and @y@, @'atan2' y x@ computes the angle (from the-  -- positive x-axis) of the vector from the origin to the point @(x,y)@.-  -- @'atan2' y x@ returns a value in the range [@-pi@, @pi@].-  atan2          :: Exp a -> Exp a -> Exp a---instance RealFloat Float where-  atan2           = mkAtan2-  isNaN           = mkIsNaN-  isInfinite      = mkIsInfinite-  isDenormalized  = ieee754 "isDenormalized" (ieee754_f32_is_denormalized . mkUnsafeCoerce)-  isNegativeZero  = ieee754 "isNegativeZero" (ieee754_f32_is_negative_zero . mkUnsafeCoerce)-  decodeFloat     = ieee754 "decodeFloat"    (\x -> let (m,n) = untup2 $ ieee754_f32_decode (mkUnsafeCoerce x)-                                                    in  (fromIntegral m, n))--instance RealFloat Double where-  atan2           = mkAtan2-  isNaN           = mkIsNaN-  isInfinite      = mkIsInfinite-  isDenormalized  = ieee754 "isDenormalized" (ieee754_f64_is_denormalized . mkUnsafeCoerce)-  isNegativeZero  = ieee754 "isNegativeZero" (ieee754_f64_is_negative_zero . mkUnsafeCoerce)-  decodeFloat     = ieee754 "decodeFloat"    (untup2 . ieee754_f64_decode . mkUnsafeCoerce)--instance RealFloat CFloat where-  atan2           = mkAtan2-  isNaN           = mkIsNaN-  isInfinite      = mkIsInfinite-  isDenormalized  = ieee754 "isDenormalized" (ieee754_f32_is_denormalized . mkUnsafeCoerce)-  isNegativeZero  = ieee754 "isNegativeZero" (ieee754_f32_is_negative_zero . mkUnsafeCoerce)-  decodeFloat     = ieee754 "decodeFloat"    (\x -> let (m,n) = untup2 $ ieee754_f32_decode (mkUnsafeCoerce x)-                                                    in  (fromIntegral m, n))--instance RealFloat CDouble where-  atan2           = mkAtan2-  isNaN           = mkIsNaN-  isInfinite      = mkIsInfinite-  isDenormalized  = ieee754 "isDenormalized" (ieee754_f64_is_denormalized . mkUnsafeCoerce)-  isNegativeZero  = ieee754 "isNegativeZero" (ieee754_f64_is_negative_zero . mkUnsafeCoerce)-  decodeFloat     = ieee754 "decodeFloat"    (untup2 . ieee754_f64_decode . mkUnsafeCoerce)----- To satisfy superclass constraints----instance RealFloat a => P.RealFloat (Exp a) where-  floatRadix     = preludeError "floatRadix"-  floatDigits    = preludeError "floatDigits"-  floatRange     = preludeError "floatRange"-  decodeFloat    = preludeError "decodeFloat"-  encodeFloat    = preludeError "encodeFloat"-  isNaN          = preludeError "isNaN"-  isInfinite     = preludeError "isInfinite"-  isDenormalized = preludeError "isDenormalized"-  isNegativeZero = preludeError "isNegativeZero"-  isIEEE         = preludeError "isIEEE"--preludeError :: String -> a-preludeError x = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x x)---ieee754 :: forall a b. P.RealFloat a => String -> (Exp a -> b) -> Exp a -> b-ieee754 name f x-  | P.isIEEE (undefined::a) = f x-  | otherwise               = $internalError (printf "RealFloat.%s" name) "Not implemented for non-IEEE floating point"---- From: ghc/libraries/base/cbits/primFloat.c--- ---------------------------------------------- An IEEE754 number is denormalised iff:---   * exponent is zero---   * mantissa is non-zero.---   * (don't care about setting of sign bit.)----ieee754_f64_is_denormalized :: Exp Word64 -> Exp Bool-ieee754_f64_is_denormalized x =-  ieee754_f64_mantissa x == 0 &&-  ieee754_f64_exponent x /= 0--ieee754_f32_is_denormalized :: Exp Word32 -> Exp Bool-ieee754_f32_is_denormalized x =-  ieee754_f32_mantissa x == 0 &&-  ieee754_f32_exponent x /= 0---- Negative zero if only the sign bit is set----ieee754_f64_is_negative_zero :: Exp Word64 -> Exp Bool-ieee754_f64_is_negative_zero x =-  ieee754_f64_negative x &&-  ieee754_f64_exponent x == 0 &&-  ieee754_f64_mantissa x == 0--ieee754_f32_is_negative_zero :: Exp Word32 -> Exp Bool-ieee754_f32_is_negative_zero x =-  ieee754_f32_negative x &&-  ieee754_f32_exponent x == 0 &&-  ieee754_f32_mantissa x == 0----- Assume the host processor stores integers and floating point numbers in the--- same endianness (true for modern processors).------ To recap, here's the representation of a double precision--- IEEE floating point number:------ sign         63           sign bit (0==positive, 1==negative)--- exponent     62-52        exponent (biased by 1023)--- fraction     51-0         fraction (bits to right of binary point)----ieee754_f64_mantissa :: Exp Word64 -> Exp Word64-ieee754_f64_mantissa x = x .&. 0xFFFFFFFFFFFFF--ieee754_f64_exponent :: Exp Word64 -> Exp Word16-ieee754_f64_exponent x = fromIntegral (x `unsafeShiftR` 52) .&. 0x7FF--ieee754_f64_negative :: Exp Word64 -> Exp Bool-ieee754_f64_negative x = testBit x 63---- Representation of single precision IEEE floating point number:------ sign         31           sign bit (0==positive, 1==negative)--- exponent     30-23        exponent (biased by 127)--- fraction     22-0         fraction (bits to right of binary point)----ieee754_f32_mantissa :: Exp Word32 -> Exp Word32-ieee754_f32_mantissa x = x .&. 0x7FFFFF--ieee754_f32_exponent :: Exp Word32 -> Exp Word8-ieee754_f32_exponent x = fromIntegral (x `unsafeShiftR` 23)--ieee754_f32_negative :: Exp Word32 -> Exp Bool-ieee754_f32_negative x = testBit x 31---- From: ghc/rts/StgPrimFloat.c--- ------------------------------ieee754_f32_decode :: Exp Word32 -> Exp (Int32, Int)-ieee754_f32_decode i =-  let-      _FMSBIT                       = 0x80000000-      _FHIGHBIT                     = 0x00800000-      _FMINEXP                      = ((_FLT_MIN_EXP) - (_FLT_MANT_DIG) - 1)-      _FLT_MANT_DIG                 = floatDigits (undefined::Exp Float)-      (_FLT_MIN_EXP, _FLT_MAX_EXP)  = floatRange  (undefined::Exp Float)--      high1 = fromIntegral i-      high2 = high1 .&. (_FHIGHBIT - 1)--      exp1  = ((fromIntegral high1 `unsafeShiftR` 23) .&. 0xFF) + _FMINEXP-      exp2  = exp1 + 1--      (high3, exp3)-            = untup2-            $ Exp $ Cond (exp1 /= _FMINEXP)-                         -- don't add hidden bit to denorms-                         (tup2 (high2 .|. _FHIGHBIT, exp1))-                         -- a denorm, normalise the mantissa-                         (Exp $ While (\(untup2 -> (h,_)) -> (h .&. _FHIGHBIT) /= 0 )-                                      (\(untup2 -> (h,e)) -> tup2 (h `unsafeShiftL` 1, e-1))-                                      (tup2 (high2, exp2)))--      high4 = Exp $ Cond (fromIntegral i < (0 :: Exp Int32)) (-high3) high3-  in-  Exp $ Cond (high1 .&. complement _FMSBIT == 0)-             (tup2 (0,0))-             (tup2 (high4, exp3))---ieee754_f64_decode :: Exp Word64 -> Exp (Int64, Int)-ieee754_f64_decode i =-  let (s,h,l,e) = untup4 $ ieee754_f64_decode2 i-  in  tup2 (fromIntegral s * (fromIntegral h `unsafeShiftL` 32 .|. fromIntegral l), e)--ieee754_f64_decode2 :: Exp Word64 -> Exp (Int, Word32, Word32, Int)-ieee754_f64_decode2 i =-  let-      _DHIGHBIT                     = 0x00100000-      _DMSBIT                       = 0x80000000-      _DMINEXP                      = ((_DBL_MIN_EXP) - (_DBL_MANT_DIG) - 1)-      _DBL_MANT_DIG                 = floatDigits (undefined::Exp Double)-      (_DBL_MIN_EXP, _DBL_MAX_EXP)  = floatRange  (undefined::Exp Double)--      low   = fromIntegral i-      high  = fromIntegral (i `unsafeShiftR` 32)--      iexp  = (fromIntegral ((high `unsafeShiftR` 20) .&. 0x7FF) + _DMINEXP)-      sign = Exp $ Cond (fromIntegral i < (0 :: Exp Int64)) (-1) 1--      high2 = high .&. (_DHIGHBIT - 1)-      iexp2 = iexp + 1--      (hi,lo,ie)-            = untup3-            $ Exp $ Cond (iexp2 /= _DMINEXP)-                         -- don't add hidden bit to denorms-                         (tup3 (high2 .|. _DHIGHBIT, low, iexp))-                         -- a denorm, nermalise the mantissa-                         (Exp $ While (\(untup3 -> (h,_,_)) -> (h .&. _DHIGHBIT) /= 0)-                                      (\(untup3 -> (h,l,e)) ->-                                        let h1 = h `unsafeShiftL` 1-                                            h2 = Exp $ Cond ((l .&. _DMSBIT) /= 0) (h1+1) h1-                                        in  tup3 (h2, l `unsafeShiftL` 1, e-1))-                                      (tup3 (high2, low, iexp2)))--  in-  Exp $ Cond (low == 0 && (high .&. (complement _DMSBIT)) == 0)-             (tup4 (1,0,0,0))-             (tup4 (sign,hi,lo,ie))-
− Data/Array/Accelerate/Classes/RealFrac.hs 
@@ -1,166 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MonoLocalBinds    #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Classes.RealFrac--- Copyright   : [2016..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.Classes.RealFrac (--  RealFrac(..),-  div', mod', divMod',--) where--import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.Classes.Eq-import Data.Array.Accelerate.Classes.Floating-import Data.Array.Accelerate.Classes.Fractional-import Data.Array.Accelerate.Classes.Num-import Data.Array.Accelerate.Classes.Real-import Data.Array.Accelerate.Classes.ToFloating--import Text.Printf-import Prelude                                                      ( ($), String, error )-import qualified Prelude                                            as P----- | Generalisation of 'P.div' to any instance of 'RealFrac'----div' :: (RealFrac a, Elt b, IsIntegral b) => Exp a -> Exp a -> Exp b-div' n d = floor (n / d)---- | Generalisation of 'P.mod' to any instance of 'RealFrac'----mod' :: (Floating a, RealFrac a, ToFloating Int a) => Exp a -> Exp a -> Exp a-mod' n d = n - (toFloating f) * d-  where-    f :: Exp Int-    f = div' n d---- | Generalisation of 'P.divMod' to any instance of 'RealFrac'----divMod'-    :: (Floating a, RealFrac a, Num b, IsIntegral b, ToFloating b a)-    => Exp a-    -> Exp a-    -> (Exp b, Exp a)-divMod' n d = (f, n - (toFloating f) * d)-  where-    f = div' n d----- | Extracting components of fractions.----class (Real a, Fractional a) => RealFrac a where-  -- The function 'properFraction' takes a real fractional number @x@ and-  -- returns a pair @(n,f)@ such that @x = n+f@, and:-  ---  -- * @n@ is an integral number with the same sign as @x@; and-  ---  -- * @f@ is a fraction with the same type and sign as @x@,-  --   and with absolute value less than @1@.-  ---  -- The default definitions of the 'ceiling', 'floor', 'truncate'-  -- and 'round' functions are in terms of 'properFraction'.-  properFraction :: (Num b, ToFloating b a, IsIntegral b) => Exp a -> (Exp b, Exp a)--  -- The function 'splitFraction' takes a real fractional number @x@ and-  -- returns a pair @(n,f)@ such that @x = n+f@, and:-  ---  -- * @n@ is an integral number with the same sign as @x@; and-  ---  -- * @f@ is a fraction with the same type as @x@ in the range [0,1). Note that-  -- this differs from 'Prelude.properFraction'.-  ---  -- splitFraction :: (Elt b, IsIntegral b) => Exp a -> (Exp b, Exp a)--  -- @fraction x@ returns @x@ with the integer part removed.-  -- fraction       :: Exp a -> Exp a--  -- properFraction is part of the standard Haskell'98 RealFrac type classes-  -- splitFraction / fraction are from numeric-prelude Algebra.RealRing--  -- | @truncate x@ returns the integer nearest @x@ between zero and @x@-  truncate       :: (Elt b, IsIntegral b) => Exp a -> Exp b--  -- | @'round' x@ returns the nearest integer to @x@; the even integer if @x@-  -- is equidistant between two integers-  round          :: (Elt b, IsIntegral b) => Exp a -> Exp b--  -- | @'ceiling' x@ returns the least integer not less than @x@-  ceiling        :: (Elt b, IsIntegral b) => Exp a -> Exp b--  -- | @'floor' x@ returns the greatest integer not greater than @x@-  floor          :: (Elt b, IsIntegral b) => Exp a -> Exp b---instance RealFrac Float where-  properFraction  = defaultProperFraction-  truncate        = mkTruncate-  round           = mkRound-  ceiling         = mkCeiling-  floor           = mkFloor--instance RealFrac Double where-  properFraction  = defaultProperFraction-  truncate        = mkTruncate-  round           = mkRound-  ceiling         = mkCeiling-  floor           = mkFloor--instance RealFrac CFloat where-  properFraction  = defaultProperFraction-  truncate        = mkTruncate-  round           = mkRound-  ceiling         = mkCeiling-  floor           = mkFloor--instance RealFrac CDouble where-  properFraction  = defaultProperFraction-  truncate        = mkTruncate-  round           = mkRound-  ceiling         = mkCeiling-  floor           = mkFloor----- Must test for ±0.0 to avoid returning -0.0 in the second component of the--- pair. Unfortunately the branching costs a lot of performance.----defaultProperFraction-    :: (ToFloating a b, RealFrac b, IsIntegral a, Num a, Floating b)-    => Exp b-    -> (Exp a, Exp b)-defaultProperFraction x =-  untup2 $ Exp-         $ Cond (x == 0) (tup2 (0, 0))-                         (tup2 (n, f))-  where-    n = truncate x-    f = x - toFloating n----- To satisfy superclass constraints----instance RealFrac a => P.RealFrac (Exp a) where-  properFraction = preludeError "properFraction"-  truncate       = preludeError "truncate"-  round          = preludeError "round"-  ceiling        = preludeError "ceiling"-  floor          = preludeError "floor"--preludeError :: String -> a-preludeError x = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x x)-
− Data/Array/Accelerate/Classes/ToFloating.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude     #-}-{-# LANGUAGE TemplateHaskell       #-}--- |--- Module      : Data.Array.Accelerate.Classes.ToFloating--- Copyright   : [2016..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.Classes.ToFloating (--  ToFloating(..),--) where--import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.Classes.Floating-import Data.Array.Accelerate.Classes.Num--import Language.Haskell.TH                                          hiding ( Exp )-import Control.Monad-import Prelude                                                      ( ($), error, concat )----- | Accelerate lacks an arbitrary-precision 'Prelude.Rational' type, which the--- standard 'Prelude.realToFrac' uses as an intermediate value when coercing--- to floating-point types. Instead, we use this class to capture a direct--- coercion between to types.----class ToFloating a b where-  -- | General coercion to floating types-  toFloating :: (Num a, Floating b) => Exp a -> Exp b---- instance (Elt a, Elt b, IsNum a, IsFloating b) => ToFloating a b where---   toFloating = mkToFloating---- Generate standard instances explicitly. See also: 'FromIntegral'.----$(runQ $ do-    let-        -- Get all the types that our dictionaries reify-        digItOut :: Name -> Q [Name]-        digItOut name = do-#if __GLASGOW_HASKELL__ < 800-          TyConI (DataD _ _ _   cons _) <- reify name-#else-          TyConI (DataD _ _ _ _ cons _) <- reify name-#endif-          let-            dig (NormalC _ [(_, AppT (ConT n) (VarT _))])               = digItOut n-#if __GLASGOW_HASKELL__ < 800-            dig (ForallC _ _ (NormalC _ [(_, AppT (ConT _) (ConT n))])) = return [n]-#else-            dig (GadtC _ _ (AppT (ConT _) (ConT n)))                    = return [n]-#endif-            dig _ = error "Unexpected case generating ToFloating instances"-            ---          concat `fmap` mapM dig cons--        thToFloating :: Name -> Name -> Q Dec-        thToFloating a b =-          let-              ty  = AppT (AppT (ConT (mkName "ToFloating")) (ConT a)) (ConT b)-              dec = ValD (VarP (mkName "toFloating")) (NormalB (VarE (mkName "mkToFloating"))) []-          in-          instanceD (return []) (return ty) [return dec]-    ---    as <- digItOut ''NumType-    bs <- digItOut ''FloatingType-    sequence [ thToFloating a b | a <- as, b <- bs ]- )-
− Data/Array/Accelerate/Data/Bits.hs 
@@ -1,806 +0,0 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE ViewPatterns        #-}--- |--- Module      : Data.Array.Accelerate.Data.Bits--- Copyright   : [2016..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)------ Bitwise operations for signed and unsigned integer expressions.-----module Data.Array.Accelerate.Data.Bits (--  Bits(..),-  FiniteBits(..),--) where--import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Language-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.Classes.Eq-import Data.Array.Accelerate.Classes.Ord-import Data.Array.Accelerate.Classes.Num-import Data.Array.Accelerate.Classes.Integral                       ()--import Prelude                                                      ( ($), (.), undefined, otherwise )-import qualified Data.Bits                                          as B---infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`-infixl 7 .&.-infixl 6 `xor`-infixl 5 .|.----- | The 'Bits' class defines bitwise operations over integral scalar expression--- types. As usual, bits are numbered from zero, with zero being the least--- significant bit.----class Eq a => Bits a where-  {-# MINIMAL (.&.), (.|.), xor, complement,-              (shift | (shiftL, shiftR)),-              (rotate | (rotateL, rotateR)),-              isSigned, testBit, bit, popCount #-}--  -- | Bitwise "and"-  (.&.)         :: Exp a -> Exp a -> Exp a--  -- | Bitwise "or"-  (.|.)         :: Exp a -> Exp a -> Exp a--  -- | Bitwise "xor"-  xor           :: Exp a -> Exp a -> Exp a--  -- | Reverse all bits in the argument-  complement    :: Exp a -> Exp a--  -- | @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive, or right by-  -- @-i@ bits otherwise. Right shifts perform sign extension on signed number-  -- types; i.e. they fill the top bits with 1 if the @x@ is negative and with-  -- 0 otherwise.-  shift         :: Exp a -> Exp Int -> Exp a-  shift x i-    = cond (i < 0) (x `shiftR` (-i))-    $ cond (i > 0) (x `shiftL` i)-    $ x--  -- | @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive, or right-  -- by @-i@ bits otherwise.-  rotate        :: Exp a -> Exp Int -> Exp a-  rotate x i-    = cond (i < 0) (x `rotateR` (-i))-    $ cond (i > 0) (x `rotateL` i)-    $ x--  -- | The value with all bits unset-  zeroBits      :: Exp a-  zeroBits = clearBit (bit 0) 0--  -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear.-  bit           :: Exp Int -> Exp a--  -- | @x \`setBit\` i@ is the same as @x .|. bit i@-  setBit        :: Exp a -> Exp Int -> Exp a-  setBit x i = x .|. bit i--  -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@-  clearBit      :: Exp a -> Exp Int -> Exp a-  clearBit x i = x .&. complement (bit i)--  -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@-  complementBit :: Exp a -> Exp Int -> Exp a-  complementBit x i = x `xor` bit i--  -- | Return 'True' if the @n@th bit of the argument is 1-  testBit       :: Exp a -> Exp Int -> Exp Bool--  -- | Return 'True' if the argument is a signed type.-  isSigned      :: Exp a -> Exp Bool--  -- | Shift the argument left by the specified number of bits (which must be-  -- non-negative).-  shiftL        :: Exp a -> Exp Int -> Exp a-  shiftL x i = x `shift` i--  -- | Shift the argument left by the specified number of bits. The result is-  -- undefined for negative shift amounts and shift amounts greater or equal to-  -- the 'finiteBitSize'.-  unsafeShiftL  :: Exp a -> Exp Int -> Exp a-  unsafeShiftL = shiftL--  -- | Shift the first argument right by the specified number of bits (which-  -- must be non-negative).-  ---  -- Right shifts perform sign extension on signed number types; i.e. they fill-  -- the top bits with 1 if @x@ is negative and with 0 otherwise.-  shiftR        :: Exp a -> Exp Int -> Exp a-  shiftR x i = x `shift` (-i)--  -- | Shift the first argument right by the specified number of bits. The-  -- result is undefined for negative shift amounts and shift amounts greater or-  -- equal to the 'finiteBitSize'.-  unsafeShiftR  :: Exp a -> Exp Int -> Exp a-  unsafeShiftR = shiftR--  -- | Rotate the argument left by the specified number of bits (which must be-  -- non-negative).-  rotateL       :: Exp a -> Exp Int -> Exp a-  rotateL x i = x `rotate` i--  -- | Rotate the argument right by the specified number of bits (which must be non-negative).-  rotateR       :: Exp a -> Exp Int -> Exp a-  rotateR x i = x `rotate` (-i)--  -- | Return the number of set bits in the argument. This number is known as-  -- the population count or the Hamming weight.-  popCount      :: Exp a -> Exp Int---class Bits b => FiniteBits b where-  -- | Return the number of bits in the type of the argument.-  finiteBitSize :: Exp b -> Exp Int--  -- | Count the number of zero bits preceding the most significant set bit.-  -- This can be used to compute a base-2 logarithm via:-  ---  -- > logBase2 x = finiteBitSize x - 1 - countLeadingZeros x-  ---  countLeadingZeros :: Exp b -> Exp Int--  -- | Count the number of zero bits following the least significant set bit.-  -- The related-  -- <http://en.wikipedia.org/wiki/Find_first_set find-first-set operation> can-  -- be expressed in terms of this as:-  ---  -- > findFirstSet x = 1 + countTrailingZeros x-  ---  countTrailingZeros :: Exp b -> Exp Int----- Instances for Bits--- --------------------instance Bits Bool where-  (.&.)        = (&&)-  (.|.)        = (||)-  xor          = (/=)-  complement   = not-  shift x i    = cond (i == 0) x (constant False)-  testBit x i  = cond (i == 0) x (constant False)-  rotate x _   = x-  bit i        = i == 0-  isSigned     = isSignedDefault-  popCount     = mkBoolToInt--instance Bits Int where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits Int8 where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits Int16 where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits Int32 where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits Int64 where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits Word where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits Word8 where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits Word16 where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits Word32 where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits Word64 where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits CInt where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits CUInt where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits CLong where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits CULong where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits CLLong where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits CULLong where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits CShort where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount--instance Bits CUShort where-  (.&.)        = mkBAnd-  (.|.)        = mkBOr-  xor          = mkBXor-  complement   = mkBNot-  bit          = bitDefault-  testBit      = testBitDefault-  shift        = shiftDefault-  shiftL       = shiftLDefault-  shiftR       = shiftRDefault-  unsafeShiftL = mkBShiftL-  unsafeShiftR = mkBShiftR-  rotate       = rotateDefault-  rotateL      = rotateLDefault-  rotateR      = rotateRDefault-  isSigned     = isSignedDefault-  popCount     = mkPopCount---- instance Bits CChar where---   (.&.)        = mkBAnd---   (.|.)        = mkBOr---   xor          = mkBXor---   complement   = mkBNot---   bit          = bitDefault---   testBit      = testBitDefault---   shift        = shiftDefault---   shiftL       = shiftLDefault---   shiftR       = shiftRDefault---   unsafeShiftL = mkBShiftL---   unsafeShiftR = mkBShiftR---   rotate       = rotateDefault---   rotateL      = rotateLDefault---   rotateR      = rotateRDefault---   isSigned     = isSignedDefault---   popCount     = mkPopCount---- instance Bits CUChar where---   (.&.)        = mkBAnd---   (.|.)        = mkBOr---   xor          = mkBXor---   complement   = mkBNot---   bit          = bitDefault---   testBit      = testBitDefault---   shift        = shiftDefault---   shiftL       = shiftLDefault---   shiftR       = shiftRDefault---   unsafeShiftL = mkBShiftL---   unsafeShiftR = mkBShiftR---   rotate       = rotateDefault---   rotateL      = rotateLDefault---   rotateR      = rotateRDefault---   isSigned     = isSignedDefault---   popCount     = mkPopCount---- instance Bits CSChar where---   (.&.)        = mkBAnd---   (.|.)        = mkBOr---   xor          = mkBXor---   complement   = mkBNot---   bit          = bitDefault---   testBit      = testBitDefault---   shift        = shiftDefault---   shiftL       = shiftLDefault---   shiftR       = shiftRDefault---   unsafeShiftL = mkBShiftL---   unsafeShiftR = mkBShiftR---   rotate       = rotateDefault---   rotateL      = rotateLDefault---   rotateR      = rotateRDefault---   isSigned     = isSignedDefault---   popCount     = mkPopCount----- Instances for FiniteBits--- --------------------------instance FiniteBits Bool where-  finiteBitSize _      = constant (B.finiteBitSize (undefined::Bool))-  countLeadingZeros  x = cond x 0 1-  countTrailingZeros x = cond x 0 1--instance FiniteBits Int where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits Int8 where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int8))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits Int16 where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int16))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits Int32 where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int32))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits Int64 where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int64))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits Word where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits Word8 where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word8))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits Word16 where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word16))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits Word32 where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word32))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits Word64 where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word64))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits CInt where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::CInt))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits CUInt where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::CUInt))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits CLong where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::CLong))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits CULong where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::CULong))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits CLLong where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::CLLong))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits CULLong where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::CULLong))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits CShort where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::CShort))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros--instance FiniteBits CUShort where-  finiteBitSize _    = constant (B.finiteBitSize (undefined::CUShort))-  countLeadingZeros  = mkCountLeadingZeros-  countTrailingZeros = mkCountTrailingZeros---- instance FiniteBits CChar--- instance FiniteBits CUChar--- instance FiniteBits CSChar----- Default implementations--- -------------------------bitDefault :: (IsIntegral t, Bits t) => Exp Int -> Exp t-bitDefault x = constant 1 `shiftL` x--testBitDefault :: (IsIntegral t, Bits t) => Exp t -> Exp Int -> Exp Bool-testBitDefault x i = (x .&. bit i) /= constant 0--shiftDefault :: (FiniteBits t, IsIntegral t, B.Bits t) => Exp t -> Exp Int -> Exp t-shiftDefault x i-  = cond (i >= 0) (shiftLDefault x i)-                  (shiftRDefault x (-i))--shiftLDefault :: (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t-shiftLDefault x i-  = cond (i >= finiteBitSize x) (constant 0)-  $ mkBShiftL x i--shiftRDefault :: forall t. (B.Bits t, FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t-shiftRDefault-  | B.isSigned (undefined::t) = shiftRADefault-  | otherwise                 = shiftRLDefault---- Shift the argument right (signed)-shiftRADefault :: (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t-shiftRADefault x i-  = cond (i >= finiteBitSize x) (cond (mkLt x (constant 0)) (constant (-1)) (constant 0))-  $ mkBShiftR x i---- Shift the argument right (unsigned)-shiftRLDefault :: (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t-shiftRLDefault x i-  = cond (i >= finiteBitSize x) (constant 0)-  $ mkBShiftR x i--rotateDefault :: forall t. (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t-rotateDefault =-  case (integralType :: IntegralType t) of-    TypeInt{}     -> rotateDefault' (undefined::Word)-    TypeInt8{}    -> rotateDefault' (undefined::Word8)-    TypeInt16{}   -> rotateDefault' (undefined::Word16)-    TypeInt32{}   -> rotateDefault' (undefined::Word32)-    TypeInt64{}   -> rotateDefault' (undefined::Word64)-    TypeWord{}    -> rotateDefault' (undefined::Word)-    TypeWord8{}   -> rotateDefault' (undefined::Word8)-    TypeWord16{}  -> rotateDefault' (undefined::Word16)-    TypeWord32{}  -> rotateDefault' (undefined::Word32)-    TypeWord64{}  -> rotateDefault' (undefined::Word64)-    TypeCShort{}  -> rotateDefault' (undefined::CUShort)-    TypeCUShort{} -> rotateDefault' (undefined::CUShort)-    TypeCInt{}    -> rotateDefault' (undefined::CUInt)-    TypeCUInt{}   -> rotateDefault' (undefined::CUInt)-    TypeCLong{}   -> rotateDefault' (undefined::CULong)-    TypeCULong{}  -> rotateDefault' (undefined::CULong)-    TypeCLLong{}  -> rotateDefault' (undefined::CULLong)-    TypeCULLong{} -> rotateDefault' (undefined::CULLong)--rotateDefault'-    :: forall i w. (Elt w, FiniteBits i, IsIntegral i, IsIntegral w, BitSizeEq i w, BitSizeEq w i)-    => w {- dummy -}-    -> Exp i-    -> Exp Int-    -> Exp i-rotateDefault' _ x i-  = cond (i' == 0) x-  $ w2i ((x' `mkBShiftL` i') `mkBOr` (x' `mkBShiftR` (wsib - i')))-  where-    w2i  = mkBitcast :: Exp w -> Exp i-    i2w  = mkBitcast :: Exp i -> Exp w-    ---    x'   = i2w x-    i'   = i `mkBAnd` (wsib - 1)-    wsib = finiteBitSize x--rotateLDefault :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t-rotateLDefault x i-  = cond (i == 0) x-  $ mkBRotateL x i--rotateRDefault :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t-rotateRDefault x i-  = cond (i == 0) x-  $ mkBRotateR x i--isSignedDefault :: forall b. B.Bits b => Exp b -> Exp Bool-isSignedDefault _ = constant (B.isSigned (undefined::b))--_popCountDefault :: forall a. (B.FiniteBits a, IsScalar a, Bits a, Num a) => Exp a -> Exp Int-_popCountDefault =-  $( [e| case B.finiteBitSize (undefined::a) of-           8  -> popCnt8  . mkUnsafeCoerce-           16 -> popCnt16 . mkUnsafeCoerce-           32 -> popCnt32 . mkUnsafeCoerce-           64 -> popCnt64 . mkUnsafeCoerce-           _  -> popCountKernighan |] )---- http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan-popCountKernighan :: (Bits a, Num a) => Exp a -> Exp Int-popCountKernighan x = r-  where-    (r,_) = untup2-          $ while (\(untup2 -> (_,v)) -> v /= 0)-                  (\(untup2 -> (c,v)) -> tup2 (c+1, v .&. (v-1)))-                  (tup2 (0,x))---- http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetParallel-popCnt8 :: Exp Word8 -> Exp Int-popCnt8 v1 = mkFromIntegral c-  where-    v2 = v1 - ((v1 `unsafeShiftR` 1) .&. 0x55)-    v3 = (v2 .&. 0x33) + ((v2 `unsafeShiftR` 2) .&. 0x33)-    v4 = (v3 + (v3 `unsafeShiftR` 4)) .&. 0x0F-    c  = v4 * 0x01--popCnt16 :: Exp Word16 -> Exp Int-popCnt16 v1 = mkFromIntegral c-  where-    v2 = v1 - ((v1 `unsafeShiftR` 1) .&. 0x5555)-    v3 = (v2 .&. 0x3333) + ((v2 `unsafeShiftR` 2) .&. 0x3333)-    v4 = (v3 + (v3 `unsafeShiftR` 4)) .&. 0x0F0F-    c  = (v4 * 0x0101) `unsafeShiftR` 8--popCnt32 :: Exp Word32 -> Exp Int-popCnt32 v1 = mkFromIntegral c-  where-    v2 = v1 - ((v1 `unsafeShiftR` 1) .&. 0x55555555)-    v3 = (v2 .&. 0x33333333) + ((v2 `unsafeShiftR` 2) .&. 0x33333333)-    v4 = (v3 + (v3 `unsafeShiftR` 4)) .&. 0x0F0F0F0F-    c  = (v4 * 0x01010101) `unsafeShiftR` 24--popCnt64 :: Exp Word64 -> Exp Int-popCnt64 v1 = mkFromIntegral c-  where-    v2 = v1 - ((v1 `unsafeShiftR` 1) .&. 0x5555555555555555)-    v3 = (v2 .&. 0x3333333333333333) + ((v2 `unsafeShiftR` 2) .&. 0x3333333333333333)-    v4 = (v3 + (v3 `unsafeShiftR` 4)) .&. 0X0F0F0F0F0F0F0F0F-    c  = (v4 * 0x0101010101010101) `unsafeShiftR` 56-
− Data/Array/Accelerate/Data/Complex.hs 
@@ -1,202 +0,0 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeSynonymInstances  #-}-{-# LANGUAGE UndecidableInstances  #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Data.Complex--- Copyright   : [2015..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Complex numbers----module Data.Array.Accelerate.Data.Complex (--  -- * Rectangular from-  Complex(..),-  real,-  imag,--  -- * Polar form-  mkPolar,-  cis,-  polar,-  magnitude,-  phase,--  -- * Conjugate-  conjugate,--) where--import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Classes                                as A-import Data.Array.Accelerate.Language-import Data.Array.Accelerate.Lift-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Prelude                                                      ( ($), undefined, fromInteger )-import Data.Complex                                                 ( Complex(..) )-import qualified Data.Complex                                       as C-import qualified Prelude                                            as P---type instance EltRepr (Complex a) = EltRepr (a, a)--instance Elt a => Elt (Complex a) where-  eltType _             = eltType (undefined :: (a,a))-  toElt p               = let (a, b) = toElt p in a :+ b-  fromElt (a :+ b)      = fromElt (a, b)--instance cst a => IsProduct cst (Complex a) where-  type ProdRepr (Complex a) = ProdRepr (a, a)-  fromProd cst (x :+ y) = fromProd cst (x, y)-  toProd cst p          = let (x, y) = toProd cst p in (x :+ y)-  prod cst _            = prod cst (undefined :: (a, a))--instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Complex a) where-  type Plain (Complex a) = Complex (Plain a)-  lift (x1 :+ x2)       = Exp $ Tuple (NilTup `SnocTup` lift x1 `SnocTup` lift x2)--instance Elt a => Unlift Exp (Complex (Exp a)) where-  unlift e-    = let x     = Exp $ SuccTupIdx ZeroTupIdx `Prj` e-          y     = Exp $ ZeroTupIdx `Prj` e-      in-      x :+ y--instance A.Eq a => A.Eq (Complex a) where-  x == y = let r1 :+ c1 = unlift x-               r2 :+ c2 = unlift y-           in  r1 == r2 && c1 == c2-  x /= y = let r1 :+ c1 = unlift x-               r2 :+ c2 = unlift y-           in  r1 /= r2 || c1 /= c2--instance A.RealFloat a => P.Num (Exp (Complex a)) where-  (+)           = lift2 ((+) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))-  (-)           = lift2 ((-) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))-  (*)           = lift2 ((*) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))-  negate        = lift1 (negate :: Complex (Exp a) -> Complex (Exp a))-  signum        = lift1 (signum :: Complex (Exp a) -> Complex (Exp a))-  abs           = lift1 (abs :: Complex (Exp a) -> Complex (Exp a))-  fromInteger n = lift ((fromInteger n :: Exp a) :+ 0)--instance A.RealFloat a => P.Fractional (Exp (Complex a)) where-  c / c'-    = let x  :+ y       = unlift c-          x' :+ y'      = unlift c'     :: Complex (Exp a)-          den           = x' P.^ (2 :: Int) + y' P.^ (2 :: Int)-          re            = (x * x' + y * y') / den-          im            = (y * x' - x * y') / den-      in-      lift (re :+ im)--  fromRational x-    = lift ((fromRational x :: Exp a) :+ 0)--instance A.RealFloat a => P.Floating (Exp (Complex a)) where-  sqrt z-    = let-          x :+ y        = unlift z-          v'            = abs y / (u'*2)-          u'            = sqrt ((magnitude z + abs x) / 2)-          (u, v)        = unlift $ cond (x < 0) (lift (v',u')) (lift (u',v'))-      in-      cond (x == 0 && y == 0)-        {- then -} 0-        {- else -} (lift (u :+ (cond (y < 0) (-v) v)))--  pi            = lift (pi :: Complex (Exp a))-  log z         = lift (log (magnitude z) :+ phase z)-  exp           = lift1 (exp :: Complex (Exp a) -> Complex (Exp a))-  sin           = lift1 (sin :: Complex (Exp a) -> Complex (Exp a))-  cos           = lift1 (cos :: Complex (Exp a) -> Complex (Exp a))-  tan           = lift1 (tan :: Complex (Exp a) -> Complex (Exp a))-  sinh          = lift1 (sinh :: Complex (Exp a) -> Complex (Exp a))-  cosh          = lift1 (cosh :: Complex (Exp a) -> Complex (Exp a))-  tanh          = lift1 (tanh :: Complex (Exp a) -> Complex (Exp a))-  asin          = lift1 (asin :: Complex (Exp a) -> Complex (Exp a))-  acos          = lift1 (acos :: Complex (Exp a) -> Complex (Exp a))-  atan          = lift1 (atan :: Complex (Exp a) -> Complex (Exp a))-  asinh         = lift1 (asinh :: Complex (Exp a) -> Complex (Exp a))-  acosh         = lift1 (acosh :: Complex (Exp a) -> Complex (Exp a))-  atanh         = lift1 (atanh :: Complex (Exp a) -> Complex (Exp a))--instance (A.FromIntegral a b, A.Num b) => A.FromIntegral a (Complex b) where-  fromIntegral x = lift (fromIntegral x :+ (0 :: Exp b))----- | The non-negative magnitude of a complex number----magnitude :: RealFloat a => Exp (Complex a) -> Exp a-magnitude c =-  let r :+ i    = unlift c-  in sqrt (r*r + i*i)---- | The phase of a complex number, in the range @(-'pi', 'pi']@. If the--- magnitude is zero, then so is the phase.----phase :: RealFloat a => Exp (Complex a) -> Exp a-phase c =-  let x :+ y    = unlift c-  in atan2 y x---- | The function 'polar' takes a complex number and returns a (magnitude,--- phase) pair in canonical form: the magnitude is non-negative, and the phase--- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.----polar :: RealFloat a => Exp (Complex a) -> Exp (a,a)-polar z =  lift (magnitude z, phase z)---- | Form a complex number from polar components of magnitude and phase.----#if __GLASGOW_HASKELL__ <= 708-mkPolar :: forall a. RealFloat a => Exp a -> Exp a -> Exp (Complex a)-#else-mkPolar :: forall a. Floating a  => Exp a -> Exp a -> Exp (Complex a)-#endif-mkPolar = lift2 (C.mkPolar :: Exp a -> Exp a -> Complex (Exp a))---- | @'cis' t@ is a complex value with magnitude @1@ and phase @t@ (modulo--- @2*'pi'@).----#if __GLASGOW_HASKELL__ <= 708-cis :: forall a. RealFloat a => Exp a -> Exp (Complex a)-#else-cis :: forall a. Floating a  => Exp a -> Exp (Complex a)-#endif-cis = lift1 (C.cis :: Exp a -> Complex (Exp a))---- | Return the real part of a complex number----real :: Elt a => Exp (Complex a) -> Exp a-real c =-  let r :+ _    = unlift c-  in  r---- | Return the imaginary part of a complex number----imag :: Elt a => Exp (Complex a) -> Exp a-imag c =-  let _ :+ i    = unlift c-  in  i---- | Return the complex conjugate of a complex number, defined as------ > conjugate(Z) = X - iY----conjugate :: Num a => Exp (Complex a) -> Exp (Complex a)-conjugate z = lift $ real z :+ (- imag z)-
− Data/Array/Accelerate/Data/Fold.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs             #-}-{-# LANGUAGE TypeOperators     #-}--- |--- Module      : Data.Array.Accelerate.Data.Fold--- Copyright   : [2016..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Combine folds in 'Applicative' style to generate multiple results with--- a single pass over the array. Based on Max Rabkin's "Beautiful Folding" [1]--- and talks by Gabriel Gonzalez [2].------  1. <http://squing.blogspot.com/2008/11/beautiful-folding.html>---  2. <https://www.youtube.com/watch?v=6a5Ti0r8Q2s>-----module Data.Array.Accelerate.Data.Fold (--  Fold(..), runFold,--) where--import Data.Array.Accelerate                                        hiding ( fold, sum, product, length )-import Data.Array.Accelerate.Data.Monoid-import qualified Data.Array.Accelerate                              as A--import Control.Applicative                                          as P-import Prelude                                                      hiding ( sum, product, length )-import qualified Prelude                                            as P----- | 'Fold' describes how to process data of some 'i'nput type into some--- 'o'utput type, via a reduction using some intermediate Monoid 'w'. For--- example, both 'sum' and 'length' below use the 'Sum' monoid:------ >>> let sum = Fold (lift . Sum) (getSum . unlift)--- >>> let length = Fold (\_ -> 1) (getSum . unlift)------ The key is that 'Fold's can be combined using 'Applicative' in order to--- produce multiple outputs from a /single/ reduction of the array. For example:------ >>> let average = (/) <$> sum <*> length------ This computes both the sum of the array as well as its length in a single--- traversal, then combines both results to compute the average.------ Because 'Fold' has some numeric instances, this can also be defined more--- succinctly as:------ >>> let average = sum / length------ A more complex example:------ >>> let sumOfSquares = Fold (lift . Sum . (^2)) (getSum . unlift)--- >>> let standardDeviation = sqrt ((sumOfSquares / length) - (sum / length) ^ 2)------ These will all execute with a single reduction kernel and a single map to--- summarise (combine) the results.----data Fold i o where-  Fold :: (Elt w, Monoid (Exp w))-       => (i -> Exp w)              -- transform input element into internal monoid type-       -> (Exp w -> o)              -- summarise the reduction to retrieve the final result-       -> Fold i o---- | Apply a 'Fold' to an array.----runFold-    :: (Shape sh, Elt i, Elt o)-    => Fold (Exp i) (Exp o)-    -> Acc (Array (sh:.Int) i)-    -> Acc (Array sh o)-runFold (Fold tally summarise) is-  = A.map summarise-  $ A.fold (<>) mempty-  $ A.map tally is----- sum :: A.Num e => Fold (Exp e) (Exp e)--- sum = Fold (lift . Sum) (getSum . unlift)---- product :: A.Num e => Fold (Exp e) (Exp e)--- product = Fold (lift . Product) (getProduct . unlift)---- length :: A.Num i => Fold (Exp e) (Exp i)--- length = Fold (\_ -> 1) (getSum . unlift)----- combine2 :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a,b)--- combine2 a b = lift (a,b)---- combine3 :: (Elt a, Elt b, Elt c) => Exp a -> Exp b -> Exp c -> Exp (a,b,c)--- combine3 a b c = lift (a,b,c)---- combine4 :: (Elt a, Elt b, Elt c, Elt d) => Exp a -> Exp b -> Exp c -> Exp d -> Exp (a,b,c,d)--- combine4 a b c d = lift (a,b,c,d)---- combine5 :: (Elt a, Elt b, Elt c, Elt d, Elt e) => Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp (a,b,c,d,e)--- combine5 a b c d e = lift (a,b,c,d,e)----- Instances for 'Fold'--- ----------------------instance P.Functor (Fold i) where-  fmap k (Fold tally summarise) = Fold tally (k . summarise)--instance P.Applicative (Fold i) where-  pure o                    = Fold (\_ -> constant ()) (\_ -> o)-  Fold tF sF <*> Fold tX sX = Fold tally summarise-    where-      tally i     = lift (tF i, tX i)-      summarise t = let (mF, mX) = unlift t-                    in sF mF (sX mX)--instance A.Num b => P.Num (Fold a (Exp b)) where-  (+)           = liftA2 (+)-  (-)           = liftA2 (-)-  (*)           = liftA2 (*)-  negate        = fmap negate-  abs           = fmap abs-  signum        = fmap signum-  fromInteger n = pure (fromInteger n)--instance A.Fractional b => P.Fractional (Fold a (Exp b)) where-  (/)            = liftA2 (/)-  recip          = fmap recip-  fromRational n = pure (fromRational n)--instance A.Floating b => P.Floating (Fold a (Exp b)) where-  pi      = pure pi-  sin     = fmap sin-  cos     = fmap cos-  tan     = fmap tan-  asin    = fmap asin-  acos    = fmap acos-  atan    = fmap atan-  sinh    = fmap sinh-  cosh    = fmap cosh-  tanh    = fmap tanh-  asinh   = fmap asinh-  acosh   = fmap acosh-  atanh   = fmap atanh-  exp     = fmap exp-  sqrt    = fmap sqrt-  log     = fmap log-  (**)    = liftA2 (**)-  logBase = liftA2 logBase-
− Data/Array/Accelerate/Data/Monoid.hs 
@@ -1,172 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.Data.Monoid--- Copyright   : [2016..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Monoid instances for Accelerate-----module Data.Array.Accelerate.Data.Monoid (--  Monoid(..), (<>),--  Sum(..),-  Product(..),--) where--import Data.Array.Accelerate                                        as A-import Data.Array.Accelerate.Type                                   as A-import Data.Array.Accelerate.Smart                                  as A ( Exp(..), PreExp(..) )-import Data.Array.Accelerate.Product                                as A-import Data.Array.Accelerate.Array.Sugar                            as A--import Data.Function-import Data.Monoid                                                  hiding ( mconcat )-import qualified Prelude                                            as P----- Sum: Monoid under addition--- ----------------------------type instance EltRepr (Sum a) = ((), EltRepr a)--instance Elt a => Elt (Sum a) where-  eltType _       = PairTuple UnitTuple (eltType (undefined::a))-  toElt ((),x)    = Sum (toElt x)-  fromElt (Sum x) = ((), fromElt x)--instance Elt a => IsProduct Elt (Sum a) where-  type ProdRepr (Sum a) = ((), a)-  toProd _ ((),a)    = Sum a-  fromProd _ (Sum a) = ((),a)-  prod _ _           = ProdRsnoc ProdRunit--instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Sum a) where-  type Plain (Sum a) = Sum (Plain a)-  lift (Sum a)       = Exp $ Tuple $ NilTup `SnocTup` lift a--instance Elt a => Unlift Exp (Sum (Exp a)) where-  unlift t = Sum . Exp $ ZeroTupIdx `Prj` t--instance A.Num a => Monoid (Exp (Sum a)) where-  mempty  = 0-  mappend = lift2 (mappend :: Sum (Exp a) -> Sum (Exp a) -> Sum (Exp a))--instance A.Num a => P.Num (Exp (Sum a)) where-  (+)             = lift2 ((+) :: Sum (Exp a) -> Sum (Exp a) -> Sum (Exp a))-  (-)             = lift2 ((-) :: Sum (Exp a) -> Sum (Exp a) -> Sum (Exp a))-  (*)             = lift2 ((*) :: Sum (Exp a) -> Sum (Exp a) -> Sum (Exp a))-  negate          = lift1 (negate :: Sum (Exp a) -> Sum (Exp a))-  signum          = lift1 (signum :: Sum (Exp a) -> Sum (Exp a))-  abs             = lift1 (signum :: Sum (Exp a) -> Sum (Exp a))-  fromInteger x   = lift (P.fromInteger x :: Sum (Exp a))--instance A.Eq a => A.Eq (Sum a) where-  (==) = lift2 ((==) `on` getSum)-  (/=) = lift2 ((/=) `on` getSum)--instance A.Ord a => A.Ord (Sum a) where-  (<)     = lift2 ((<) `on` getSum)-  (>)     = lift2 ((>) `on` getSum)-  (<=)    = lift2 ((<=) `on` getSum)-  (>=)    = lift2 ((>=) `on` getSum)-  min x y = lift . Sum $ lift2 (min `on` getSum) x y-  max x y = lift . Sum $ lift2 (max `on` getSum) x y----- Product: Monoid under multiplication--- --------------------------------------type instance EltRepr (Product a) = ((), EltRepr a)--instance Elt a => Elt (Product a) where-  eltType _       = PairTuple UnitTuple (eltType (undefined::a))-  toElt ((),x)    = Product (toElt x)-  fromElt (Product x) = ((), fromElt x)--instance Elt a => IsProduct Elt (Product a) where-  type ProdRepr (Product a) = ((), a)-  toProd _ ((),a)        = Product a-  fromProd _ (Product a) = ((),a)-  prod _ _               = ProdRsnoc ProdRunit--instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Product a) where-  type Plain (Product a) = Product (Plain a)-  lift (Product a)       = Exp $ Tuple $ NilTup `SnocTup` lift a--instance Elt a => Unlift Exp (Product (Exp a)) where-  unlift t = Product . Exp $ ZeroTupIdx `Prj` t--instance A.Num a => Monoid (Exp (Product a)) where-  mempty  = 1-  mappend = lift2 (mappend :: Product (Exp a) -> Product (Exp a) -> Product (Exp a))--instance A.Num a => P.Num (Exp (Product a)) where-  (+)             = lift2 ((+) :: Product (Exp a) -> Product (Exp a) -> Product (Exp a))-  (-)             = lift2 ((-) :: Product (Exp a) -> Product (Exp a) -> Product (Exp a))-  (*)             = lift2 ((*) :: Product (Exp a) -> Product (Exp a) -> Product (Exp a))-  negate          = lift1 (negate :: Product (Exp a) -> Product (Exp a))-  signum          = lift1 (signum :: Product (Exp a) -> Product (Exp a))-  abs             = lift1 (signum :: Product (Exp a) -> Product (Exp a))-  fromInteger x   = lift (P.fromInteger x :: Product (Exp a))--instance A.Eq a => A.Eq (Product a) where-  (==) = lift2 ((==) `on` getProduct)-  (/=) = lift2 ((/=) `on` getProduct)--instance A.Ord a => A.Ord (Product a) where-  (<)     = lift2 ((<) `on` getProduct)-  (>)     = lift2 ((>) `on` getProduct)-  (<=)    = lift2 ((<=) `on` getProduct)-  (>=)    = lift2 ((>=) `on` getProduct)-  min x y = lift . Product $ lift2 (min `on` getProduct) x y-  max x y = lift . Product $ lift2 (max `on` getProduct) x y----- Instances for unit and tuples--- -------------------------------instance Monoid (Exp ()) where-  mempty      = constant ()-  mappend _ _ = constant ()--instance (Elt a, Elt b, Monoid (Exp a), Monoid (Exp b)) => Monoid (Exp (a,b)) where-  mempty      = lift (mempty :: Exp a, mempty :: Exp b)-  mappend x y = let (a1,b1) = unlift x  :: (Exp a, Exp b)-                    (a2,b2) = unlift y-                in-                lift (a1<>a2, b1<>b2)--instance (Elt a, Elt b, Elt c, Monoid (Exp a), Monoid (Exp b), Monoid (Exp c)) => Monoid (Exp (a,b,c)) where-  mempty      = lift (mempty :: Exp a, mempty :: Exp b, mempty :: Exp c)-  mappend x y = let (a1,b1,c1) = unlift x  :: (Exp a, Exp b, Exp c)-                    (a2,b2,c2) = unlift y-                in-                lift (a1<>a2, b1<>b2, c1<>c2)--instance (Elt a, Elt b, Elt c, Elt d, Monoid (Exp a), Monoid (Exp b), Monoid (Exp c), Monoid (Exp d)) => Monoid (Exp (a,b,c,d)) where-  mempty      = lift (mempty :: Exp a, mempty :: Exp b, mempty :: Exp c, mempty :: Exp d)-  mappend x y = let (a1,b1,c1,d1) = unlift x  :: (Exp a, Exp b, Exp c, Exp d)-                    (a2,b2,c2,d2) = unlift y-                in-                lift (a1<>a2, b1<>b2, c1<>c2, d1<>d2)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Monoid (Exp a), Monoid (Exp b), Monoid (Exp c), Monoid (Exp d), Monoid (Exp e)) => Monoid (Exp (a,b,c,d,e)) where-  mempty      = lift (mempty :: Exp a, mempty :: Exp b, mempty :: Exp c, mempty :: Exp d, mempty :: Exp e)-  mappend x y = let (a1,b1,c1,d1,e1) = unlift x  :: (Exp a, Exp b, Exp c, Exp d, Exp e)-                    (a2,b2,c2,d2,e2) = unlift y-                in-                lift (a1<>a2, b1<>b2, c1<>c2, d1<>d2, e1<>e2)-
− Data/Array/Accelerate/Debug.hs 
@@ -1,120 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Debug--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Embedded array processing language: debugging support (internal). This module--- provides functionality that is useful for developers of the library. It is--- not meant for library users.-----module Data.Array.Accelerate.Debug (--  module Debug,--  dumpGraph,-  dumpSimplStats,--  monitoringIsEnabled,-  debuggingIsEnabled,--) where--import Data.Array.Accelerate.Debug.Flags                as Debug-import Data.Array.Accelerate.Debug.Monitoring           as Debug-import Data.Array.Accelerate.Debug.Stats                as Debug-import Data.Array.Accelerate.Debug.Timed                as Debug-import Data.Array.Accelerate.Debug.Trace                as Debug--import Data.Array.Accelerate.Pretty.Graphviz--import Control.Monad.Trans                              ( MonadIO )--#if ACCELERATE_DEBUG-import Control.Exception                                ( bracket )-import Control.Monad.Trans                              ( liftIO )-import System.Directory                                 ( getTemporaryDirectory, createDirectoryIfMissing )-import System.FilePath                                  ( (</>) )-import System.IO                                        ( Handle, openTempFile, hPutStrLn, hPrint, hClose, stderr )--#if   defined(UNIX)-import System.Posix.Process                             ( getProcessID )-#elif defined(WIN32)-import System.Win32.Process                             ( ProcessId )-#else-#error "I don't know what operating system I am"-#endif-#endif---debuggingIsEnabled :: Bool-#if ACCELERATE_DEBUG-debuggingIsEnabled = True-#else-debuggingIsEnabled = False-#endif--monitoringIsEnabled :: Bool-#if ACCELERATE_MONITORING-monitoringIsEnabled = True-#else-monitoringIsEnabled = False-#endif----- | Display simplifier statistics. The counts are reset afterwards.----{-# INLINEABLE dumpSimplStats #-}-dumpSimplStats :: MonadIO m => m ()-#if ACCELERATE_DEBUG-dumpSimplStats = do-  liftIO $ Debug.when dump_simpl_stats $ do-    stats <- simplCount-    putTraceMsg (show stats)-    resetSimplCount-#else-dumpSimplStats = return ()-#endif----- | Write a representation of the given input (a closed array expression or--- function) to file in Graphviz dot format in the temporary directory.----{-# INLINEABLE dumpGraph #-}-dumpGraph :: (MonadIO m, PrettyGraph g) => g -> m ()-#if ACCELERATE_DEBUG-dumpGraph g =-  liftIO $ do-    Debug.when dump_dot       $ writeGraph Full   g-    Debug.when dump_simpl_dot $ writeGraph Simple g-#else-dumpGraph _ = return ()-#endif--#if ACCELERATE_DEBUG-writeGraph :: PrettyGraph g => Detail -> g -> IO ()-writeGraph simple g = do-  withTemporaryFile "acc.dot" $ \path hdl -> do-    hPrint hdl (ppGraph simple g)-    hPutStrLn stderr ("program graph: " ++ path)--withTemporaryFile :: String -> (FilePath -> Handle -> IO a) -> IO a-withTemporaryFile template go = do-  pid <- getProcessID-  tmp <- getTemporaryDirectory-  let dir = tmp </> "accelerate-" ++ show pid-  createDirectoryIfMissing True dir-  bracket (openTempFile dir template) (hClose . snd) (uncurry go)--#ifdef WIN32-getProcessID :: IO ProcessId-getProcessID = return 0xaaaa-#endif-#endif
− Data/Array/Accelerate/Debug/Flags.hs 
@@ -1,343 +0,0 @@-{-# LANGUAGE CPP                      #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE TemplateHaskell          #-}-{-# LANGUAGE TypeOperators            #-}-#ifdef ACCELERATE_DEBUG-#if __GLASGOW_HASKELL >= 800-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-#endif-#else-{-# OPTIONS_GHC -fno-warn-unused-binds   #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-#endif--- |--- Module      : Data.Array.Accelerate.Debug.Flags--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Option parsing for debug flags-----module Data.Array.Accelerate.Debug.Flags (--  Flags, Mode,-  acc_sharing, exp_sharing, fusion, simplify, flush_cache, force_recomp, fast_math, verbose,-  dump_phases, dump_sharing, dump_simpl_stats, dump_simpl_iterations, dump_vectorisation,-  dump_dot, dump_simpl_dot, dump_gc, dump_gc_stats, debug_cc, dump_cc, dump_ld, dump_asm,-  dump_exec, dump_sched,--  accInit,-  queryFlag, setFlag, setFlag', setFlags, clearFlag, clearFlags,-  when, unless,--) where--import Control.Monad.IO.Class-import Data.IORef-import Data.Label-import Data.Label.Derive-import Data.List-import System.Environment-import System.IO.Unsafe-import Text.PrettyPrint.ANSI.Leijen-import qualified Control.Monad                                      as M ( when, unless )--import Foreign.C-import Foreign.Marshal-import Foreign.Ptr-import GHC.Foreign                                                  as GHC-import GHC.IO.Encoding                                              ( getFileSystemEncoding )--import Debug.Trace---data FlagSpec flag = Option String              -- external form-                            flag                -- internal form--data OptKind f-    = NoArg f-    | IntArg (Int -> f)----- The runtime debug and control options supported by Accelerate. This is a bit--- awkward, as we process both frontend as well as backend option flags, but--- gives some control over error messages and overlapping options.----data Flags = Flags-  {-    -- Functionality and phase control-    -- --------------------------------    ---    -- These are Maybe types because they will only override the backend-    -- options if the user specifies a value-    ---    _acc_sharing              :: !(Maybe Bool)        -- recover sharing of array computations-  , _exp_sharing              :: !(Maybe Bool)        -- recover sharing of scalar expressions-  , _fusion                   :: !(Maybe Bool)        -- fuse array expressions-  , _simplify                 :: !(Maybe Bool)        -- simplify scalar expressions-  , _unfolding_use_threshold  :: !(Maybe Int)         -- the magic cut-off figure for inlining-  , _flush_cache              :: !(Maybe Bool)        -- delete persistent compilation cache(s)-  , _force_recomp             :: !(Maybe Bool)        -- force recompilation of array programs-  , _fast_math                :: !(Maybe Bool)        -- use faster, less precise math library operations--    -- Debug trace-    -- ------------  , _verbose                  :: !Bool                -- be very chatty--    -- optimisation and simplification-  , _dump_phases              :: !Bool                -- print information about each phase of the compiler-  , _dump_sharing             :: !Bool                -- sharing recovery phase-  , _dump_simpl_stats         :: !Bool                -- statistics form fusion/simplification-  , _dump_simpl_iterations    :: !Bool                -- output from each simplifier iteration-  , _dump_vectorisation       :: !Bool                -- output from the vectoriser-  , _dump_dot                 :: !Bool                -- generate dot output of the program-  , _dump_simpl_dot           :: !Bool                -- generate simplified dot output--    -- garbage collection-  , _dump_gc                  :: !Bool                -- trace garbage collector-  , _dump_gc_stats            :: !Bool                -- print final GC statistics--    -- code generation / compilation-  , _debug_cc                 :: !Bool                -- compile with debug symbols-  , _dump_cc                  :: !Bool                -- trace code generation & compilation-  , _dump_ld                  :: !Bool                -- trace runtime linker-  , _dump_asm                 :: !Bool                -- trace assembler--    -- execution-  , _dump_exec                :: !Bool                -- trace execution-  , _dump_sched               :: !Bool                -- trace scheduler-  }---- Generate labels with INLINE pragmas-$(mkLabelsWith defaultNaming True False False True ''Flags)---allFlags :: [FlagSpec (OptKind (Flags -> Flags))]-allFlags-  =  map (enableB 'd') dflags-  ++ map (enableB 'f') fflagsB ++ map (disableB 'f') fflagsB-  ++ map (enableI 'f') fflagsI-  where-    enableI  p (Option f go) = Option ('-':p:f)        (IntArg go)-    enableB  p (Option f go) = Option ('-':p:f)        (NoArg (go True))-    disableB p (Option f go) = Option ('-':p:"no-"++f) (NoArg (go False))----- These @-f\<blah\>@ phase control flags can be reversed with @-fno-\<blah\>@----fflagsB :: [FlagSpec (Bool -> Flags -> Flags)]-fflagsB =-  [ Option "acc-sharing"                (set' acc_sharing)-  , Option "exp-sharing"                (set' exp_sharing)-  , Option "fusion"                     (set' fusion)-  , Option "simplify"                   (set' simplify)-  , Option "flush-cache"                (set' flush_cache)-  , Option "force-recomp"               (set' force_recomp)-  , Option "fast-math"                  (set' fast_math)-  ]-  where-    set' f v = set f (Just v)---- These @-f\<blah\>@ flags require an integer argument----fflagsI :: [FlagSpec (Int -> Flags -> Flags)]-fflagsI =-  [ Option "unfolding-use-threshold"    (set' unfolding_use_threshold)-  ]-  where-    set' f v = set f (Just v)---- These debugging flags default to off and can be enable with @-d\<blah\>@----dflags :: [FlagSpec (Bool -> Flags -> Flags)]-dflags =-  [ Option "verbose"                    (set verbose)-  , Option "dump-phases"                (set dump_phases)-  , Option "dump-sharing"               (set dump_sharing)-  , Option "dump-simpl-stats"           (set dump_simpl_stats)-  , Option "dump-simpl-iterations"      (set dump_simpl_iterations)-  , Option "dump-vectorisation"         (set dump_vectorisation)-  , Option "dump-dot"                   (set dump_dot)-  , Option "dump-simpl-dot"             (set dump_simpl_dot)-  , Option "dump-gc"                    (set dump_gc)-  , Option "dump-gc-stats"              (set dump_gc_stats)-  , Option "debug-cc"                   (set debug_cc)-  , Option "dump-cc"                    (set dump_cc)-  , Option "dump-ld"                    (set dump_ld)-  , Option "dump-asm"                   (set dump_asm)-  , Option "dump-exec"                  (set dump_exec)-  , Option "dump-sched"                 (set dump_sched)-  ]---class DebugFlag a where-  def :: a--instance DebugFlag Bool where-  {-# INLINE def #-}-  def = False--instance DebugFlag (Maybe a) where-  {-# INLINE def #-}-  def = Nothing----- | A bit of a hack to get the command line options processing out of the way.------ We would like to have this automatically called once during program--- initialisation, so that our command-line debug flags between +ACC .. [-ACC]--- don't interfere with other programs.------ Hacks beget hacks beget hacks...----accInit :: IO ()-#ifdef ACCELERATE_DEBUG-accInit = _flags `seq` return ()-#else-accInit = getUpdateArgs >> return ()-#endif---- Initialise the debugging flags structure. This reads from both the command--- line arguments as well as the environment variable "ACCELERATE_FLAGS".--- Where applicable, options on the command line take precedence.------ This is only available when compiled with debugging mode, because trying to--- access it at any other time is an error.----#ifdef ACCELERATE_DEBUG-initialiseFlags :: IO Flags-initialiseFlags = do-  argv  <- getUpdateArgs-  env   <- maybe [] words `fmap` lookupEnv "ACCELERATE_FLAGS"-  return $ parse (env ++ argv)-  where-    defaults :: Flags-    defaults = Flags def def def def def def def def def def def def def def def def def def def def def def def def--    parse :: [String] -> Flags-    parse = foldl parse1 defaults--    parse1 :: Flags -> String -> Flags-    parse1 opts this =-      case filter (\(Option flag _) -> prefix `isPrefixOf` flag) allFlags of-        [Option _ f]    -> apply f-        []              -> trace unknown opts-        alts            -> case find (\(Option flag _) -> flag == prefix) alts of-                             Just (Option _ f)  -> apply f-                             Nothing            -> trace (ambiguous alts) opts-      where-        apply :: OptKind (Flags -> Flags) -> Flags-        apply (NoArg f)   = f opts-        apply (IntArg f)  = f (read suffix) opts--        (prefix,rest)   = break (== '=') this-        suffix          = if null rest then [] else tail rest--        unknown         = show $ text "Unknown option:" <+> squotes (text this)-        ambiguous alts  = show $-          vcat [ text "Ambiguous option:" <+> squotes (text this)-               , text ""-               , text "Did you mean one of these?"-               , nest 4 $ vcat (map (\(Option s _) -> text s) alts)-               ]-#endif----- If the command line arguments include a section "+ACC ... [-ACC]" then return--- that section, and update the command line arguments to not include that part.----getUpdateArgs :: IO [String]-getUpdateArgs = do-  argv <- getArgs-  ---  let (before, r1)      = span (/= "+ACC") argv-      (flags,  r2)      = span (/= "-ACC") $ dropWhile (== "+ACC") r1-      after             = dropWhile (== "-ACC") r2-  ---#ifdef ACCELERATE_DEBUG-  prog <- getProgName-  setProgArgv (prog : before ++ after)-#else-  M.unless (null flags)-    $ error "Data.Array.Accelerate: Debugging options are disabled. Reinstall package 'accelerate' with '-fdebug' to enable them."-#endif-  return flags----- This is only defined in debug mode because to access it at any other time--- should be an error.----#ifdef ACCELERATE_DEBUG-{-# NOINLINE _flags #-}-_flags :: IORef Flags-_flags = unsafePerformIO $ newIORef =<< initialiseFlags-#endif--{-# INLINE queryFlag #-}-queryFlag :: DebugFlag a => (Flags :-> a) -> IO a-#ifdef ACCELERATE_DEBUG-queryFlag f = get f `fmap` readIORef _flags-#else-queryFlag _ = return def-#endif---type Mode = Flags :-> Bool--setFlag, clearFlag :: Mode -> IO ()-setFlag f   = setFlags [f]-clearFlag f = clearFlags [f]--setFlag' :: (Flags :-> a) -> a -> IO ()-#ifdef ACCELERATE_DEBUG-setFlag' f v = modifyIORef _flags (set f v)-#else-setFlag' _ _ = return ()-#endif--setFlags, clearFlags :: [Mode] -> IO ()-#ifdef ACCELERATE_DEBUG-setFlags f   = modifyIORef _flags (\opt -> foldr (flip set True)  opt f)-clearFlags f = modifyIORef _flags (\opt -> foldr (flip set False) opt f)-#else-setFlags _   = return ()-clearFlags _ = return ()-#endif----- | Conditional execution of a monadic debugging expression----{-# INLINEABLE when #-}-when :: MonadIO m => Mode -> m () -> m ()-when f s = do-  yes <- liftIO $ queryFlag f-  M.when yes s---- | The opposite of 'when'----{-# INLINEABLE unless #-}-unless :: MonadIO m => Mode -> m () -> m ()-unless f s = do-  yes <- liftIO $ queryFlag f-  M.unless yes s---#ifdef ACCELERATE_DEBUG--- Stolen from System.Environment----setProgArgv :: [String] -> IO ()-setProgArgv argv = do-  enc <- getFileSystemEncoding-  vs  <- mapM (GHC.newCString enc) argv >>= newArray0 nullPtr-  c_setProgArgv (genericLength argv) vs--foreign import ccall unsafe "setProgArgv"-  c_setProgArgv  :: CInt -> Ptr CString -> IO ()-#endif-
− Data/Array/Accelerate/Debug/Monitoring.hs 
@@ -1,459 +0,0 @@-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Debug.Monitoring--- Copyright   : [2016..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.Debug.Monitoring (--  beginMonitoring,-  initAccMetrics,--  -- Load monitoring-  Processor(..),-  withProcessor, addProcessorTime,--  -- GC subsystem monitoring-  didAllocateBytesLocal, didAllocateBytesRemote,-  didCopyBytesToRemote, didCopyBytesFromRemote,-  increaseCurrentBytesRemote, decreaseCurrentBytesRemote,-  setCurrentBytesNursery,-  didRemoteGC,-  didEvictBytes,--) where--#ifdef ACCELERATE_MONITORING-import Data.Atomic                                                  ( Atomic )-import qualified Data.Atomic                                        as Atomic--import System.Metrics-import System.Metrics.Counter                                       ( Counter )-import System.Metrics.Gauge                                         ( Gauge )-import qualified System.Metrics.Counter                             as Counter-import qualified System.Metrics.Gauge                               as Gauge--import Control.Concurrent-import Control.Concurrent.Async-import Control.Monad-import Data.IORef-import Data.Text                                                    ( Text )-import Data.Time.Clock-import System.IO.Unsafe-import System.Remote.Monitoring-import Text.Printf-import qualified Data.HashMap.Strict                                as Map-#endif--import Data.Int-import Prelude----- | Launch a monitoring server that will collect statistics on the running--- application. This should be called as soon as the application starts. The--- program will need to be run with the RTS option -T.----beginMonitoring :: IO ()-#ifdef ACCELERATE_MONITORING-beginMonitoring = do-  store <- initAccMetrics-  registerGcMetrics store-  r     <- withAsync (forkServerWith store "localhost" 8000 >> threadDelay 10000) waitCatch-  case r of-    Right _ -> printf "EKG monitor started at: http://localhost:8000\n"-    Left _  -> printf "Failed to start EKG monitor\n"-#else-beginMonitoring = return ()-#endif----- | Initialise and return the Accelerate monitoring store. To enable monitoring--- of your application:------ > import Data.Array.Accelerate.Debug--- >--- > import System.Metrics--- > import System.Remote.Monitoring--- >--- > main :: IO ()--- > main = do--- >   store  <- initAccMetrics--- >   registerGcMetrics store      -- optional--- >--- >   server <- forkServerWith store "localhost" 8000--- >--- >   ...------ Note that aside from the processor load metrics, counters are shared between--- all active backends.------ Registered rates:------ [@acc.load.llvm_native@] Current processor load (%) of the LLVM CPU backend.--- This only includes time spent executing Accelerate functions; compare this to--- the total processor load (e.g. via top) to estimate the productivity of the--- Accelerate program.------ [@acc.load.llvm_ptx@] Current processor load (%) of the GPU in the LLVM PTX--- backend. This only takes into account how much time the GPU spent executing--- Accelerate code, and does not consider the number of active cores during that--- time.------ Registered gauges:------ [@acc.gc.current_bytes_remote@] Total number of bytes currently considered--- live in the remote address space.------ [@acc.gc.current_bytes_nursery@] Total number of bytes allocated in the--- remote address space but not currently live (available for reallocation).------ Registered counters:------ [@acc.gc.bytes_allocated_local@] Total number of bytes allocated in the local--- address space.------ [@acc.gc.bytes_allocated_remote@] Total number of bytes allocated in the--- remote address space.------ [@acc.gc.bytes_copied_to_remote@] Total number of bytes copied from the host--- to the remote address space (e.g. from the CPU to the GPU).------ [@acc.gc.bytes_copied_from_remote@] Total number of bytes copied from the--- remote address space back to the host (e.g. from the GPU back to the CPU).------ [@acc.gc.bytes_evicted_from_remote@] Total number of bytes evicted from the--- remote address space by the LRU memory manager, in order to make space for--- new allocations. A subset of __acc.gc.bytes_copied_from_remote__.------ [@acc.gc.num_gcs@] Number of garbage collections of the remote address space--- performed.------ [@acc.gc.num_lru_evict@] Total number of evictions from the remote address--- space performed.----#ifndef ACCELERATE_MONITORING-initAccMetrics :: IO a-initAccMetrics = error "Data.Array.Accelerate: Monitoring is disabled. Reinstall package 'accelerate' with '-fekg' to enable it."-#else-initAccMetrics :: IO Store-initAccMetrics = do-  store <- newStore--  registerRate    "acc.load.llvm_native"              (estimateProcessorLoad _active_ns_llvm_native)           store-  registerRate    "acc.load.llvm_ptx"                 (estimateProcessorLoad _active_ns_llvm_ptx)              store-  registerGauge   "acc.gc.current_bytes_remote"       (Gauge.read _current_bytes_remote)                       store-  registerGauge   "acc.gc.current_bytes_nursery"      (Gauge.read _current_bytes_nursery)                      store-  registerCounter "acc.gc.bytes_allocated_local"      (Counter.read _total_bytes_allocated_local)              store-  registerCounter "acc.gc.bytes_allocated_remote"     (Counter.read _total_bytes_allocated_remote)             store-  registerCounter "acc.gc.bytes_copied_to_remote"     (Counter.read _total_bytes_copied_to_remote)             store-  registerCounter "acc.gc.bytes_copied_from_remote"   (Counter.read _total_bytes_copied_from_remote)           store-  registerCounter "acc.gc.bytes_evicted_from_remote"  (Counter.read _total_bytes_evicted_from_remote)          store-  registerCounter "acc.gc.num_gcs"                    (Counter.read _num_remote_gcs)                           store-  registerCounter "acc.gc.num_lru_evict"              (Counter.read _num_evictions)                            store--  return store----- Abusing 'registerGroup' to perform the rate calculation on every wake-up.----registerRate :: Text -> (IORef EMAState -> IO Int64) -> Store -> IO ()-registerRate name sample store = do-  now <- getCurrentTime-  st  <- newIORef (ES now 0 0)-  registerGroup (Map.singleton name Gauge) (sample st) store-#endif----- Recording metrics--- -------------------data Processor = Native | PTX---- | Execute the given action and assign the elapsed wall-clock time as active--- time for the given processing element.----{-# INLINE withProcessor #-}-withProcessor :: Processor -> IO a -> IO a-#ifndef ACCELERATE_MONITORING-withProcessor _      = id-#else-withProcessor Native = withProcessor' _active_ns_llvm_native-withProcessor PTX    = withProcessor' _active_ns_llvm_ptx--withProcessor' :: Atomic -> IO a -> IO a-withProcessor' var action = do-  wall0 <- getCurrentTime-  !r    <- action-  wall1 <- getCurrentTime-  addProcessorTime' var (realToFrac (diffUTCTime wall1 wall0))-  return r-#endif---- | Record the given number of seconds as active processing time for the given--- processing element.----{-# INLINE addProcessorTime #-}-addProcessorTime :: Processor -> Double -> IO ()-#ifndef ACCELERATE_MONITORING-addProcessorTime _ _    = return ()-#else-addProcessorTime Native = addProcessorTime' _active_ns_llvm_native-addProcessorTime PTX    = addProcessorTime' _active_ns_llvm_ptx--addProcessorTime' :: Atomic -> Double -> IO ()-addProcessorTime' var secs =-  let ns   = round (secs * 1.0E9)-  in  void $ Atomic.add var ns-#endif----- | Allocated the number of bytes in the local memory space----didAllocateBytesLocal :: Int64 -> IO ()-#ifndef ACCELERATE_MONITORING-didAllocateBytesLocal _ = return ()-#else-didAllocateBytesLocal n = do-  -- void $ Atomic.add _active_bytes_allocated_local n-  Counter.add _total_bytes_allocated_local n-#endif---- | Allocated the number of bytes of /new/ memory in the remote memory space----didAllocateBytesRemote :: Int64 -> IO ()-#ifndef ACCELERATE_MONITORING-didAllocateBytesRemote _ = return ()-#else-didAllocateBytesRemote n = do- -- void $ Atomic.add _active_bytes_allocated_remote n- Counter.add _total_bytes_allocated_remote n-#endif--{-# INLINE increaseCurrentBytesRemote #-}-increaseCurrentBytesRemote :: Int64 -> IO ()-#ifndef ACCELERATE_MONITORING-increaseCurrentBytesRemote _ = return ()-#else-increaseCurrentBytesRemote n = Gauge.add _current_bytes_remote n-#endif--{-# INLINE decreaseCurrentBytesRemote #-}-decreaseCurrentBytesRemote :: Int64 -> IO ()-#ifndef ACCELERATE_MONITORING-decreaseCurrentBytesRemote _ = return ()-#else-decreaseCurrentBytesRemote n = Gauge.subtract _current_bytes_remote n-#endif---- | Copied data between the local and remote memory spaces----didCopyBytesToRemote :: Int64 -> IO ()-#ifndef ACCELERATE_MONITORING-didCopyBytesToRemote _ = return ()-#else-didCopyBytesToRemote n = Counter.add _total_bytes_copied_to_remote n-#endif--didCopyBytesFromRemote :: Int64 -> IO ()-#ifndef ACCELERATE_MONITORING-didCopyBytesFromRemote _ = return ()-#else-didCopyBytesFromRemote n = Counter.add _total_bytes_copied_from_remote n-#endif----- TLM: This is required for the 'cleanup' function (which deletes everything--- from the nursery) and is somewhat useful for the add/remove functions, since--- we keep track of the size anyway, but we do lose track of the number of--- allocations/deletions to/from the nursery.----{-# INLINE setCurrentBytesNursery #-}-setCurrentBytesNursery :: Int64 -> IO ()-#ifndef ACCELERATE_MONITORING-setCurrentBytesNursery _ = return ()-#else-setCurrentBytesNursery n = Gauge.set _current_bytes_nursery n-#endif----- | Performed a major GC of the remote memory space----didRemoteGC :: IO ()-#ifndef ACCELERATE_MONITORING-didRemoteGC = return ()-#else-didRemoteGC = Counter.inc _num_remote_gcs-#endif---- | Performed an eviction of a remote array of the given number of bytes----didEvictBytes :: Int64 -> IO ()-#ifndef ACCELERATE_MONITORING-didEvictBytes _ = return ()-#else-didEvictBytes n = do-  Counter.inc _num_evictions-  Counter.add _total_bytes_evicted_from_remote n-#endif----- Implementation--- ----------------#ifdef ACCELERATE_MONITORING---- In order to calculate the processor load we need to remember the previous--- values. Storing this state in an IORef has a bit of extra overhead (as--- indirection) compared to the rest of the monitoring counters (which are--- unboxed values on the heap manipulated directly with atomic primops), but--- since 'calculateProcessorLoad' will only be called by the EKG monitor--- whenever it refreshes the value for display, rather than running continuously--- in the background, we should be okay.----data EMAState = ES-  { old_time  :: {-# UNPACK #-} !UTCTime-  , old_inst  :: {-# UNPACK #-} !Double-  , old_avg   :: {-# UNPACK #-} !Double-  }---- Estimate the load on the processor as a moving exponential average--- (weight of previous measurement = 0.2).----estimateProcessorLoad :: Atomic -> IORef EMAState -> IO Int64-estimateProcessorLoad !var !ref = do-  ES{..} <- readIORef ref-  time   <- getCurrentTime-  sample <- Atomic.and var 0-  ---  let-      active_ns   = fromIntegral sample-      elapsed_s   = realToFrac (diffUTCTime time old_time)-      elapsed_ns  = 1.0E9 * elapsed_s-      ---      new_inst    = 100 * (active_ns / elapsed_ns)                -- instantaneous load-      new_avg     = ema 0.2 elapsed_s old_avg old_inst new_inst   -- moving average load-  ---  writeIORef ref (ES time new_inst new_avg)-  return (round new_avg)---{----- Compute the current load on a processor as a percentage of time spent working--- over the elapsed time. This is meant to run continuously by a background--- thread, updating the gauge each time it wakes up.----monitorProcessorLoad :: Gauge -> Atomic -> UTCTime -> Double -> Double -> IO ()-monitorProcessorLoad !gauge !var !old_time !old_inst !old_avg = do-  time   <- getCurrentTime-  sample <- Atomic.and var 0--  let-      active_ns   = fromIntegral sample-      elapsed_s   = realToFrac (diffUTCTime time old_time)-      elapsed_ns  = 1.0E9 * elapsed_s--      load_inst   = 100 * (active_ns / elapsed_ns)                -- instantaneous load-      load_avg    = ema 0.2 elapsed_s old_avg old_inst load_inst  -- moving average load--  -- Set what we thing the processor load over the previous interval should be-  Gauge.set gauge (round load_avg)--  -- Sleep for a bit, then do it all again-  threadDelay 500000    -- 500 ms-  monitorProcessorLoad gauge var time load_inst load_avg---}---- Exponential moving average for irregular time series----ema :: Double -> Double -> Double -> Double -> Double -> Double-ema !alpha !dt !old_ema !old_sample !new_sample =-  let-      a = dt / alpha-      u = exp ( -a )-      v = ( 1 - u ) / a-  in-  (u * old_ema) + ((v-u) * old_sample) + ((1-v) * new_sample)----- Monitoring variables--- ------------------------ Number of nanoseconds a backend has spent doing real work since the last--- check. This is an integer amount because there are no built-in functions for--- atomic memory access on double precision (as specified by the Intel docs).----{-# NOINLINE _active_ns_llvm_native #-}-_active_ns_llvm_native :: Atomic-_active_ns_llvm_native = unsafePerformIO (Atomic.new 0)--{-# NOINLINE _active_ns_llvm_ptx #-}-_active_ns_llvm_ptx :: Atomic-_active_ns_llvm_ptx = unsafePerformIO (Atomic.new 0)--{-# NOINLINE _active_ns_cuda #-}-_active_ns_cuda :: Atomic-_active_ns_cuda = unsafePerformIO (Atomic.new 0)---- Total number of bytes allocated in the local and remote (e.g. on the GPU)--- address spaces----{-# NOINLINE _total_bytes_allocated_local #-}-_total_bytes_allocated_local :: Counter-_total_bytes_allocated_local = unsafePerformIO Counter.new--{-# NOINLINE _total_bytes_allocated_remote #-}-_total_bytes_allocated_remote :: Counter-_total_bytes_allocated_remote = unsafePerformIO Counter.new---- Total number of bytes copied to and from the remote memory space----{-# NOINLINE _total_bytes_copied_to_remote #-}-_total_bytes_copied_to_remote :: Counter-_total_bytes_copied_to_remote = unsafePerformIO Counter.new--{-# NOINLINE _total_bytes_copied_from_remote #-}-_total_bytes_copied_from_remote :: Counter-_total_bytes_copied_from_remote = unsafePerformIO Counter.new---- Total number of bytes copied out of the remote memory space due to evictions.----{-# NOINLINE _total_bytes_evicted_from_remote #-}-_total_bytes_evicted_from_remote :: Counter-_total_bytes_evicted_from_remote = unsafePerformIO Counter.new---- Current working remote memory size----{-# NOINLINE _current_bytes_remote #-}-_current_bytes_remote :: Gauge-_current_bytes_remote = unsafePerformIO Gauge.new---- Current size of the nursery----{-# NOINLINE _current_bytes_nursery #-}-_current_bytes_nursery :: Gauge-_current_bytes_nursery = unsafePerformIO Gauge.new---- Number of times the remote memory was forcibly garbage collected, and nursery--- flushed.----{-# NOINLINE _num_remote_gcs #-}-_num_remote_gcs :: Counter-_num_remote_gcs = unsafePerformIO Counter.new---- number of LRU eviction events----{-# NOINLINE _num_evictions #-}-_num_evictions :: Counter-_num_evictions = unsafePerformIO Counter.new--#endif-
− Data/Array/Accelerate/Debug/Stats.hs 
@@ -1,210 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-unused-binds   #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}--- |--- Module      : Data.Array.Accelerate.Debug.Simpl--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Tick-count statistics collection of the compiler passes, for debugging--- purposes.-----module Data.Array.Accelerate.Debug.Stats (--  simplCount, resetSimplCount,-  inline, ruleFired, knownBranch, betaReduce, substitution, simplifierDone, fusionDone,--) where--import Data.Array.Accelerate.Debug.Flags--import Data.Function                            ( on )-import Data.IORef-import Data.List                                ( groupBy, sortBy )-import Data.Ord                                 ( comparing )-import Data.Map                                 ( Map )-import Text.PrettyPrint.ANSI.Leijen-import System.IO.Unsafe--import qualified Data.Map                       as Map----- Recording statistics--- ----------------------ruleFired, inline, knownBranch, betaReduce, substitution :: String -> a -> a-inline          = annotate Inline-ruleFired       = annotate RuleFired-knownBranch     = annotate KnownBranch-betaReduce      = annotate BetaReduce-substitution    = annotate Substitution--simplifierDone, fusionDone :: a -> a-simplifierDone  = tick SimplifierDone-fusionDone      = tick FusionDone---- Add an entry to the statistics counters----tick :: Tick -> a -> a-#ifdef ACCELERATE_DEBUG-{-# NOINLINE tick #-}-tick t expr = unsafeDupablePerformIO $ do-  modifyIORef' statistics (simplTick t)-  return expr-#else-{-# INLINE tick #-}-tick _ expr = expr-#endif---- Add an entry to the statistics counters with an annotation----annotate :: (Id -> Tick) -> String -> a -> a-annotate name ctx = tick (name (Id ctx))----- Simplifier counts--- -------------------data SimplStats-  = Simple         {-# UNPACK #-} !Int          -- when we don't want detailed stats--  | Detail {-      ticks     :: {-# UNPACK #-} !Int,         -- total ticks-      details   :: !TickCount                   -- how many of each type-    }--instance Show SimplStats where-  show = show . pprSimplCount----- Stores the current statistics counters----{-# NOINLINE statistics #-}-statistics :: IORef SimplStats-statistics = unsafePerformIO $ newIORef =<< initSimplCount---- Initialise the statistics counters. If we are dumping the stats--- (-ddump-simpl-stats) record extra information, else just a total tick count.----initSimplCount :: IO SimplStats-#ifdef ACCELERATE_DEBUG-initSimplCount = do-  d <- queryFlag dump_simpl_stats-  return $! if d then Detail { ticks = 0, details = Map.empty }-                 else Simple 0-#else-initSimplCount = return $! Simple 0-#endif----- Reset the statistics counters. Do this at the beginning at each HOAS -> de--- Bruijn conversion + optimisation pass.----resetSimplCount :: IO ()-#ifdef ACCELERATE_DEBUG-resetSimplCount = writeIORef statistics =<< initSimplCount-#else-resetSimplCount = return ()-#endif----- Tick a counter----simplTick :: Tick -> SimplStats -> SimplStats-simplTick _ (Simple n)     = Simple (n+1)-simplTick t (Detail n dts) = Detail (n+1) (dts `addTick` t)---- Pretty print the tick counts. Remarkably reminiscent of GHC style...----pprSimplCount :: SimplStats -> Doc-pprSimplCount (Simple n)     = text "Total ticks:" <+> int n-pprSimplCount (Detail n dts)-  = vcat [ text "Total ticks:" <+> int n-         , text ""-         , pprTickCount dts-         ]--simplCount :: IO Doc-simplCount = pprSimplCount `fmap` readIORef statistics----- Ticks--- -------type TickCount = Map Tick Int--data Id = Id String-  deriving (Eq, Ord)--data Tick-  = Inline              Id-  | RuleFired           Id-  | KnownBranch         Id-  | BetaReduce          Id-  | Substitution        Id--  -- tick at each iteration-  | SimplifierDone-  | FusionDone-  deriving (Eq, Ord)---addTick :: TickCount -> Tick -> TickCount-addTick tc t =-  Map.alter f t tc-  where-    f Nothing  = Just 1-    f (Just x) = let x' = x+1 in x' `seq` Just x'--pprTickCount :: TickCount -> Doc-pprTickCount counts =-  vcat (map pprTickGroup groups)-  where-    groups  = groupBy sameTag (Map.toList counts)-    sameTag = (==) `on` tickToTag . fst--pprTickGroup :: [(Tick,Int)] -> Doc-pprTickGroup []  = error "pprTickGroup"-pprTickGroup grp =-  hang 2 (vcat $ (int groupTotal <+> text groupName)-               : [ int n <+> pprTickCtx t | (t,n) <- sortBy (flip (comparing snd)) grp ])-  where-    groupName  = tickToStr (fst (head grp))-    groupTotal = sum [n | (_,n) <- grp]--tickToTag :: Tick -> Int-tickToTag Inline{}              = 0-tickToTag RuleFired{}           = 1-tickToTag KnownBranch{}         = 2-tickToTag BetaReduce{}          = 3-tickToTag Substitution{}        = 4-tickToTag SimplifierDone        = 99-tickToTag FusionDone            = 100--tickToStr :: Tick -> String-tickToStr Inline{}              = "Inline"-tickToStr RuleFired{}           = "RuleFired"-tickToStr KnownBranch{}         = "KnownBranch"-tickToStr BetaReduce{}          = "BetaReduce"-tickToStr Substitution{}        = "Substitution"-tickToStr SimplifierDone        = "SimplifierDone"-tickToStr FusionDone            = "FusionDone"--pprTickCtx :: Tick -> Doc-pprTickCtx (Inline v)           = pprId v-pprTickCtx (RuleFired v)        = pprId v-pprTickCtx (KnownBranch v)      = pprId v-pprTickCtx (BetaReduce v)       = pprId v-pprTickCtx (Substitution v)     = pprId v-pprTickCtx SimplifierDone       = empty-pprTickCtx FusionDone           = empty--pprId :: Id -> Doc-pprId (Id s) = text s-
− Data/Array/Accelerate/Debug/Timed.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module      : Data.Array.Accelerate.Debug.Timed--- Copyright   : [2016..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.Debug.Timed (--  timed,-  elapsed,--) where--import Data.Array.Accelerate.Debug.Trace-import Data.Array.Accelerate.Debug.Flags--import Control.Monad.Trans                              ( MonadIO )-import Text.Printf--#if ACCELERATE_DEBUG-import Control.Applicative-import Control.Monad.Trans                              ( liftIO )-import Data.List-import Data.Time.Clock-import System.CPUTime-import Prelude--import GHC.Stats-#endif----- | Execute an action and time the results. If GC stats have been enabled (with--- @+RTS -t@ for example) then timing and memory usage information is displayed,--- otherwise only timing information is shown.----{-# INLINEABLE timed #-}-timed :: MonadIO m => Mode -> (Double -> Double -> String) -> m a -> m a-#ifdef ACCELERATE_DEBUG-timed mode fmt action = do-  enabled <- liftIO $ queryFlag mode-  if enabled-    then do-      with_gc <- liftIO $ (&&) <$> getRTSStatsEnabled <*> queryFlag verbose-      if with_gc-        then timed_gc    fmt action-        else timed_simpl fmt action-    else-      action-#else-timed _ _ action = action-#endif--#ifdef ACCELERATE_DEBUG-timed_simpl :: MonadIO m => (Double -> Double -> String) -> m a -> m a-timed_simpl fmt action = do-  wall0 <- liftIO getCurrentTime-  cpu0  <- liftIO getCPUTime-  res   <- action-  wall1 <- liftIO getCurrentTime-  cpu1  <- liftIO getCPUTime-  ---  let wallTime = realToFrac (diffUTCTime wall1 wall0)-      cpuTime  = fromIntegral (cpu1 - cpu0) * 1E-12-  ---  liftIO $ putTraceMsg (fmt wallTime cpuTime)-  return res---timed_gc :: MonadIO m => (Double -> Double -> String) -> m a -> m a-timed_gc fmt action = do-#if __GLASGOW_HASKELL__ < 802-  gc0   <- liftIO getGCStats-  res   <- action-  gc1   <- liftIO getGCStats-#else-  rts0  <- liftIO getRTSStats-  res   <- action-  rts1  <- liftIO getRTSStats-#endif-  ---  let toDouble :: Integral a => a -> Double-      toDouble = fromIntegral-      ---#if __GLASGOW_HASKELL__ < 802-      allocated   = toDouble (bytesAllocated gc1 - bytesAllocated gc0)-      copied      = toDouble (bytesCopied gc1 - bytesCopied gc0)-      totalWall   = wallSeconds gc1 - wallSeconds gc0-      totalCPU    = cpuSeconds gc1 - cpuSeconds gc0-      mutatorWall = mutatorWallSeconds gc1 - mutatorWallSeconds gc0-      mutatorCPU  = mutatorCpuSeconds gc1 - mutatorCpuSeconds gc0-      gcWall      = gcWallSeconds gc1 - gcWallSeconds gc0-      gcCPU       = gcCpuSeconds gc1 - gcCpuSeconds gc0-      totalGCs    = numGcs gc1 - numGcs gc0-#else-      gc0         = gc rts0-      gc1         = gc rts1-      allocated   = toDouble (gcdetails_allocated_bytes gc1 - gcdetails_allocated_bytes gc0)-      copied      = toDouble (gcdetails_copied_bytes gc1 - gcdetails_copied_bytes gc0)-      totalWall   = toDouble (elapsed_ns rts1 - elapsed_ns rts0) * 1.0E-9-      totalCPU    = toDouble (cpu_ns rts1 - cpu_ns rts0) * 1.0E-9-      mutatorWall = toDouble (mutator_elapsed_ns rts1 - mutator_elapsed_ns rts0) * 1.0E-9-      mutatorCPU  = toDouble (mutator_cpu_ns rts1 - mutator_cpu_ns rts0) * 1.0E-9-      gcWall      = toDouble (gcdetails_elapsed_ns gc1 - gcdetails_elapsed_ns gc0) * 1.0E-9-      gcCPU       = toDouble (gcdetails_cpu_ns gc1 - gcdetails_cpu_ns gc0) * 1.0E-9-      totalGCs    = gcs rts1 - gcs rts0-#endif--  liftIO . putTraceMsg $ intercalate "\n"-    [ fmt totalWall totalCPU-    , printf "    %s allocated on the heap" (showFFloatSIBase (Just 1) 1024 allocated "B")-    , printf "    %s copied during GC (%d collections)" (showFFloatSIBase (Just 1) 1024 copied "B") totalGCs-    , printf "    MUT: %s" (elapsed mutatorWall mutatorCPU)-    , printf "    GC:  %s" (elapsed gcWall gcCPU)-    ]-  ---  return res--#if __GLASGOW_HASKELL__ < 802-getRTSStatsEnabled :: IO Bool-getRTSStatsEnabled = getGCStatsEnabled-#endif-#endif--elapsed :: Double -> Double -> String-elapsed wallTime cpuTime =-  printf "%s (wall), %s (cpu)"-    (showFFloatSIBase (Just 3) 1000 wallTime "s")-    (showFFloatSIBase (Just 3) 1000 cpuTime  "s")-
− Data/Array/Accelerate/Debug/Trace.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP          #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}--- |--- Module      : Data.Array.Accelerate.Debug.Trace--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Functions for tracing and monitoring execution. These are useful for--- investigating bugs and performance problems, but by default are not enabled--- in performance code.-----module Data.Array.Accelerate.Debug.Trace-  where--import Data.Array.Accelerate.Debug.Flags--import Numeric-import System.CPUTime-import System.IO.Unsafe-import Text.Printf-import qualified Debug.Trace                            as D----- | Show a signed 'RealFloat' value using SI unit prefixes. In the call to:------ > showFFloatSIBase prec base val------ If @prec@ is @'Nothing'@ the value is shown to full precision, and if @prec@--- is @'Just' d@, then at most @d@ digits are shown after the decimal place.--- Here @base@ represents the increment size between multiples of the original--- unit. For measures in base-10 this will be 1000 and for values in base-2 this--- is usually 1024, for example when measuring seconds versus bytes,--- respectively.----showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> ShowS-showFFloatSIBase prec !base !k-  = showString-  $ case pow of-      4   -> with "T"-      3   -> with "G"-      2   -> with "M"-      1   -> with "k"-      -1  -> with "m"-      -2  -> with "µ"-      -3  -> with "n"-      -4  -> with "p"-      _   -> showGFloat prec k " "      -- no unit or unhandled SI prefix-  where-    !k'         = k / (base ^^ pow)-    !pow        = floor (logBase base k) :: Int-    with unit   = showFFloat prec k' (' ':unit)----- | The 'trace' function outputs the message given as its second argument when--- the debug mode indicated by the first argument is enabled, before returning--- the third argument as its result. The message is prefixed with a time stamp.----trace :: Mode -> String -> a -> a-#ifdef ACCELERATE_DEBUG-{-# NOINLINE trace #-}-trace f msg expr = unsafePerformIO $ do-  traceIO f msg-  return expr-#else-{-# INLINE trace #-}-trace _ _ expr = expr-#endif----- | The 'traceIO' function outputs the trace message together with a time stamp--- from the IO monad. This sequences the output with respect to other IO--- actions.---- TLM: Perhaps we should automatically format the log messages. Namely:---        * prefix with a description of the mode (e.g. "gc: foo")---        * align multi-line messages----traceIO :: Mode -> String -> IO ()-#ifdef ACCELERATE_DEBUG-traceIO f msg = when f $ putTraceMsg msg-#else-{-# INLINE traceIO #-}-traceIO _ _   = return ()-#endif----- | The 'traceEvent' function behaves like 'trace' with the difference that the--- message is emitted to the eventlog, if eventlog profiling is enabled at--- runtime.----traceEvent :: Mode -> String -> a -> a-#ifdef ACCELERATE_DEBUG-{-# NOINLINE traceEvent #-}-traceEvent f msg expr = unsafePerformIO $ do-  traceEventIO f msg-  return expr-#else-{-# INLINE traceEvent #-}-traceEvent _ _ expr = expr-#endif----- | Print a message prefixed with the current CPU time.----putTraceMsg :: String -> IO ()-#ifdef ACCELERATE_DEBUG-putTraceMsg msg = do-  psec        <- getCPUTime-  let secs    = fromIntegral psec * 1E-12 :: Double-  D.traceIO   $ printf "[%8.3f] %s" secs msg-#else-putTraceMsg _   = return ()-#endif----- | The 'traceEventIO' function emits a message to the eventlog, if eventlog--- profiling is available and enabled at runtime.------ Compared to 'traceEvent', 'traceEventIO' sequences the event with respect to--- other IO actions.----traceEventIO :: Mode -> String -> IO ()-#ifdef ACCELERATE_DEBUG-traceEventIO f msg = do-  when f $ D.traceEventIO msg-#else-{-# INLINE traceEventIO #-}-traceEventIO _ _ = return ()-#endif-
− Data/Array/Accelerate/Error.hs 
@@ -1,165 +0,0 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE QuasiQuotes     #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Error--- Copyright   : [2009..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.Error (--  internalError,   boundsError,   unsafeError,-  internalCheck,   boundsCheck,   unsafeCheck,   indexCheck,-  internalWarning, boundsWarning, unsafeWarning,--) where--import Data.List-import Debug.Trace-import Language.Haskell.TH                              hiding ( Unsafe )--data Check = Bounds | Unsafe | Internal----- | Issue an internal error message------   $internalError :: String -> String -> a----internalError :: Q Exp-internalError = appE errorQ [| Internal |]--boundsError :: Q Exp-boundsError = appE errorQ [| Bounds |]--unsafeError :: Q Exp-unsafeError = appE errorQ [| Unsafe |]----- | Throw an error if the condition evaluates to False, otherwise evaluate the--- result.------   $internalCheck :: String -> String -> Bool -> a -> a----internalCheck :: Q Exp-internalCheck = appE checkQ [| Internal |]--boundsCheck :: Q Exp-boundsCheck = appE checkQ [| Bounds |]--unsafeCheck :: Q Exp-unsafeCheck = appE checkQ [| Unsafe |]----- | Throw an error if the index is not in range, otherwise evaluate the result.------   $boundsCheck :: String -> Int -> Int -> a -> a----indexCheck :: Q Exp-indexCheck = withLocation-  [| \format fn i n x ->-        case not (doChecks Bounds) || (i >= 0 && i < n) of-           True  -> x-           False -> error (format Bounds (call fn ("index out of bounds: " ++ show (i,n)))) x |]----- | Print a warning message if the condition evaluates to False.------   $internalWarning :: String -> String -> Bool -> a -> a----internalWarning :: Q Exp-internalWarning = appE warningQ [| Internal |]--boundsWarning :: Q Exp-boundsWarning = appE warningQ [| Bounds |]--unsafeWarning :: Q Exp-unsafeWarning = appE warningQ [| Unsafe |]----- Template Haskell implementation--- ---------------------------------call :: String -> String -> String-call f m = concat ["(", f, "): ", m]--errorQ :: Q Exp-errorQ = withLocation-  [| \format kind fn msg -> error (format kind (call fn msg)) |]--checkQ :: Q Exp-checkQ = withLocation-  [| \format kind fn msg cond x ->-        case not (doChecks kind) || cond of-          True  -> x-          False -> error (format kind (call fn msg)) |]--warningQ :: Q Exp-warningQ = withLocation-  [| \format kind fn msg cond x ->-        case not (doChecks kind) || cond of-          True  -> x-          False -> trace (format kind (call fn msg)) x |]--withLocation :: Q Exp -> Q Exp-withLocation f =-  appE f (locatedMessage =<< location)--locatedMessage :: Loc -> Q Exp-locatedMessage loc =-  [| \kind msg -> message kind ($(litE (stringL (formatLoc loc))) ++ msg) |]--formatLoc :: Loc -> String-formatLoc loc =-  let   file            = loc_filename loc-        (line,col)      = loc_start loc-  in-  intercalate ":" [file, show line, show col, " "]--message :: Check -> String -> String-message kind msg = unlines header ++ msg-  where-    header =-      case kind of-        Internal -> [""-                    ,"*** Internal error in package accelerate ***"-                    ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"]-        _        -> []----- CPP malarky--- -------------{-# INLINE doChecks #-}-doChecks :: Check -> Bool-doChecks Bounds   = doBoundsChecks-doChecks Unsafe   = doUnsafeChecks-doChecks Internal = doInternalChecks--doBoundsChecks :: Bool-#ifdef ACCELERATE_BOUNDS_CHECKS-doBoundsChecks = True-#else-doBoundsChecks = False-#endif--doUnsafeChecks :: Bool-#ifdef ACCELERATE_UNSAFE_CHECKS-doUnsafeChecks = True-#else-doUnsafeChecks = False-#endif--doInternalChecks :: Bool-#ifdef ACCELERATE_INTERNAL_CHECKS-doInternalChecks = True-#else-doInternalChecks = False-#endif-
− Data/Array/Accelerate/FullList.hs 
@@ -1,119 +0,0 @@-{-# LANGUAGE BangPatterns  #-}-{-# LANGUAGE PatternGuards #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.FullList--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Non-empty lists of key/value pairs. The lists are strict in the key and lazy--- in the values. We assume that keys only occur once.-----module Data.Array.Accelerate.FullList (--  FullList(..),-  List(..),--  singleton,-  cons,-  size,-  mapM_,-  lookup,-  lookupDelete,--) where--import Prelude                  hiding ( lookup, mapM_ )---data FullList k v = FL !k v !(List k v)-data List k v     = Nil | Cons !k v !(List k v)--infixr 5 `Cons`--instance (Eq k, Eq v) => Eq (FullList k v) where-  (FL k1 v1 xs) == (FL k2 v2 ys)      = k1 == k2 && v1 == v2 && xs == ys-  (FL k1 v1 xs) /= (FL k2 v2 ys)      = k1 /= k2 || v1 /= v2 || xs /= ys--instance (Eq k, Eq v) => Eq (List k v) where-  (Cons k1 v1 xs) == (Cons k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys-  Nil == Nil = True-  _   == _   = False--  (Cons k1 v1 xs) /= (Cons k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys-  Nil /= Nil = False-  _   /= _   = True----- List-like operations----infixr 5 `cons`-cons :: k -> v -> FullList k v -> FullList k v-cons k v (FL k' v' xs) = FL k v (Cons k' v' xs)--singleton :: k -> v -> FullList k v-singleton k v = FL k v Nil--size :: FullList k v -> Int-size (FL _ _ xs) = 1 + sizeL xs--sizeL :: List k v -> Int-sizeL Nil           = 0-sizeL (Cons _ _ xs) = 1 + sizeL xs--lookup :: Eq k => k -> FullList k v -> Maybe v-lookup key (FL k v xs)-  | key == k    = Just v-  | otherwise   = lookupL key xs-{-# INLINABLE  lookup #-}-{-# SPECIALISE lookup :: () -> FullList () v -> Maybe v #-}--lookupL :: Eq k => k -> List k v -> Maybe v-lookupL !key = go-  where-    go Nil              = Nothing-    go (Cons k v xs)-      | key == k        = Just v-      | otherwise       = go xs-{-# INLINABLE  lookupL #-}-{-# SPECIALISE lookupL :: () -> List () v -> Maybe v #-}--lookupDelete :: Eq k => k -> FullList k v -> (Maybe v, Maybe (FullList k v))-lookupDelete key (FL k v xs)-  | key == k-  = case xs of-      Nil               -> (Just v, Nothing)-      Cons k' v' xs'    -> (Just v, Just $ FL k' v' xs')--  | (r, xs') <- lookupDeleteL k xs-  = (r, Just $ FL k v xs')-{-# INLINABLE  lookupDelete #-}-{-# SPECIALISE lookupDelete :: () -> FullList () v -> (Maybe v, Maybe (FullList () v)) #-}--lookupDeleteL :: Eq k => k -> List k v -> (Maybe v, List k v)-lookupDeleteL !key = go-  where-    go Nil                      = (Nothing, Nil)-    go (Cons k v xs)-      | key == k                = (Just v, xs)-      | (r, xs') <- go xs       = (r,      Cons k v xs')-{-# INLINABLE  lookupDeleteL #-}-{-# SPECIALISE lookupDeleteL :: () -> List () v -> (Maybe v, List () v) #-}--mapM_ :: Monad m => (k -> v -> m a) -> FullList k v -> m ()-mapM_ !f (FL k v xs) = f k v >> mapML_ f xs-{-# INLINABLE mapM_ #-}--mapML_ :: Monad m => (k -> v -> m a) -> List k v -> m ()-mapML_ !f = go-  where-    go Nil              = return ()-    go (Cons k v xs)    = f k v >> go xs-{-# INLINABLE mapML_ #-}-
− Data/Array/Accelerate/Interpreter.hs 
@@ -1,1875 +0,0 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE ViewPatterns        #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_HADDOCK prune #-}--- |--- Module      : Data.Array.Accelerate.Interpreter--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell---               [2014..2014] Frederik M. Madsen--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ This interpreter is meant to be a reference implementation of the semantics--- of the embedded array language. The emphasis is on defining the semantics--- clearly, not on performance.------- [/Surface types versus representation types:/]------ As a general rule, we perform all computations on representation types and we--- store all data as values of representation types. To guarantee the type--- safety of the interpreter, this currently implies a lot of conversions--- between surface and representation types. Optimising the code by eliminating--- back and forth conversions is fine, but only where it doesn't negatively--- affects clarity---after all, the main purpose of the interpreter is to serve--- as an executable specification.-----module Data.Array.Accelerate.Interpreter (--  -- * Interpret an array expression-  Sugar.Acc, Arrays,-  run, run1, runN,--  -- Internal (hidden)-  evalPrim, evalPrimConst, evalPrj--) where---- standard libraries-import Control.DeepSeq-import Control.Exception-import Control.Monad-import Data.Bits-import Data.Char                                                    ( chr, ord )-import System.IO.Unsafe                                             ( unsafePerformIO )-import Text.Printf                                                  ( printf )-import Unsafe.Coerce                                                ( unsafeCoerce )-import Prelude                                                      hiding ( sum )---- friends-import Data.Array.Accelerate.AST                                    hiding ( Boundary, PreBoundary(..) )-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Representation                   ( SliceIndex(..) )-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Trafo                                  hiding ( Delayed )-import Data.Array.Accelerate.Type-import qualified Data.Array.Accelerate.AST                          as AST-import qualified Data.Array.Accelerate.Array.Representation         as R-import qualified Data.Array.Accelerate.Smart                        as Sugar-import qualified Data.Array.Accelerate.Trafo                        as AST--import qualified Data.Array.Accelerate.Debug                        as D----- Program execution--- --------------------- | Run a complete embedded array program using the reference interpreter.----run :: Arrays a => Sugar.Acc a -> a-run a = unsafePerformIO execute-  where-    !acc    = convertAccWith config a-    execute = do-      D.dumpGraph $!! acc-      D.dumpSimplStats-      phase "execute" D.elapsed (evaluate (evalOpenAcc acc Empty))---- | This is 'runN' specialised to an array program of one argument.----run1 :: (Arrays a, Arrays b) => (Sugar.Acc a -> Sugar.Acc b) -> a -> b-run1 = runN---- | Prepare and execute an embedded array program.----runN :: Afunction f => f -> AfunctionR f-runN f = go-  where-    !acc    = convertAfunWith config f-    !afun   = unsafePerformIO $ do-                D.dumpGraph $!! acc-                D.dumpSimplStats-                return acc-    !go     = eval afun Empty-    ---    eval :: DelayedOpenAfun aenv f -> Val aenv -> f-    eval (Alam f)  aenv = \a -> eval f (aenv `Push` a)-    eval (Abody b) aenv = unsafePerformIO $ phase "execute" D.elapsed (evaluate (evalOpenAcc b aenv))----- -- | Stream a lazily read list of input arrays through the given program,--- -- collecting results as we go--- ----- streamOut :: Arrays a => Sugar.Seq [a] -> [a]--- streamOut seq = let seq' = convertSeqWith config seq---                 in evalDelayedSeq defaultSeqConfig seq'---config :: Phase-config =  Phase-  { recoverAccSharing      = True-  , recoverExpSharing      = True-  , recoverSeqSharing      = True-  , floatOutAccFromExp     = True-  , enableAccFusion        = True-  , convertOffsetOfSegment = False-  -- , vectoriseSequences     = True-  }---- Debugging--- -----------phase :: String -> (Double -> Double -> String) -> IO a -> IO a-phase n fmt go = D.timed D.dump_phases (\wall cpu -> printf "phase %s: %s" n (fmt wall cpu)) go----- Delayed Arrays--- ------------------ Note that in contrast to the representation used in the optimised AST, the--- delayed array representation used here is _only_ for delayed arrays --- we do--- not require an optional Manifest|Delayed data type to evaluate the program.----data Delayed a where-  Delayed :: (Shape sh, Elt e)-          => sh-          -> (sh -> e)-          -> (Int -> e)-          -> Delayed (Array sh e)----- Array expression evaluation--- -----------------------------type EvalAcc acc = forall aenv a. acc aenv a -> Val aenv -> a---- Evaluate an open array function----evalOpenAfun :: DelayedOpenAfun aenv f -> Val aenv -> f-evalOpenAfun (Alam  f) aenv = \a -> evalOpenAfun f (aenv `Push` a)-evalOpenAfun (Abody b) aenv = evalOpenAcc b aenv----- The core interpreter for optimised array programs----evalOpenAcc-    :: forall aenv a.-       DelayedOpenAcc aenv a-    -> Val aenv-    -> a-evalOpenAcc AST.Delayed{}       _    = $internalError "evalOpenAcc" "expected manifest array"-evalOpenAcc (AST.Manifest pacc) aenv =-  let-      manifest :: DelayedOpenAcc aenv a' -> a'-      manifest acc = evalOpenAcc acc aenv--      delayed :: DelayedOpenAcc aenv (Array sh e) -> Delayed (Array sh e)-      delayed AST.Manifest{}  = $internalError "evalOpenAcc" "expected delayed array"-      delayed AST.Delayed{..} = Delayed (evalE extentD) (evalF indexD) (evalF linearIndexD)--      evalE :: DelayedExp aenv t -> t-      evalE exp = evalPreExp evalOpenAcc exp aenv--      evalF :: DelayedFun aenv f -> f-      evalF fun = evalPreFun evalOpenAcc fun aenv--      evalB :: AST.PreBoundary DelayedOpenAcc aenv t -> Boundary t-      evalB bnd = evalPreBoundary evalOpenAcc bnd aenv-  in-  case pacc of-    Avar ix                     -> prj ix aenv-    Alet acc1 acc2              -> evalOpenAcc acc2 (aenv `Push` manifest acc1)-    Atuple atup                 -> toAtuple $ evalAtuple atup aenv-    Aprj ix atup                -> evalPrj ix . fromAtuple $ manifest atup-    Apply afun acc              -> evalOpenAfun afun aenv  $ manifest acc-    Aforeign _ afun acc         -> evalOpenAfun afun Empty $ manifest acc-    Acond p acc1 acc2-      | evalE p                 -> manifest acc1-      | otherwise               -> manifest acc2--    Awhile cond body acc        -> go (manifest acc)-      where-        p       = evalOpenAfun cond aenv-        f       = evalOpenAfun body aenv-        go !x-          | p x ! Z     = go (f x)-          | otherwise   = x--    Use arr                     -> toArr arr-    Unit e                      -> unitOp (evalE e)-    -- Collect s                   -> evalSeq defaultSeqConfig s aenv--    -- Producers-    -- ----------    Map f acc                   -> mapOp (evalF f) (delayed acc)-    Generate sh f               -> generateOp (evalE sh) (evalF f)-    Transform sh p f acc        -> transformOp (evalE sh) (evalF p) (evalF f) (delayed acc)-    Backpermute sh p acc        -> backpermuteOp (evalE sh) (evalF p) (delayed acc)-    Reshape sh acc              -> reshapeOp (evalE sh) (manifest acc)--    ZipWith f acc1 acc2         -> zipWithOp (evalF f) (delayed acc1) (delayed acc2)-    Replicate slice slix acc    -> replicateOp slice (evalE slix) (manifest acc)-    Slice slice acc slix        -> sliceOp slice (manifest acc) (evalE slix)--    -- Consumers-    -- ----------    Fold f z acc                -> foldOp (evalF f) (evalE z) (delayed acc)-    Fold1 f acc                 -> fold1Op (evalF f) (delayed acc)-    FoldSeg f z acc seg         -> foldSegOp (evalF f) (evalE z) (delayed acc) (delayed seg)-    Fold1Seg f acc seg          -> fold1SegOp (evalF f) (delayed acc) (delayed seg)-    Scanl f z acc               -> scanlOp (evalF f) (evalE z) (delayed acc)-    Scanl' f z acc              -> scanl'Op (evalF f) (evalE z) (delayed acc)-    Scanl1 f acc                -> scanl1Op (evalF f) (delayed acc)-    Scanr f z acc               -> scanrOp (evalF f) (evalE z) (delayed acc)-    Scanr' f z acc              -> scanr'Op (evalF f) (evalE z) (delayed acc)-    Scanr1 f acc                -> scanr1Op (evalF f) (delayed acc)-    Permute f def p acc         -> permuteOp (evalF f) (manifest def) (evalF p) (delayed acc)-    Stencil sten b acc          -> stencilOp (evalF sten) (evalB b) (manifest acc)-    Stencil2 sten b1 a1 b2 a2   -> stencil2Op (evalF sten) (evalB b1) (manifest a1) (evalB b2) (manifest a2)---- Array tuple construction and projection----evalAtuple :: Atuple (DelayedOpenAcc aenv) t -> Val aenv -> t-evalAtuple NilAtup        _    = ()-evalAtuple (SnocAtup t a) aenv = (evalAtuple t aenv, evalOpenAcc a aenv)----- Array primitives--- ------------------unitOp :: Elt e => e -> Scalar e-unitOp e = fromFunction Z (const e)---generateOp-    :: (Shape sh, Elt e)-    => sh-    -> (sh -> e)-    -> Array sh e-generateOp = fromFunction---transformOp-    :: (Shape sh', Elt b)-    => sh'-    -> (sh' -> sh)-    -> (a -> b)-    -> Delayed (Array sh a)-    -> Array sh' b-transformOp sh' p f (Delayed _ xs _)-  = fromFunction sh' (\ix -> f (xs $ p ix))---reshapeOp-    :: (Shape sh, Shape sh', Elt e)-    => sh-    -> Array sh' e-    -> Array sh  e-reshapeOp newShape arr@(Array _ adata)-  = $boundsCheck "reshape" "shape mismatch" (size newShape == size (shape arr))-  $ Array (fromElt newShape) adata---replicateOp-    :: (Shape sh, Shape sl, Elt slix, Elt e)-    => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-    -> slix-    -> Array sl e-    -> Array sh e-replicateOp slice slix arr-  = fromFunction (toElt sh) (\ix -> arr ! liftToElt pf ix)-  where-    (sh, pf) = extend slice (fromElt slix) (fromElt (shape arr))--    extend :: SliceIndex slix sl co dim-           -> slix-           -> sl-           -> (dim, dim -> sl)-    extend SliceNil              ()        ()       = ((), const ())-    extend (SliceAll sliceIdx)   (slx, ()) (sl, sz)-      = let (dim', f') = extend sliceIdx slx sl-        in  ((dim', sz), \(ix, i) -> (f' ix, i))-    extend (SliceFixed sliceIdx) (slx, sz) sl-      = let (dim', f') = extend sliceIdx slx sl-        in  ((dim', sz), \(ix, _) -> f' ix)---sliceOp-    :: (Shape sh, Shape sl, Elt slix, Elt e)-    => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-    -> Array sh e-    -> slix-    -> Array sl e-sliceOp slice arr slix-  = fromFunction (toElt sh') (\ix -> arr ! liftToElt pf ix)-  where-    (sh', pf) = restrict slice (fromElt slix) (fromElt (shape arr))--    restrict :: SliceIndex slix sl co sh-             -> slix-             -> sh-             -> (sl, sl -> sh)-    restrict SliceNil              ()        ()       = ((), const ())-    restrict (SliceAll sliceIdx)   (slx, ()) (sl, sz)-      = let (sl', f') = restrict sliceIdx slx sl-        in  ((sl', sz), \(ix, i) -> (f' ix, i))-    restrict (SliceFixed sliceIdx) (slx, i)  (sl, sz)-      = let (sl', f') = restrict sliceIdx slx sl-        in  $indexCheck "slice" i sz $ (sl', \ix -> (f' ix, i))---mapOp :: (Shape sh, Elt b)-      => (a -> b)-      -> Delayed (Array sh a)-      -> Array sh b-mapOp f (Delayed sh xs _)-  = fromFunction sh (\ix -> f (xs ix))---zipWithOp-    :: (Shape sh, Elt c)-    => (a -> b -> c)-    -> Delayed (Array sh a)-    -> Delayed (Array sh b)-    -> Array sh c-zipWithOp f (Delayed shx xs _) (Delayed shy ys _)-  = fromFunction (shx `intersect` shy) (\ix -> f (xs ix) (ys ix))---- zipWith'Op---     :: (Shape sh, Elt a)---     => (a -> a -> a)---     -> Delayed (Array sh a)---     -> Delayed (Array sh a)---     -> Array sh a--- zipWith'Op f (Delayed shx xs _) (Delayed shy ys _)---   = fromFunction (shx `union` shy) (\ix -> if ix `outside` shx---                                            then ys ix---                                            else if ix `outside` shy---                                            then xs ix---                                            else f (xs ix) (ys ix))---   where---     a `outside` b = or $ zipWith (>=) (shapeToList a) (shapeToList b)---foldOp-    :: (Shape sh, Elt e)-    => (e -> e -> e)-    -> e-    -> Delayed (Array (sh :. Int) e)-    -> Array sh e-foldOp f z (Delayed (sh :. n) arr _)-  | size sh == 0-  = fromFunction (listToShape . map (max 1) . shapeToList $ sh) (const z)--  | otherwise-  = fromFunction sh (\ix -> iter (Z:.n) (\(Z:.i) -> arr (ix :. i)) f z)---fold1Op-    :: (Shape sh, Elt e)-    => (e -> e -> e)-    -> Delayed (Array (sh :. Int) e)-    -> Array sh e-fold1Op f (Delayed (sh :. n) arr _)-  = $boundsCheck "fold1" "empty array" (n > 0)-  $ fromFunction sh (\ix -> iter1 (Z:.n) (\(Z:.i) -> arr (ix :. i)) f)---foldSegOp-    :: forall sh e i. (Elt e, Elt i, IsIntegral i)-    => (e -> e -> e)-    -> e-    -> Delayed (Array (sh :. Int) e)-    -> Delayed (Segments i)-    -> Array (sh :. Int) e-foldSegOp f z (Delayed (sh :. _) arr _) seg@(Delayed (Z :. n) _ _)-  | IntegralDict <- integralDict (integralType :: IntegralType i)-  = fromFunction (sh :. n)-  $ \(sz :. ix) -> let start = fromIntegral $ offset ! (Z :. ix)-                       end   = fromIntegral $ offset ! (Z :. ix+1)-                   in-                   iter (Z :. end-start) (\(Z:.i) -> arr (sz :. start+i)) f z-  where-    offset      = scanlOp (+) 0 seg---fold1SegOp-    :: forall sh e i. (Shape sh, Elt e, Elt i, IsIntegral i)-    => (e -> e -> e)-    -> Delayed (Array (sh :. Int) e)-    -> Delayed (Segments i)-    -> Array (sh :. Int) e-fold1SegOp f (Delayed (sh :. _) arr _) seg@(Delayed (Z :. n) _ _)-  | IntegralDict <- integralDict (integralType :: IntegralType i)-  = fromFunction (sh :. n)-  $ \(sz :. ix) -> let start = fromIntegral $ offset ! (Z :. ix)-                       end   = fromIntegral $ offset ! (Z :. ix+1)-                   in-                   $boundsCheck "fold1Seg" "empty segment" (end > start)-                   $ iter1 (Z :. end-start) (\(Z:.i) -> arr (sz :. start+i)) f-  where-    offset      = scanlOp (+) 0 seg---scanl1Op-    :: (Shape sh, Elt e)-    => (e -> e -> e)-    -> Delayed (Array (sh:.Int) e)-    -> Array (sh:.Int) e-scanl1Op f (Delayed sh@(_ :. n) ain _)-  = $boundsCheck "scanl1" "empty array" (n > 0)-  $ adata `seq` Array (fromElt sh) adata-  where-    f'          = sinkFromElt2 f-    ---    (adata, _)  = runArrayData $ do-      aout <- newArrayData (size sh)--      let write (sz:.0) = unsafeWriteArrayData aout (toIndex sh (sz:.0)) (fromElt (ain (sz:.0)))-          write (sz:.i) = do-            x <- unsafeReadArrayData aout (toIndex sh (sz:.i-1))-            y <- return $ fromElt (ain (sz:.i))-            unsafeWriteArrayData aout (toIndex sh (sz:.i)) (f' x y)--      iter1 sh write (>>)-      return (aout, undefined)---scanlOp-    :: (Shape sh, Elt e)-    => (e -> e -> e)-    -> e-    -> Delayed (Array (sh:.Int) e)-    -> Array (sh:.Int) e-scanlOp f z (Delayed (sh :. n) ain _)-  = adata `seq` Array (fromElt sh') adata-  where-    sh'         = sh :. n+1-    f'          = sinkFromElt2 f-    ---    (adata, _)  = runArrayData $ do-      aout <- newArrayData (size sh')--      let write (sz:.0) = unsafeWriteArrayData aout (toIndex sh' (sz:.0)) (fromElt z)-          write (sz:.i) = do-            x <- unsafeReadArrayData aout (toIndex sh' (sz:.i-1))-            y <- return $ fromElt (ain (sz:.i-1))-            unsafeWriteArrayData aout (toIndex sh' (sz:.i)) (f' x y)--      iter sh' write (>>) (return ())-      return (aout, undefined)---scanl'Op-    :: (Shape sh, Elt e)-    => (e -> e -> e)-    -> e-    -> Delayed (Array (sh:.Int) e)-    -> (Array (sh:.Int) e, Array sh e)-scanl'Op f z (Delayed (sh :. n) ain _)-  = aout `seq` asum `seq` ( Array (fromElt (sh:.n)) aout-                          , Array (fromElt sh)      asum )-  where-    f'          = sinkFromElt2 f-    ---    (AD_Pair aout asum, _) = runArrayData $ do-      aout <- newArrayData (size (sh:.n))-      asum <- newArrayData (size sh)--      let write (sz:.0)-            | n == 0    = unsafeWriteArrayData asum (toIndex sh sz) (fromElt z)-            | otherwise = unsafeWriteArrayData aout (toIndex (sh:.n) (sz:.0)) (fromElt z)-          write (sz:.i) = do-            x <- unsafeReadArrayData aout (toIndex (sh:.n) (sz:.i-1))-            y <- return $ fromElt (ain (sz:.i-1))-            if i == n-              then unsafeWriteArrayData asum (toIndex sh      sz)      (f' x y)-              else unsafeWriteArrayData aout (toIndex (sh:.n) (sz:.i)) (f' x y)--      iter (sh:.n+1) write (>>) (return ())-      return (AD_Pair aout asum, undefined)---scanrOp-    :: (Shape sh, Elt e)-    => (e -> e -> e)-    -> e-    -> Delayed (Array (sh:.Int) e)-    -> Array (sh:.Int) e-scanrOp f z (Delayed (sz :. n) ain _)-  = adata `seq` Array (fromElt sh') adata-  where-    sh'         = sz :. n+1-    f'          = sinkFromElt2 f-    ---    (adata, _)  = runArrayData $ do-      aout <- newArrayData (size sh')--      let write (sz:.0) = unsafeWriteArrayData aout (toIndex sh' (sz:.n)) (fromElt z)-          write (sz:.i) = do-            x <- return $ fromElt (ain (sz:.n-i))-            y <- unsafeReadArrayData aout (toIndex sh' (sz:.n-i+1))-            unsafeWriteArrayData aout (toIndex sh' (sz:.n-i)) (f' x y)--      iter sh' write (>>) (return ())-      return (aout, undefined)---scanr1Op-    :: (Shape sh, Elt e)-    => (e -> e -> e)-    -> Delayed (Array (sh:.Int) e)-    -> Array (sh:.Int) e-scanr1Op f (Delayed sh@(_ :. n) ain _)-  = $boundsCheck "scanr1" "empty array" (n > 0)-  $ adata `seq` Array (fromElt sh) adata-  where-    f'          = sinkFromElt2 f-    ---    (adata, _)  = runArrayData $ do-      aout <- newArrayData (size sh)--      let write (sz:.0) = unsafeWriteArrayData aout (toIndex sh (sz:.n-1)) (fromElt (ain (sz:.n-1)))-          write (sz:.i) = do-            x <- return $ fromElt (ain (sz:.n-i-1))-            y <- unsafeReadArrayData aout (toIndex sh (sz:.n-i))-            unsafeWriteArrayData aout (toIndex sh (sz:.n-i-1)) (f' x y)--      iter1 sh write (>>)-      return (aout, undefined)---scanr'Op-    :: forall sh e. (Shape sh, Elt e)-    => (e -> e -> e)-    -> e-    -> Delayed (Array (sh:.Int) e)-    -> (Array (sh:.Int) e, Array sh e)-scanr'Op f z (Delayed (sh :. n) ain _)-  = aout `seq` asum `seq` ( Array (fromElt (sh:.n)) aout-                          , Array (fromElt sh)      asum )-  where-    f'          = sinkFromElt2 f-    ---    (AD_Pair aout asum, _) = runArrayData $ do-      aout <- newArrayData (size (sh:.n))-      asum <- newArrayData (size sh)--      let write (sz:.0)-            | n == 0    = unsafeWriteArrayData asum (toIndex sh sz) (fromElt z)-            | otherwise = unsafeWriteArrayData aout (toIndex (sh:.n) (sz:.n-1)) (fromElt z)--          write (sz:.i) = do-            x <- return $ fromElt (ain (sz:.n-i))-            y <- unsafeReadArrayData aout (toIndex (sh:.n) (sz:.n-i))-            if i == n-              then unsafeWriteArrayData asum (toIndex sh      sz)          (f' x y)-              else unsafeWriteArrayData aout (toIndex (sh:.n) (sz:.n-i-1)) (f' x y)--      iter (sh:.n+1) write (>>) (return ())-      return (AD_Pair aout asum, undefined)---permuteOp-    :: (Shape sh, Shape sh', Elt e)-    => (e -> e -> e)-    -> Array sh' e-    -> (sh -> sh')-    -> Delayed (Array sh  e)-    -> Array sh' e-permuteOp f def@(Array _ adef) p (Delayed sh _ ain)-  = adata `seq` Array (fromElt sh') adata-  where-    sh'         = shape def-    n'          = size sh'-    f'          = sinkFromElt2 f-    ---    (adata, _)  = runArrayData $ do-      aout <- newArrayData n'--      let -- initialise array with default values-          init i-            | i >= n'   = return ()-            | otherwise = do-                x <- unsafeReadArrayData adef i-                unsafeWriteArrayData aout i x-                init (i+1)--          -- project each element onto the destination array and update-          update src-            = let dst   = p src-                  i     = toIndex sh  src-                  j     = toIndex sh' dst-              in-              unless (fromElt dst == R.ignore) $ do-                x <- return . fromElt $  ain  i-                y <- unsafeReadArrayData aout j-                unsafeWriteArrayData aout j (f' x y)--      init 0-      iter sh update (>>) (return ())-      return (aout, undefined)---backpermuteOp-    :: (Shape sh', Elt e)-    => sh'-    -> (sh' -> sh)-    -> Delayed (Array sh e)-    -> Array sh' e-backpermuteOp sh' p (Delayed _ arr _)-  = fromFunction sh' (\ix -> arr $ p ix)---stencilOp-    :: (Stencil sh a stencil, Elt b)-    => (stencil -> b)-    -> Boundary (Array sh a)-    -> Array sh a-    -> Array sh b-stencilOp stencil bnd arr-  = fromFunction sh f-  where-    sh  = shape arr-    f   = stencil . stencilAccess (bounded bnd arr)---stencil2Op-    :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c)-    => (stencil1 -> stencil2 -> c)-    -> Boundary (Array sh a)-    -> Array sh a-    -> Boundary (Array sh b)-    -> Array sh b-    -> Array sh c-stencil2Op stencil bnd1 arr1 bnd2 arr2-  = fromFunction (sh1 `intersect` sh2) f-  where-    sh1   = shape arr1-    sh2   = shape arr2-    f ix  = stencil (stencilAccess (bounded bnd1 arr1) ix)-                    (stencilAccess (bounded bnd2 arr2) ix)--stencilAccess-    :: Stencil sh e stencil-    => (sh -> e)-    -> sh-    -> stencil-stencilAccess = goR stencil-  where-    -- Base cases, nothing interesting to do here since we know the lower-    -- dimension is Z.-    ---    goR :: StencilR sh e stencil -> (sh -> e) -> sh -> stencil-    goR StencilRunit3 rf ix =-      let-          z :. i = ix-          rf' d  = rf (z :. i+d)-      in-      ( rf' (-1)-      , rf'   0-      , rf'   1-      )--    goR StencilRunit5 rf ix =-      let z :. i = ix-          rf' d  = rf (z :. i+d)-      in-      ( rf' (-2)-      , rf' (-1)-      , rf'   0-      , rf'   1-      , rf'   2-      )--    goR StencilRunit7 rf ix =-      let z :. i = ix-          rf' d  = rf (z :. i+d)-      in-      ( rf' (-3)-      , rf' (-2)-      , rf' (-1)-      , rf'   0-      , rf'   1-      , rf'   2-      , rf'   3-      )--    goR StencilRunit9 rf ix =-      let z :. i = ix-          rf' d  = rf (z :. i+d)-      in-      ( rf' (-4)-      , rf' (-3)-      , rf' (-2)-      , rf' (-1)-      , rf'   0-      , rf'   1-      , rf'   2-      , rf'   3-      , rf'   4-      )--    -- Recursive cases. Note that because the stencil pattern is defined with-    -- cons ordering, whereas shapes (and indices) are defined as a snoc-list,-    -- when we recurse on the stencil structure we must manipulate the-    -- _left-most_ index component.-    ---    goR (StencilRtup3 s1 s2 s3) rf ix =-      let (i, ix') = uncons ix-          rf' d ds = rf (cons (i+d) ds)-      in-      ( goR s1 (rf' (-1)) ix'-      , goR s2 (rf'   0)  ix'-      , goR s3 (rf'   1)  ix'-      )--    goR (StencilRtup5 s1 s2 s3 s4 s5) rf ix =-      let (i, ix') = uncons ix-          rf' d ds = rf (cons (i+d) ds)-      in-      ( goR s1 (rf' (-2)) ix'-      , goR s2 (rf' (-1)) ix'-      , goR s3 (rf'   0)  ix'-      , goR s4 (rf'   1)  ix'-      , goR s5 (rf'   2)  ix'-      )--    goR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) rf ix =-      let (i, ix') = uncons ix-          rf' d ds = rf (cons (i+d) ds)-      in-      ( goR s1 (rf' (-3)) ix'-      , goR s2 (rf' (-2)) ix'-      , goR s3 (rf' (-1)) ix'-      , goR s4 (rf'   0)  ix'-      , goR s5 (rf'   1)  ix'-      , goR s6 (rf'   2)  ix'-      , goR s7 (rf'   3)  ix'-      )--    goR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) rf ix =-      let (i, ix') = uncons ix-          rf' d ds = rf (cons (i+d) ds)-      in-      ( goR s1 (rf' (-4)) ix'-      , goR s2 (rf' (-3)) ix'-      , goR s3 (rf' (-2)) ix'-      , goR s4 (rf' (-1)) ix'-      , goR s5 (rf'   0)  ix'-      , goR s6 (rf'   1)  ix'-      , goR s7 (rf'   2)  ix'-      , goR s8 (rf'   3)  ix'-      , goR s9 (rf'   4)  ix'-      )--    -- Add a left-most component to an index-    ---    cons :: forall sh. Shape sh => Int -> sh -> (sh :. Int)-    cons ix extent = toElt $ go (eltType (undefined::sh)) (fromElt extent)-      where-        go :: TupleType t -> t -> (t, Int)-        go UnitTuple         ()       = ((), ix)-        go (PairTuple th tz) (sh, sz)-          | SingleTuple t <- tz-          , Just Refl     <- matchScalarType t (scalarType :: ScalarType Int)-          = (go th sh, sz)-        go _ _-          = $internalError "cons" "expected index with Int components"--    -- Remove the left-most index of an index, and return the remainder-    ---    uncons :: forall sh. Shape sh => sh :. Int -> (Int, sh)-    uncons extent = let (i,ix) = go (eltType (undefined::(sh:.Int))) (fromElt extent)-                    in  (i, toElt ix)-      where-        go :: TupleType (t, Int) -> (t, Int) -> (Int, t)-        go (PairTuple UnitTuple _)           ((), v) = (v, ())-        go (PairTuple t1@(PairTuple _ t2) _) (v1,v3)-          | SingleTuple t <- t2-          , Just Refl     <- matchScalarType t (scalarType :: ScalarType Int)-          = let (i, v1') = go t1 v1-            in  (i, (v1', v3))-        go _ _-          = $internalError "uncons" "expected index with Int components"---bounded-    :: (Shape sh, Elt e)-    => Boundary (Array sh e)-    -> Array sh e-    -> sh-    -> e-bounded bnd arr ix =-  if inside (shape arr) ix-    then arr ! ix-    else-      case bnd of-        Function f -> f ix-        Constant v -> toElt v-        _          -> arr ! bound (shape arr) ix--  where-    -- Whether the index (second argument) is inside the bounds of the given-    -- shape (first argument).-    ---    inside :: forall sh. Shape sh => sh -> sh -> Bool-    inside sh1 ix1 = go (eltType (undefined::sh)) (fromElt sh1) (fromElt ix1)-      where-        go :: TupleType t -> t -> t -> Bool-        go UnitTuple          ()       ()      = True-        go (PairTuple tsh ti) (sh, sz) (ih,iz)-          = if go ti sz iz-              then go tsh sh ih-              else False-        go (SingleTuple t) sz iz-          | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)-          = if iz < 0 || iz >= sz-              then False-              else True-          ---          | otherwise-          = $internalError "inside" "expected index with Int components"--    -- Return the index (second argument), updated to obey the given boundary-    -- conditions when outside the bounds of the given shape (first argument)-    ---    bound :: forall sh. Shape sh => sh -> sh -> sh-    bound sh1 ix1 = toElt $ go (eltType (undefined::sh)) (fromElt sh1) (fromElt ix1)-      where-        go :: TupleType t -> t -> t -> t-        go UnitTuple          ()       ()       = ()-        go (PairTuple tsh ti) (sh, sz) (ih, iz) = (go tsh sh ih, go ti sz iz)-        go (SingleTuple t)    sz       iz-          | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)-          = let i | iz < 0    = case bnd of-                                  Clamp  -> 0-                                  Mirror -> -iz-                                  Wrap   -> sz + iz-                                  _      -> $internalError "bound" "unexpected boundary condition"-                  | iz >= sz  = case bnd of-                                  Clamp  -> sz - 1-                                  Mirror -> sz - (iz - sz + 2)-                                  Wrap   -> iz - sz-                                  _      -> $internalError "bound" "unexpected boundary condition"-                  | otherwise = iz-            in i-          | otherwise-          = $internalError "bound" "expected index with Int components"----- toSeqOp :: forall slix sl dim co e proxy. (Elt slix, Shape sl, Shape dim, Elt e)---         => SliceIndex (EltRepr slix)---                       (EltRepr sl)---                       co---                       (EltRepr dim)---         -> proxy slix---         -> Array dim e---         -> [Array sl e]--- toSeqOp sliceIndex _ arr = map (sliceOp sliceIndex arr :: slix -> Array sl e)---                                (enumSlices sliceIndex (shape arr))----- Stencil boundary conditions--- -----------------------------data Boundary t where-  Clamp    :: Boundary t-  Mirror   :: Boundary t-  Wrap     :: Boundary t-  Constant :: Elt t => EltRepr t -> Boundary (Array sh t)-  Function :: (Shape sh, Elt e) => (sh -> e) -> Boundary (Array sh e)---evalPreBoundary :: EvalAcc acc -> AST.PreBoundary acc aenv t -> Val aenv -> Boundary t-evalPreBoundary evalAcc bnd aenv =-  case bnd of-    AST.Clamp      -> Clamp-    AST.Mirror     -> Mirror-    AST.Wrap       -> Wrap-    AST.Constant v -> Constant v-    AST.Function f -> Function (evalPreFun evalAcc f aenv)----- Scalar expression evaluation--- -------------------------------- Evaluate a closed scalar expression----evalPreExp :: EvalAcc acc -> PreExp acc aenv t -> Val aenv -> t-evalPreExp evalAcc e aenv = evalPreOpenExp evalAcc e EmptyElt aenv---- Evaluate a closed scalar function----evalPreFun :: EvalAcc acc -> PreFun acc aenv t -> Val aenv -> t-evalPreFun evalAcc f aenv = evalPreOpenFun evalAcc f EmptyElt aenv---- Evaluate an open scalar function----evalPreOpenFun :: EvalAcc acc -> PreOpenFun acc env aenv t -> ValElt env -> Val aenv -> t-evalPreOpenFun evalAcc (Body e) env aenv = evalPreOpenExp evalAcc e env aenv-evalPreOpenFun evalAcc (Lam f)  env aenv =-  \x -> evalPreOpenFun evalAcc f (env `PushElt` fromElt x) aenv----- Evaluate an open scalar expression------ NB: The implementation of 'Index' and 'Shape' demonstrate clearly why---     array expressions must be hoisted out of scalar expressions before code---     execution. If these operations are in the body of a function that gets---     mapped over an array, the array argument would be evaluated many times---     leading to a large amount of wasteful recomputation.----evalPreOpenExp-    :: forall acc env aenv t.-       EvalAcc acc-    -> PreOpenExp acc env aenv t-    -> ValElt env-    -> Val aenv-    -> t-evalPreOpenExp evalAcc pexp env aenv =-  let-      evalE :: PreOpenExp acc env aenv t' -> t'-      evalE e = evalPreOpenExp evalAcc e env aenv--      evalF :: PreOpenFun acc env aenv f' -> f'-      evalF f = evalPreOpenFun evalAcc f env aenv--      evalA :: acc aenv a -> a-      evalA a = evalAcc a aenv-  in-  case pexp of-    Let exp1 exp2               -> let !v1  = evalE exp1-                                       env' = env `PushElt` fromElt v1-                                   in  evalPreOpenExp evalAcc exp2 env' aenv-    Var ix                      -> prjElt ix env-    Const c                     -> toElt c-    PrimConst c                 -> evalPrimConst c-    PrimApp f x                 -> evalPrim f (evalE x)-    Tuple tup                   -> toTuple $ evalTuple evalAcc tup env aenv-    Prj ix tup                  -> evalPrj ix . fromTuple $ evalE tup-    IndexNil                    -> Z-    IndexAny                    -> Any-    IndexCons sh sz             -> evalE sh :. evalE sz-    IndexHead sh                -> let _  :. ix = evalE sh in ix-    IndexTail sh                -> let ix :. _  = evalE sh in ix-    IndexSlice slice slix sh    -> toElt $ restrict slice (fromElt (evalE slix))-                                                          (fromElt (evalE sh))-      where-        restrict :: SliceIndex slix sl co sh -> slix -> sh -> sl-        restrict SliceNil              ()        ()         = ()-        restrict (SliceAll sliceIdx)   (slx, ()) (sl, sz)   =-          let sl' = restrict sliceIdx slx sl-          in  (sl', sz)-        restrict (SliceFixed sliceIdx) (slx, _i)  (sl, _sz) =-          restrict sliceIdx slx sl--    IndexFull slice slix sh     -> toElt $ extend slice (fromElt (evalE slix))-                                                        (fromElt (evalE sh))-      where-        extend :: SliceIndex slix sl co sh -> slix -> sl -> sh-        extend SliceNil              ()        ()       = ()-        extend (SliceAll sliceIdx)   (slx, ()) (sl, sz) =-          let sh' = extend sliceIdx slx sl-          in  (sh', sz)-        extend (SliceFixed sliceIdx) (slx, sz) sl       =-          let sh' = extend sliceIdx slx sl-          in  (sh', sz)--    ToIndex sh ix               -> toIndex (evalE sh) (evalE ix)-    FromIndex sh ix             -> fromIndex (evalE sh) (evalE ix)-    Cond c t e-      | evalE c                 -> evalE t-      | otherwise               -> evalE e--    While cond body seed        -> go (evalE seed)-      where-        f       = evalF body-        p       = evalF cond-        go !x-          | p x         = go (f x)-          | otherwise   = x--    Index acc ix                -> evalA acc ! evalE ix-    LinearIndex acc i           -> let a  = evalA acc-                                       ix = fromIndex (shape a) (evalE i)-                                   in a ! ix-    Shape acc                   -> shape (evalA acc)-    ShapeSize sh                -> size (evalE sh)-    Intersect sh1 sh2           -> intersect (evalE sh1) (evalE sh2)-    Union sh1 sh2               -> union (evalE sh1) (evalE sh2)-    Foreign _ f e               -> evalPreOpenFun evalAcc f EmptyElt Empty $ evalE e----- Scalar primitives--- -------------------evalPrimConst :: PrimConst a -> a-evalPrimConst (PrimMinBound ty) = evalMinBound ty-evalPrimConst (PrimMaxBound ty) = evalMaxBound ty-evalPrimConst (PrimPi       ty) = evalPi ty--evalPrim :: PrimFun p -> p-evalPrim (PrimAdd                ty) = evalAdd ty-evalPrim (PrimSub                ty) = evalSub ty-evalPrim (PrimMul                ty) = evalMul ty-evalPrim (PrimNeg                ty) = evalNeg ty-evalPrim (PrimAbs                ty) = evalAbs ty-evalPrim (PrimSig                ty) = evalSig ty-evalPrim (PrimQuot               ty) = evalQuot ty-evalPrim (PrimRem                ty) = evalRem ty-evalPrim (PrimQuotRem            ty) = evalQuotRem ty-evalPrim (PrimIDiv               ty) = evalIDiv ty-evalPrim (PrimMod                ty) = evalMod ty-evalPrim (PrimDivMod             ty) = evalDivMod ty-evalPrim (PrimBAnd               ty) = evalBAnd ty-evalPrim (PrimBOr                ty) = evalBOr ty-evalPrim (PrimBXor               ty) = evalBXor ty-evalPrim (PrimBNot               ty) = evalBNot ty-evalPrim (PrimBShiftL            ty) = evalBShiftL ty-evalPrim (PrimBShiftR            ty) = evalBShiftR ty-evalPrim (PrimBRotateL           ty) = evalBRotateL ty-evalPrim (PrimBRotateR           ty) = evalBRotateR ty-evalPrim (PrimPopCount           ty) = evalPopCount ty-evalPrim (PrimCountLeadingZeros  ty) = evalCountLeadingZeros ty-evalPrim (PrimCountTrailingZeros ty) = evalCountTrailingZeros ty-evalPrim (PrimFDiv               ty) = evalFDiv ty-evalPrim (PrimRecip              ty) = evalRecip ty-evalPrim (PrimSin                ty) = evalSin ty-evalPrim (PrimCos                ty) = evalCos ty-evalPrim (PrimTan                ty) = evalTan ty-evalPrim (PrimAsin               ty) = evalAsin ty-evalPrim (PrimAcos               ty) = evalAcos ty-evalPrim (PrimAtan               ty) = evalAtan ty-evalPrim (PrimSinh               ty) = evalSinh ty-evalPrim (PrimCosh               ty) = evalCosh ty-evalPrim (PrimTanh               ty) = evalTanh ty-evalPrim (PrimAsinh              ty) = evalAsinh ty-evalPrim (PrimAcosh              ty) = evalAcosh ty-evalPrim (PrimAtanh              ty) = evalAtanh ty-evalPrim (PrimExpFloating        ty) = evalExpFloating ty-evalPrim (PrimSqrt               ty) = evalSqrt ty-evalPrim (PrimLog                ty) = evalLog ty-evalPrim (PrimFPow               ty) = evalFPow ty-evalPrim (PrimLogBase            ty) = evalLogBase ty-evalPrim (PrimTruncate        ta tb) = evalTruncate ta tb-evalPrim (PrimRound           ta tb) = evalRound ta tb-evalPrim (PrimFloor           ta tb) = evalFloor ta tb-evalPrim (PrimCeiling         ta tb) = evalCeiling ta tb-evalPrim (PrimAtan2              ty) = evalAtan2 ty-evalPrim (PrimIsNaN              ty) = evalIsNaN ty-evalPrim (PrimIsInfinite         ty) = evalIsInfinite ty-evalPrim (PrimLt                 ty) = evalLt ty-evalPrim (PrimGt                 ty) = evalGt ty-evalPrim (PrimLtEq               ty) = evalLtEq ty-evalPrim (PrimGtEq               ty) = evalGtEq ty-evalPrim (PrimEq                 ty) = evalEq ty-evalPrim (PrimNEq                ty) = evalNEq ty-evalPrim (PrimMax                ty) = evalMax ty-evalPrim (PrimMin                ty) = evalMin ty-evalPrim PrimLAnd                    = evalLAnd-evalPrim PrimLOr                     = evalLOr-evalPrim PrimLNot                    = evalLNot-evalPrim PrimOrd                     = evalOrd-evalPrim PrimChr                     = evalChr-evalPrim PrimBoolToInt               = evalBoolToInt-evalPrim (PrimFromIntegral ta tb)    = evalFromIntegral ta tb-evalPrim (PrimToFloating ta tb)      = evalToFloating ta tb-evalPrim PrimCoerce{}                = unsafeCoerce----- Tuple construction and projection--- -----------------------------------evalTuple :: EvalAcc acc -> Tuple (PreOpenExp acc env aenv) t -> ValElt env -> Val aenv -> t-evalTuple _       NilTup            _env _aenv = ()-evalTuple evalAcc (tup `SnocTup` e) env  aenv  =-  (evalTuple evalAcc tup env aenv, evalPreOpenExp evalAcc e env aenv)--evalPrj :: TupleIdx t e -> t -> e-evalPrj ZeroTupIdx       (!_, v)   = v-evalPrj (SuccTupIdx idx) (tup, !_) = evalPrj idx tup-  -- FIXME: Strictly speaking, we ought to force all components of a tuples;-  --        not only those that we happen to encounter during the recursive-  --        walk.----- Implementation of scalar primitives--- -------------------------------------evalLAnd :: (Bool, Bool) -> Bool-evalLAnd (x, y) = x && y--evalLOr  :: (Bool, Bool) -> Bool-evalLOr (x, y) = x || y--evalLNot :: Bool -> Bool-evalLNot = not--evalOrd :: Char -> Int-evalOrd = ord--evalChr :: Int -> Char-evalChr = chr--evalBoolToInt :: Bool -> Int-evalBoolToInt = fromEnum--evalFromIntegral :: IntegralType a -> NumType b -> a -> b-evalFromIntegral ta (IntegralNumType tb)-  | IntegralDict <- integralDict ta-  , IntegralDict <- integralDict tb-  = fromIntegral--evalFromIntegral ta (FloatingNumType tb)-  | IntegralDict <- integralDict ta-  , FloatingDict <- floatingDict tb-  = fromIntegral--evalToFloating :: NumType a -> FloatingType b -> a -> b-evalToFloating (IntegralNumType ta) tb-  | IntegralDict <- integralDict ta-  , FloatingDict <- floatingDict tb-  = realToFrac--evalToFloating (FloatingNumType ta) tb-  | FloatingDict <- floatingDict ta-  , FloatingDict <- floatingDict tb-  = realToFrac----- Extract methods from reified dictionaries------- Constant methods of Bounded-----evalMinBound :: BoundedType a -> a-evalMinBound (IntegralBoundedType ty)-  | IntegralDict <- integralDict ty-  = minBound--evalMinBound (NonNumBoundedType   ty)-  | NonNumDict   <- nonNumDict ty-  = minBound--evalMaxBound :: BoundedType a -> a-evalMaxBound (IntegralBoundedType ty)-  | IntegralDict <- integralDict ty-  = maxBound--evalMaxBound (NonNumBoundedType   ty)-  | NonNumDict   <- nonNumDict ty-  = maxBound---- Constant method of floating-----evalPi :: FloatingType a -> a-evalPi ty | FloatingDict <- floatingDict ty = pi--evalSin :: FloatingType a -> (a -> a)-evalSin ty | FloatingDict <- floatingDict ty = sin--evalCos :: FloatingType a -> (a -> a)-evalCos ty | FloatingDict <- floatingDict ty = cos--evalTan :: FloatingType a -> (a -> a)-evalTan ty | FloatingDict <- floatingDict ty = tan--evalAsin :: FloatingType a -> (a -> a)-evalAsin ty | FloatingDict <- floatingDict ty = asin--evalAcos :: FloatingType a -> (a -> a)-evalAcos ty | FloatingDict <- floatingDict ty = acos--evalAtan :: FloatingType a -> (a -> a)-evalAtan ty | FloatingDict <- floatingDict ty = atan--evalSinh :: FloatingType a -> (a -> a)-evalSinh ty | FloatingDict <- floatingDict ty = sinh--evalCosh :: FloatingType a -> (a -> a)-evalCosh ty | FloatingDict <- floatingDict ty = cosh--evalTanh :: FloatingType a -> (a -> a)-evalTanh ty | FloatingDict <- floatingDict ty = tanh--evalAsinh :: FloatingType a -> (a -> a)-evalAsinh ty | FloatingDict <- floatingDict ty = asinh--evalAcosh :: FloatingType a -> (a -> a)-evalAcosh ty | FloatingDict <- floatingDict ty = acosh--evalAtanh :: FloatingType a -> (a -> a)-evalAtanh ty | FloatingDict <- floatingDict ty = atanh--evalExpFloating :: FloatingType a -> (a -> a)-evalExpFloating ty | FloatingDict <- floatingDict ty = exp--evalSqrt :: FloatingType a -> (a -> a)-evalSqrt ty | FloatingDict <- floatingDict ty = sqrt--evalLog :: FloatingType a -> (a -> a)-evalLog ty | FloatingDict <- floatingDict ty = log--evalFPow :: FloatingType a -> ((a, a) -> a)-evalFPow ty | FloatingDict <- floatingDict ty = uncurry (**)--evalLogBase :: FloatingType a -> ((a, a) -> a)-evalLogBase ty | FloatingDict <- floatingDict ty = uncurry logBase--evalTruncate :: FloatingType a -> IntegralType b -> (a -> b)-evalTruncate ta tb-  | FloatingDict <- floatingDict ta-  , IntegralDict <- integralDict tb-  = truncate--evalRound :: FloatingType a -> IntegralType b -> (a -> b)-evalRound ta tb-  | FloatingDict <- floatingDict ta-  , IntegralDict <- integralDict tb-  = round--evalFloor :: FloatingType a -> IntegralType b -> (a -> b)-evalFloor ta tb-  | FloatingDict <- floatingDict ta-  , IntegralDict <- integralDict tb-  = floor--evalCeiling :: FloatingType a -> IntegralType b -> (a -> b)-evalCeiling ta tb-  | FloatingDict <- floatingDict ta-  , IntegralDict <- integralDict tb-  = ceiling--evalAtan2 :: FloatingType a -> ((a, a) -> a)-evalAtan2 ty | FloatingDict <- floatingDict ty = uncurry atan2--evalIsNaN :: FloatingType a -> (a -> Bool)-evalIsNaN ty | FloatingDict <- floatingDict ty = isNaN--evalIsInfinite :: FloatingType a -> (a -> Bool)-evalIsInfinite ty | FloatingDict <- floatingDict ty = isInfinite----- Methods of Num-----evalAdd :: NumType a -> ((a, a) -> a)-evalAdd (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (+)-evalAdd (FloatingNumType ty) | FloatingDict <- floatingDict ty = uncurry (+)--evalSub :: NumType a -> ((a, a) -> a)-evalSub (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (-)-evalSub (FloatingNumType ty) | FloatingDict <- floatingDict ty = uncurry (-)--evalMul :: NumType a -> ((a, a) -> a)-evalMul (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (*)-evalMul (FloatingNumType ty) | FloatingDict <- floatingDict ty = uncurry (*)--evalNeg :: NumType a -> (a -> a)-evalNeg (IntegralNumType ty) | IntegralDict <- integralDict ty = negate-evalNeg (FloatingNumType ty) | FloatingDict <- floatingDict ty = negate--evalAbs :: NumType a -> (a -> a)-evalAbs (IntegralNumType ty) | IntegralDict <- integralDict ty = abs-evalAbs (FloatingNumType ty) | FloatingDict <- floatingDict ty = abs--evalSig :: NumType a -> (a -> a)-evalSig (IntegralNumType ty) | IntegralDict <- integralDict ty = signum-evalSig (FloatingNumType ty) | FloatingDict <- floatingDict ty = signum--evalQuot :: IntegralType a -> ((a, a) -> a)-evalQuot ty | IntegralDict <- integralDict ty = uncurry quot--evalRem :: IntegralType a -> ((a, a) -> a)-evalRem ty | IntegralDict <- integralDict ty = uncurry rem--evalQuotRem :: IntegralType a -> ((a, a) -> (a, a))-evalQuotRem ty | IntegralDict <- integralDict ty = uncurry quotRem--evalIDiv :: IntegralType a -> ((a, a) -> a)-evalIDiv ty | IntegralDict <- integralDict ty = uncurry div--evalMod :: IntegralType a -> ((a, a) -> a)-evalMod ty | IntegralDict <- integralDict ty = uncurry mod--evalDivMod :: IntegralType a -> ((a, a) -> (a, a))-evalDivMod ty | IntegralDict <- integralDict ty = uncurry divMod--evalBAnd :: IntegralType a -> ((a, a) -> a)-evalBAnd ty | IntegralDict <- integralDict ty = uncurry (.&.)--evalBOr :: IntegralType a -> ((a, a) -> a)-evalBOr ty | IntegralDict <- integralDict ty = uncurry (.|.)--evalBXor :: IntegralType a -> ((a, a) -> a)-evalBXor ty | IntegralDict <- integralDict ty = uncurry xor--evalBNot :: IntegralType a -> (a -> a)-evalBNot ty | IntegralDict <- integralDict ty = complement--evalBShiftL :: IntegralType a -> ((a, Int) -> a)-evalBShiftL ty | IntegralDict <- integralDict ty = uncurry shiftL--evalBShiftR :: IntegralType a -> ((a, Int) -> a)-evalBShiftR ty | IntegralDict <- integralDict ty = uncurry shiftR--evalBRotateL :: IntegralType a -> ((a, Int) -> a)-evalBRotateL ty | IntegralDict <- integralDict ty = uncurry rotateL--evalBRotateR :: IntegralType a -> ((a, Int) -> a)-evalBRotateR ty | IntegralDict <- integralDict ty = uncurry rotateR--evalPopCount :: IntegralType a -> (a -> Int)-evalPopCount ty | IntegralDict <- integralDict ty = popCount--evalCountLeadingZeros :: IntegralType a -> (a -> Int)-#if __GLASGOW_HASKELL__ >= 710-evalCountLeadingZeros ty | IntegralDict <- integralDict ty = countLeadingZeros-#else-evalCountLeadingZeros ty | IntegralDict <- integralDict ty = clz-  where-    clz x = (w-1) - go (w-1)-      where-        go i | i < 0       = i  -- no bit set-             | testBit x i = i-             | otherwise   = go (i-1)-        w = finiteBitSize x-#endif--evalCountTrailingZeros :: IntegralType a -> (a -> Int)-#if __GLASGOW_HASKELL__ >= 710-evalCountTrailingZeros ty | IntegralDict <- integralDict ty = countTrailingZeros-#else-evalCountTrailingZeros ty | IntegralDict <- integralDict ty = ctz-  where-    ctz x = go 0-      where-        go i | i >= w      = i-             | testBit x i = i-             | otherwise   = go (i+1)-        w = finiteBitSize x-#endif---evalFDiv :: FloatingType a -> ((a, a) -> a)-evalFDiv ty | FloatingDict <- floatingDict ty = uncurry (/)--evalRecip :: FloatingType a -> (a -> a)-evalRecip ty | FloatingDict <- floatingDict ty = recip---evalLt :: ScalarType a -> ((a, a) -> Bool)-evalLt (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (<)-evalLt (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (<)-evalLt (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (<)--evalGt :: ScalarType a -> ((a, a) -> Bool)-evalGt (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (>)-evalGt (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (>)-evalGt (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (>)--evalLtEq :: ScalarType a -> ((a, a) -> Bool)-evalLtEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (<=)-evalLtEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (<=)-evalLtEq (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (<=)--evalGtEq :: ScalarType a -> ((a, a) -> Bool)-evalGtEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (>=)-evalGtEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (>=)-evalGtEq (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (>=)--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 (==)--evalNEq :: ScalarType a -> ((a, a) -> Bool)-evalNEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (/=)-evalNEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (/=)-evalNEq (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (/=)--evalMax :: ScalarType a -> ((a, a) -> a)-evalMax (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry max-evalMax (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry max-evalMax (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = uncurry max--evalMin :: ScalarType a -> ((a, a) -> a)-evalMin (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry min-evalMin (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry min-evalMin (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = uncurry min---{----- Sequence evaluation--- ------------------- Position in sequence.----type SeqPos = Int---- Configuration for sequence evaluation.----data SeqConfig = SeqConfig-  { chunkSize :: Int -- Allocation limit for a sequence in-                     -- words. Actual runtime allocation should be the-                     -- maximum of this size and the size of the-                     -- largest element in the sequence.-  }---- Default sequence evaluation configuration for testing purposes.----defaultSeqConfig :: SeqConfig-defaultSeqConfig = SeqConfig { chunkSize = 2 }--type Chunk a = Vector' a---- The empty chunk. O(1).-emptyChunk :: Arrays a => Chunk a-emptyChunk = empty'---- Number of arrays in chunk. O(1).----clen :: Arrays a => Chunk a -> Int-clen = length'--elemsPerChunk :: SeqConfig -> Int -> Int-elemsPerChunk conf n-  | n < 1 = chunkSize conf-  | otherwise =-    let (a,b) = chunkSize conf `quotRem` n-    in a + signum b---- Drop a number of arrays from a chunk. O(1). Note: Require keeping a--- scan of element sizes.----cdrop :: Arrays a => Int -> Chunk a -> Chunk a-cdrop = drop' dropOp (fst . offsetsOp)---- Get all the shapes of a chunk of arrays. O(1).----chunkShapes :: Chunk (Array sh a) -> Vector sh-chunkShapes = shapes'---- Get all the elements of a chunk of arrays. O(1).----chunkElems :: Chunk (Array sh a) -> Vector a-chunkElems = elements'---- Convert a vector to a chunk of scalars.----vec2Chunk :: Elt e => Vector e -> Chunk (Scalar e)-vec2Chunk = vec2Vec'---- Convert a list of arrays to a chunk.----fromListChunk :: Arrays a => [a] -> Vector' a-fromListChunk = fromList' concatOp---- Convert a chunk to a list of arrays.----toListChunk :: Arrays a => Vector' a -> [a]-toListChunk = toList' fetchAllOp---- fmap for Chunk. O(n).---   TODO: Use vectorised function.-mapChunk :: (Arrays a, Arrays b)-         => (a -> b)-         -> Chunk a -> Chunk b-mapChunk f c = fromListChunk $ map f (toListChunk c)---- zipWith for Chunk. O(n).---  TODO: Use vectorised function.-zipWithChunk :: (Arrays a, Arrays b, Arrays c)-             => (a -> b -> c)-             -> Chunk a -> Chunk b -> Chunk c-zipWithChunk f c1 c2 = fromListChunk $ zipWith f (toListChunk c1) (toListChunk c2)---- A window on a sequence.----data Window a = Window-  { chunk :: Chunk a   -- Current allocated chunk.-  , wpos  :: SeqPos    -- Position of the window on the sequence, given-                       -- in number of elements.-  }---- The initial empty window.----window0 :: Arrays a => Window a-window0 = Window { chunk = emptyChunk, wpos = 0 }---- Index the given window by the given index on the sequence.----(!#) :: Arrays a => Window a -> SeqPos -> Chunk a-w !# i-  | j <- i - wpos w-  , j >= 0-  = cdrop j (chunk w)-  ---  | otherwise-  = error $ "Window indexed before position. wpos = " ++ show (wpos w) ++ " i = " ++ show i---- Move the give window by supplying the next chunk.----moveWin :: Arrays a => Window a -> Chunk a -> Window a-moveWin w c = w { chunk = c-                , wpos = wpos w + clen (chunk w)-                }---- A cursor on a sequence.----data Cursor senv a = Cursor-  { ref  :: Idx senv a -- Reference to the sequence.-  , cpos :: SeqPos     -- Position of the cursor on the sequence,-                       -- given in number of elements.-  }---- Initial cursor.----cursor0 :: Idx senv a -> Cursor senv a-cursor0 x = Cursor { ref = x, cpos = 0 }---- Advance cursor by a relative amount.----moveCursor :: Int -> Cursor senv a -> Cursor senv a-moveCursor k c = c { cpos = cpos c + k }---- Valuation for an environment of sequence windows.----data Val' senv where-  Empty' :: Val' ()-  Push'  :: Val' senv -> Window t -> Val' (senv, t)---- Projection of a window from a window valuation using a de Bruijn--- index.----prj' :: Idx senv t -> Val' senv -> Window 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 chunk from a window valuation using a sequence--- cursor.----prjChunk :: Arrays a => Cursor senv a -> Val' senv -> Chunk a-prjChunk c senv = prj' (ref c) senv !# cpos c---- An executable sequence.----data ExecSeq senv arrs where-  ExecP :: Arrays a => Window a -> ExecP senv a -> ExecSeq (senv, a) arrs -> ExecSeq senv  arrs-  ExecC :: Arrays a =>             ExecC senv a ->                           ExecSeq senv  a-  ExecR :: Arrays a =>             Cursor senv a ->                          ExecSeq senv  [a]---- An executable producer.----data ExecP senv a where-  ExecStreamIn :: Int-               -> [a]-               -> ExecP senv a--  ExecMap :: Arrays a-          => (Chunk a -> Chunk b)-          -> Cursor senv a-          -> ExecP senv b--  ExecZipWith :: (Arrays a, Arrays b)-              => (Chunk a -> Chunk b -> Chunk c)-              -> Cursor senv a-              -> Cursor senv b-              -> ExecP senv c--  -- Stream scan skeleton.-  ExecScan :: Arrays a-           => (s -> Chunk a -> (Chunk r, s)) -- Chunk scanner.-           -> s                              -- Accumulator (internal state).-           -> Cursor senv a                  -- Input stream.-           -> ExecP senv r---- An executable consumer.----data ExecC senv a where--  -- Stream reduction skeleton.-  ExecFold :: Arrays a-           => (s -> Chunk a -> s) -- Chunk consumer function.-           -> (s -> r)            -- Finalizer function.-           -> s                   -- Accumulator (internal state).-           -> Cursor senv a       -- Input stream.-           -> ExecC senv r--  ExecStuple :: IsAtuple a-             => Atuple (ExecC senv) (TupleRepr a)-             -> ExecC senv a--minCursor :: ExecSeq senv a -> SeqPos-minCursor s = travS s 0-  where-    travS :: ExecSeq senv a -> Int -> SeqPos-    travS s i =-      case s of-        ExecP _ p s' -> travP p i `min` travS s' (i+1)-        ExecC   c    -> travC c i-        ExecR   _    -> maxBound--    k :: Cursor senv a -> Int -> SeqPos-    k c i-      | i == idxToInt (ref c) = cpos c-      | otherwise             = maxBound--    travP :: ExecP senv a -> Int -> SeqPos-    travP p i =-      case p of-        ExecStreamIn _ _ -> maxBound-        ExecMap _ c -> k c i-        ExecZipWith _ c1 c2 -> k c1 i `min` k c2 i-        ExecScan _ _ c -> k c i--    travT :: Atuple (ExecC senv) t -> Int -> SeqPos-    travT NilAtup        _ = maxBound-    travT (SnocAtup t c) i = travT t i `min` travC c i--    travC :: ExecC senv a -> Int -> SeqPos-    travC c i =-      case c of-        ExecFold _ _ _ cu -> k cu i-        ExecStuple t      -> travT t i---evalDelayedSeq :: SeqConfig-               -> DelayedSeq arrs-               -> arrs-evalDelayedSeq cfg (DelayedSeq aenv s) | aenv' <- evalExtend aenv Empty-                                       = evalSeq cfg s aenv'--evalSeq :: forall aenv arrs.-            SeqConfig-         -> PreOpenSeq DelayedOpenAcc aenv () arrs-         -> Val aenv -> arrs-evalSeq conf s aenv = evalSeq' s-  where-    evalSeq' :: PreOpenSeq DelayedOpenAcc aenv senv arrs -> arrs-    evalSeq' (Producer _ s) = evalSeq' s-    evalSeq' (Consumer _)   = loop (initSeq aenv s)-    evalSeq' (Reify _)      = reify (initSeq aenv s)--    -- Initialize the producers and the accumulators of the consumers-    -- with the given array enviroment.-    initSeq :: forall senv arrs'.-                Val aenv-             -> PreOpenSeq DelayedOpenAcc aenv senv arrs'-             -> ExecSeq senv arrs'-    initSeq aenv s =-      case s of-        Producer   p s' -> ExecP window0 (initProducer p) (initSeq aenv s')-        Consumer   c    -> ExecC         (initConsumer c)-        Reify      ix   -> ExecR (cursor0 ix)--    -- Generate a list from the sequence.-    reify :: forall arrs. ExecSeq () [arrs]-          -> [arrs]-    reify s = case step s Empty' of-                (Just s', a) -> a ++ reify s'-                (Nothing, a) -> a--    -- Iterate the given sequence until it terminates.-    -- A sequence only terminates when one of the producers are exhausted.-    loop :: Arrays arrs-         => ExecSeq () arrs-         -> arrs-    loop s =-      case step' s of-        (Nothing, arrs) -> arrs-        (Just s', _)    -> loop s'--      where-        step' :: ExecSeq () arrs -> (Maybe (ExecSeq () arrs), arrs)-        step' s = step s Empty'--    -- One iteration of a sequence.-    step :: forall senv arrs'.-            ExecSeq senv arrs'-         -> Val' senv-         -> (Maybe (ExecSeq senv arrs'), arrs')-    step s senv =-      case s of-        ExecP w p s' ->-          let (c, mp')  = produce p senv-              finished  = 0 == clen (w !# minCursor s')-              w'        = if finished then moveWin w c else w-              (ms'', a) = step s' (senv `Push'` w')-          in case ms'' of-            Nothing  -> (Nothing, a)-            Just s'' | finished-                     , Just p' <- mp'-                     -> (Just (ExecP w' p' s''), a)-                     | not finished-                     -> (Just (ExecP w' p  s''), a)-                     | otherwise-                     -> (Nothing, a)-        ExecC   c    -> let (c', acc) = consume c senv-                        in (Just (ExecC c'), acc)-        ExecR ix     -> let c = prjChunk ix senv in (Just (ExecR (moveCursor (clen c) ix)), toListChunk c)--    evalA :: DelayedOpenAcc aenv a -> a-    evalA acc = evalOpenAcc acc aenv--    evalAF :: DelayedOpenAfun aenv f -> f-    evalAF f = evalOpenAfun f aenv--    evalE :: DelayedExp aenv t -> t-    evalE exp = evalPreExp evalOpenAcc exp aenv--    evalF :: DelayedFun aenv f -> f-    evalF fun = evalPreFun evalOpenAcc fun aenv--    initProducer :: forall a senv.-                    Producer DelayedOpenAcc aenv senv a-                 -> ExecP senv a-    initProducer p =-      case p of-        StreamIn arrs -> ExecStreamIn 1 arrs-        ToSeq sliceIndex slix (delayed -> Delayed sh ix _) ->-          let n   = R.size (R.sliceShape sliceIndex (fromElt sh))-              k   = elemsPerChunk conf n-          in ExecStreamIn k (toSeqOp sliceIndex slix (fromFunction sh ix))-        MapSeq     f x       -> ExecMap     (mapChunk (evalAF f)) (cursor0 x)-        ChunkedMapSeq f x    -> ExecMap     (evalAF f) (cursor0 x)-        ZipWithSeq f x y     -> ExecZipWith (zipWithChunk (evalAF f)) (cursor0 x) (cursor0 y)-        ScanSeq    f e x     -> ExecScan scanner (evalE e) (cursor0 x)-          where-            scanner a c =-              let v0 = chunkElems c-                  (v1, a') = scanl'Op (evalF f) a (delayArray v0)-              in (vec2Chunk v1, fromScalar a')--    initConsumer :: forall a senv.-                    Consumer DelayedOpenAcc aenv senv a-                 -> ExecC senv a-    initConsumer c =-      case c of-        FoldSeq f e x ->-          let f' = evalF f-              a0 = fromFunction (Z :. chunkSize conf) (const (evalE e))-              consumer v c = zipWith'Op f' (delayArray v) (delayArray (chunkElems c))-              finalizer = fold1Op f' . delayArray-          in ExecFold consumer finalizer a0 (cursor0 x)-        FoldSeqFlatten f acc x ->-          let f' = evalAF f-              a0 = evalA acc-              consumer a c = f' a (chunkShapes c) (chunkElems c)-          in ExecFold consumer id a0 (cursor0 x)-        Stuple t ->-          let initTup :: Atuple (Consumer DelayedOpenAcc aenv senv) t -> Atuple (ExecC senv) t-              initTup NilAtup        = NilAtup-              initTup (SnocAtup t c) = SnocAtup (initTup t) (initConsumer c)-          in ExecStuple (initTup t)--    delayed :: DelayedOpenAcc aenv (Array sh e) -> Delayed (Array sh e)-    delayed AST.Manifest{}  = $internalError "evalOpenAcc" "expected delayed array"-    delayed AST.Delayed{..} = Delayed (evalPreExp evalOpenAcc extentD aenv)-                                      (evalPreFun evalOpenAcc indexD aenv)-                                      (evalPreFun evalOpenAcc linearIndexD aenv)--produce :: Arrays a => ExecP senv a -> Val' senv -> (Chunk a, Maybe (ExecP senv a))-produce p senv =-  case p of-    ExecStreamIn k xs ->-      let (xs', xs'') = (take k xs, drop k xs)-          c           = fromListChunk xs'-          mp          = if null xs''-                        then Nothing-                        else Just (ExecStreamIn k xs'')-      in (c, mp)-    ExecMap f x ->-      let c = prjChunk x senv-      in (f c, Just $ ExecMap f (moveCursor (clen c) x))-    ExecZipWith f x y ->-      let c1 = prjChunk x senv-          c2 = prjChunk y senv-          k = clen c1 `min` clen c2-      in (f c1 c2, Just $ ExecZipWith f (moveCursor k x) (moveCursor k y))-    ExecScan scanner a x ->-      let c = prjChunk x senv-          (c', a') = scanner a c-          k = clen c-      in (c', Just $ ExecScan scanner a' (moveCursor k x))--consume :: forall senv a. ExecC senv a -> Val' senv -> (ExecC senv a, a)-consume c senv =-  case c of-    ExecFold f g acc x ->-      let c    = prjChunk x senv-          acc' = f acc c-      -- Even though we call g here, lazy evaluation should guarantee it is-      -- only ever called once.-      in (ExecFold f g acc' (moveCursor (clen c) x), g acc')-    ExecStuple t ->-      let consT :: Atuple (ExecC senv) t -> (Atuple (ExecC senv) t, t)-          consT NilAtup        = (NilAtup, ())-          consT (SnocAtup t c) | (c', acc) <- consume c senv-                               , (t', acc') <- consT t-                               = (SnocAtup t' c', (acc', acc))-          (t', acc) = consT t-      in (ExecStuple t', toAtuple acc)--evalExtend :: Extend DelayedOpenAcc aenv aenv' -> Val aenv -> Val aenv'-evalExtend BaseEnv aenv = aenv-evalExtend (PushEnv ext1 ext2) aenv | aenv' <- evalExtend ext1 aenv-                                    = Push aenv' (evalOpenAcc ext2 aenv')--delayArray :: Array sh e -> Delayed (Array sh e)-delayArray arr@(Array _ adata) = Delayed (shape arr) (arr!) (toElt . unsafeIndexArrayData adata)--fromScalar :: Scalar a -> a-fromScalar = (!Z)--concatOp :: forall e. Elt e => [Vector e] -> Vector e-concatOp = concatVectors--fetchAllOp :: (Shape sh, Elt e) => Segments sh -> Vector e -> [Array sh e]-fetchAllOp segs elts-  | (offsets, n) <- offsetsOp segs-  , (n ! Z) <= size (shape elts)-  = [fetch (segs ! (Z :. i)) (offsets ! (Z :. i)) | i <- [0 .. size (shape segs) - 1]]-  | otherwise = error $ "illegal argument to fetchAllOp"-  where-    fetch sh offset = fromFunction sh (\ ix -> elts ! (Z :. ((toIndex sh ix) + offset)))--dropOp :: Elt e => Int -> Vector e -> Vector e-dropOp i v   -- TODO-             --  * Implement using C-style pointer-plus.-             --    ; dropOp is used often (from prjChunk),-             --      so it ought to be efficient O(1).-  | n <- size (shape v)-  , i <= n-  , i >= 0-  = fromFunction (Z :. n - i) (\ (Z :. j) -> v ! (Z :. i + j))-  | otherwise = error $ "illegal argument to drop"--offsetsOp :: Shape sh => Segments sh -> (Vector Int, Scalar Int)-offsetsOp segs = scanl'Op (+) 0 $ delayArray (mapOp size (delayArray segs))---}-
− Data/Array/Accelerate/Language.hs 
@@ -1,1373 +0,0 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE ViewPatterns        #-}--- |--- Module      : Data.Array.Accelerate.Language--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell---               [2014..2014] Frederik M. Madsen--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ We use the dictionary view of overloaded operations (such as arithmetic and--- bit manipulation) to reify such expressions.  With non-overloaded--- operations (such as, the logical connectives) and partially overloaded--- operations (such as comparisons), we use the standard operator names with a--- \'*\' attached.  We keep the standard alphanumeric names as they can be--- easily qualified.-----module Data.Array.Accelerate.Language (--  -- * Array and scalar expressions-  Acc, Exp,                                 -- re-exporting from 'Smart'--  -- * Scalar introduction-  constant,                                 -- re-exporting from 'Smart'--  -- * Array construction-  use, unit, replicate, generate,--  -- * Shape manipulation-  reshape,--  -- * Extraction of sub-arrays-  slice,--  -- * Map-like functions-  map, zipWith,--  -- -- * Sequence collection-  -- collect,--  -- -- * Sequence producers-  -- streamIn, toSeq,--  -- -- * Sequence transducers-  -- mapSeq, zipWithSeq, scanSeq,--  -- -- * Sequence consumers-  -- foldSeq, foldSeqFlatten,--  -- * Reductions-  fold, fold1, foldSeg, fold1Seg,--  -- * Scan functions-  scanl, scanl', scanl1, scanr, scanr', scanr1,--  -- * Permutations-  permute, backpermute,--  -- * Stencil operations-  stencil, stencil2,--  -- ** Stencil specification-  Boundary, Stencil,-  clamp, mirror, wrap, function,---  -- ** Common stencil types-  Stencil3, Stencil5, Stencil7, Stencil9,-  Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5,-  Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,-  Stencil3x5x5, Stencil5x5x5,--  -- * Foreign functions-  foreignAcc,-  foreignExp,--  -- * Pipelining-  (>->),--  -- * Index construction and destruction-  indexHead, indexTail, toIndex, fromIndex,-  intersect, union,--  -- * Flow-control-  acond, awhile,-  cond,  while,--  -- * Array operations with a scalar result-  (!), (!!), shape, size, shapeSize,--  -- * Numeric functions-  subtract, even, odd, gcd, lcm, (^), (^^),--  -- * Conversions-  ord, chr, boolToInt, bitcast,--  -- * Constants-  ignore--) where---- friends-import Data.Array.Accelerate.Array.Sugar                            hiding ( (!), ignore, shape, size, toIndex, fromIndex, intersect, union )-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type-import qualified Data.Array.Accelerate.Array.Sugar                  as Sugar--import Data.Array.Accelerate.Classes.Eq-import Data.Array.Accelerate.Classes.Fractional-import Data.Array.Accelerate.Classes.Integral-import Data.Array.Accelerate.Classes.Num-import Data.Array.Accelerate.Classes.Ord---- standard libraries-import Prelude                                                      ( ($), (.) )----- Array introduction--- ---------------------- | Make an array from vanilla Haskell available for processing within embedded--- Accelerate computations.------ Depending upon which backend is used to eventually execute array--- computations, 'use' may entail data transfer (e.g. to a GPU).------ 'use' is overloaded so that it can accept tuples of 'Arrays':------ >>> let vec = fromList (Z:.10) [0..]  :: Array DIM1 Int--- Vector (Z :. 10) [0,1,2,3,4,5,6,7,8,9]------ >>> let mat = fromList (Z:.5:.10) [0..]  :: Array DIM2 Int--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> let vec' = use vec         :: Acc (Array DIM1 Int)--- >>> let mat' = use mat         :: Acc (Array DIM2 Int)--- >>> let tup  = use (vec, mat)  :: Acc (Array DIM1 Int, Array DIM2 Int)----use :: Arrays arrays => arrays -> Acc arrays-use = Acc . Use---- | Construct a singleton (one element) array from a scalar value (or tuple of--- scalar values).----unit :: Elt e => Exp e -> Acc (Scalar e)-unit = Acc . Unit---- | Replicate an array across one or more dimensions as specified by the--- /generalised/ array index provided as the first argument.------ For example, given the following vector:------ >>> let vec = fromList (Z:.10) [0..]--- Vector (Z :. 10) [0,1,2,3,4,5,6,7,8,9]------ ...we can replicate these elements to form a two-dimensional array either by--- replicating those elements as new rows:------ >>> replicate (lift (Z :. 4 :. All)) (use vec)--- Matrix (Z :. 4 :. 10)---   [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,---     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,---     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,---     0, 1, 2, 3, 4, 5, 6, 7, 8, 9]------ ...or as columns:------ >>> replicate (lift (Z :. All :. 4)) (use vec)--- Matrix (Z :. 10 :. 4)---   [ 0, 0, 0, 0,---     1, 1, 1, 1,---     2, 2, 2, 2,---     3, 3, 3, 3,---     4, 4, 4, 4,---     5, 5, 5, 5,---     6, 6, 6, 6,---     7, 7, 7, 7,---     8, 8, 8, 8,---     9, 9, 9, 9]------ Replication along more than one dimension is also possible. Here we replicate--- twice across the first dimension and three times across the third dimension:------ >>> replicate (lift (Z :. 2 :. All :. 3)) (use vec)--- Array (Z :. 2 :. 10 :. 3) [0,0,0,1,1,1,2,2,2,3,3,3,4,4,4,5,5,5,6,6,6,7,7,7,8,8,8,9,9,9,0,0,0,1,1,1,2,2,2,3,3,3,4,4,4,5,5,5,6,6,6,7,7,7,8,8,8,9,9,9]------ The marker 'Any' can be used in the slice specification to match against some--- arbitrary dimension. For example, here 'Any' matches against whatever shape--- type variable @sh@ takes.------ > rep0 :: (Shape sh, Elt e) => Exp Int -> Acc (Array sh e) -> Acc (Array (sh :. Int) e)--- > rep0 n a = replicate (lift (Any :. n)) a------ >>> let x = unit 42  :: Acc (Scalar Int)--- >>> rep0 10 x--- Vector (Z :. 10) [42,42,42,42,42,42,42,42,42,42]------ >>> rep0 5 (use vec)--- Matrix (Z :. 10 :. 5)---   [ 0, 0, 0, 0, 0,---     1, 1, 1, 1, 1,---     2, 2, 2, 2, 2,---     3, 3, 3, 3, 3,---     4, 4, 4, 4, 4,---     5, 5, 5, 5, 5,---     6, 6, 6, 6, 6,---     7, 7, 7, 7, 7,---     8, 8, 8, 8, 8,---     9, 9, 9, 9, 9]------ Of course, 'Any' and 'All' can be used together.------ > rep1 :: (Shape sh, Elt e) => Exp Int -> Acc (Array (sh :. Int) e) -> Acc (Array (sh :. Int :. Int) e)--- > rep1 n a = A.replicate (lift (Any :. n :. All)) a------ >>> rep1 5 (use vec)--- Matrix (Z :. 5 :. 10)---   [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,---     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,---     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,---     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,---     0, 1, 2, 3, 4, 5, 6, 7, 8, 9]----replicate-    :: (Slice slix, Elt e)-    => Exp slix-    -> Acc (Array (SliceShape slix) e)-    -> Acc (Array (FullShape  slix) e)-replicate = Acc $$ Replicate---- | Construct a new array by applying a function to each index.------ For example, the following will generate a one-dimensional array--- (`Vector`) of three floating point numbers:------ >>> generate (index1 3) (\_ -> 1.2)--- Vector (Z :. 3) [1.2,1.2,1.2]------ Or equivalently:------ >>> fill (constant (Z :. 3)) 1.2--- Vector (Z :. 3) [1.2,1.2,1.2]------ The following will create a vector with the elements @[1..10]@:------ >>> generate (index1 10) (\ix -> unindex1 ix + 1)--- Vector (Z :. 10) [1,2,3,4,5,6,7,8,9,10]------ [/NOTE:/]------ Using 'generate', it is possible to introduce nested data parallelism, which--- will cause the program to fail.------ If the index given by the scalar function is then used to dispatch further--- parallel work, whose result is returned into 'Exp' terms by array indexing--- operations such as ('!') or 'Data.Array.Accelerate.Prelude.the', the program--- will fail with the error:--- '.\/Data\/Array\/Accelerate\/Trafo\/Sharing.hs:447 (convertSharingExp): inconsistent valuation \@ shared \'Exp\' tree ...'.----generate-    :: (Shape sh, Elt a)-    => Exp sh-    -> (Exp sh -> Exp a)-    -> Acc (Array sh a)-generate = Acc $$ Generate---- Shape manipulation--- ---------------------- | Change the shape of an array without altering its contents. The 'size' of--- the source and result arrays must be identical.------ > precondition: shapeSize sh == shapeSize sh'------ If the argument array is manifest in memory, 'reshape' is a no-op. If the--- argument is to be fused into a subsequent operation, 'reshape' corresponds to--- an index transformation in the fused code.----reshape-    :: (Shape sh, Shape sh', Elt e)-    => Exp sh-    -> Acc (Array sh' e)-    -> Acc (Array sh e)-reshape = Acc $$ Reshape---- Extraction of sub-arrays--- ---------------------------- | Index an array with a /generalised/ array index, supplied as the second--- argument. The result is a new array (possibly a singleton) containing the--- selected dimensions ('All's) in their entirety.------ 'slice' is the opposite of 'replicate', and can be used to /cut out/ entire--- dimensions. For example, for the two dimensional array 'mat':------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ ...will can select a specific row to yield a one dimensional result by fixing--- the row index (2) while allowing the column index to vary (via 'All'):------ >>> slice (use mat) (lift (Z :. 2 :. All))--- Vector (Z :. 10) [20,21,22,23,24,25,26,27,28,29]------ A fully specified index (with no 'All's) returns a single element (zero--- dimensional array).------ >>> slice (use mat) (lift (Z :. 4 :. 2))--- Scalar Z [42]------ The marker 'Any' can be used in the slice specification to match against some--- arbitrary (lower) dimension. Here 'Any' matches whatever shape type variable--- @sh@ takes:------ > sl0 :: (Shape sh, Elt e) => Acc (Array (sh:.Int) e) -> Exp Int -> Acc (Array sh e)--- > sl0 a n = A.slice a (lift (Any :. n))------ >>> let vec = fromList (Z:.10) [0..]--- >>> sl0 (use vec) 4--- Scalar Z [4]------ >>> sl0 (use mat) 4--- Vector (Z :. 5) [4,14,24,34,44]------ Of course, 'Any' and 'All' can be used together.------ > sl1 :: (Shape sh, Elt e) => Acc (Array (sh:.Int:.Int) e) -> Exp Int -> Acc (Array (sh:.Int) e)--- > sl1 a n = A.slice a (lift (Any :. n :. All))------ >>> sl1 (use mat) 4--- Vector (Z :. 10) [40,41,42,43,44,45,46,47,48,49]------ >>> let cube = fromList (Z:.3:.4:.5) [0..]--- >>> cube--- Array (Z :. 3 :. 4 :. 5) [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59]------ >>> sl1 (use cube) 2--- Matrix (Z :. 3 :. 5)---   [ 10, 11, 12, 13, 14,---     30, 31, 32, 33, 34,---     50, 51, 52, 53, 54]----slice :: (Slice slix, Elt e)-      => Acc (Array (FullShape slix) e)-      -> Exp slix-      -> Acc (Array (SliceShape slix) e)-slice = Acc $$ Slice---- Map-like functions--- ---------------------- | Apply the given function element-wise to an array. Denotationally we have:------ > map f [x1, x2, ... xn] = [f x1, f x2, ... f xn]------ >>> let xs = fromList (Z:.10) [0..]--- >>> xs--- Vector (Z :. 10) [0,1,2,3,4,5,6,7,8,9]------ >>> map (+1) (use xs)--- Vector (Z :. 10) [1,2,3,4,5,6,7,8,9,10]----map :: (Shape sh, Elt a, Elt b)-    => (Exp a -> Exp b)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-map = Acc $$ Map---- | Apply the given binary function element-wise to the two arrays. The extent--- of the resulting array is the intersection of the extents of the two source--- arrays.------ >>> let xs = fromList (Z:.3:.5) [0..]--- >>> xs--- Matrix (Z :. 3 :. 5)---   [ 0, 1, 2, 3, 4,---     5, 6, 7, 8, 9,---    10,11,12,13,14]------ >>> let ys = fromList (Z:.5:.10) [1..]--- >>> ys--- Matrix (Z :. 5 :. 10)---   [ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,---    11,12,13,14,15,16,17,18,19,20,---    21,22,23,24,25,26,27,28,29,30,---    31,32,33,34,35,36,37,38,39,40,---    41,42,43,44,45,46,47,48,49,50]------ >>> zipWith (+) (use xs) (use ys)--- Matrix (Z :. 3 :. 5)---   [ 1, 3, 5, 7, 9,---    16,18,20,22,24,---    31,33,35,37,39]----zipWith :: (Shape sh, Elt a, Elt b, Elt c)-        => (Exp a -> Exp b -> Exp c)-        -> Acc (Array sh a)-        -> Acc (Array sh b)-        -> Acc (Array sh c)-zipWith = Acc $$$ ZipWith---- Reductions--- -------------- | Reduction of the innermost dimension of an array of arbitrary rank.  The--- first argument needs to be an /associative/ function to enable an efficient--- parallel implementation. The initial element does not need to be an identity--- element of the combination function.------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> fold (+) 42 (use mat)--- Vector (Z :. 5) [87,187,287,387,487]------ Reductions with non-commutative operators are supported. For example, the--- following computes the maximum segment sum problem along each innermost--- dimension of the array.------ <https://en.wikipedia.org/wiki/Maximum_subarray_problem>------ > maximumSegmentSum--- >     :: forall sh e. (Shape sh, Num e, Ord e)--- >     => Acc (Array (sh :. Int) e)--- >     -> Acc (Array sh e)--- > maximumSegmentSum--- >   = map (\v -> let (x,_,_,_) = unlift v :: (Exp e, Exp e, Exp e, Exp e) in x)--- >   . fold1 f--- >   . map g--- >   where--- >     f :: (Num a, Ord a) => Exp (a,a,a,a) -> Exp (a,a,a,a) -> Exp (a,a,a,a)--- >     f x y =--- >       let (mssx, misx, mcsx, tsx) = unlift x--- >           (mssy, misy, mcsy, tsy) = unlift y--- >       in--- >       lift ( mssx `max` (mssy `max` (mcsx+misy))--- >            , misx `max` (tsx+misy)--- >            , mcsy `max` (mcsx+tsy)--- >            , tsx+tsy--- >            )--- >--- >     g :: (Num a, Ord a) => Exp a -> Exp (a,a,a,a)--- >     g x = let y = max x 0--- >           in  lift (y,y,y,x)------ >>> let vec = fromList (Z:.10) [-2,1,-3,4,-1,2,1,-5,4,0]--- >>> maximumSegmentSum (use vec)--- Scalar Z [6]------ See also 'Data.Array.Accelerate.Data.Fold.Fold', which can be a useful way to--- compute multiple results from a single reduction.----fold :: (Shape sh, Elt a)-     => (Exp a -> Exp a -> Exp a)-     -> Exp a-     -> Acc (Array (sh:.Int) a)-     -> Acc (Array sh a)-fold = Acc $$$ Fold---- | Variant of 'fold' that requires the reduced array to be non-empty and--- doesn't need an default value.  The first argument needs to be an--- /associative/ function to enable an efficient parallel implementation. The--- initial element does not need to be an identity element.----fold1 :: (Shape sh, Elt a)-      => (Exp a -> Exp a -> Exp a)-      -> Acc (Array (sh:.Int) a)-      -> Acc (Array sh a)-fold1 = Acc $$ Fold1---- | Segmented reduction along the innermost dimension of an array. The segment--- descriptor specifies the lengths of the logical sub-arrays, each of which is--- reduced independently. The innermost dimension must contain at least as many--- elements as required by the segment descriptor (sum thereof).------ >>> let seg = fromList (Z:.4) [1,4,0,3]--- >>> seg--- Vector (Z :. 4) [1,4,0,3]------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> foldSeg (+) 0 (use mat) (use seg)--- Matrix (Z :. 5 :. 4)---   [  0,  10, 0,  18,---     10,  50, 0,  48,---     20,  90, 0,  78,---     30, 130, 0, 108,---     40, 170, 0, 138]----foldSeg-    :: (Shape sh, Elt a, Elt i, IsIntegral i)-    => (Exp a -> Exp a -> Exp a)-    -> Exp a-    -> Acc (Array (sh:.Int) a)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) a)-foldSeg = Acc $$$$ FoldSeg---- | Variant of 'foldSeg' that requires /all/ segments of the reduced array to--- be non-empty and doesn't need a default value. The segment descriptor--- specifies the length of each of the logical sub-arrays.----fold1Seg-    :: (Shape sh, Elt a, Elt i, IsIntegral i)-    => (Exp a -> Exp a -> Exp a)-    -> Acc (Array (sh:.Int) a)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) a)-fold1Seg = Acc $$$ Fold1Seg---- Scan functions--- ------------------ | Data.List style left-to-right scan along the innermost dimension of an--- arbitrary rank array. The first argument needs to be an /associative/--- function to enable efficient parallel implementation. The initial value--- (second argument) may be arbitrary.------ >>> scanl (+) 10 (use $ fromList (Z :. 10) [0..])--- Array (Z :. 11) [10,10,11,13,16,20,25,31,38,46,55]------ >>> scanl (+) 0 (use $ fromList (Z :. 4 :. 10) [0..])--- Matrix (Z :. 4 :. 11)---   [ 0,  0,  1,  3,   6,  10,  15,  21,  28,  36,  45,---     0, 10, 21, 33,  46,  60,  75,  91, 108, 126, 145,---     0, 20, 41, 63,  86, 110, 135, 161, 188, 216, 245,---     0, 30, 61, 93, 126, 160, 195, 231, 268, 306, 345]----scanl :: (Shape sh, Elt a)-      => (Exp a -> Exp a -> Exp a)-      -> Exp a-      -> Acc (Array (sh:.Int) a)-      -> Acc (Array (sh:.Int) a)-scanl = Acc $$$ Scanl---- | Variant of 'scanl', where the last element (final reduction result) along--- each dimension is returned separately. Denotationally we have:------ > scanl' f e arr = (init res, unit (res!len))--- >   where--- >     len = shape arr--- >     res = scanl f e arr------ >>> let (res,sum) = scanl' (+) 0 (use $ fromList (Z:.10) [0..])--- >>> res--- Vector (Z :. 10) [0,0,1,3,6,10,15,21,28,36]--- >>> sum--- Scalar Z [45]------ >>> let (res,sums) = scanl' (+) 0 (use $ fromList (Z:.4:.10) [0..])--- >>> res--- Matrix (Z :. 4 :. 10)---   [ 0,  0,  1,  3,   6,  10,  15,  21,  28,  36,---     0, 10, 21, 33,  46,  60,  75,  91, 108, 126,---     0, 20, 41, 63,  86, 110, 135, 161, 188, 216,---     0, 30, 61, 93, 126, 160, 195, 231, 268, 306]--- >>> sums--- Vector (Z :. 4) [45,145,245,345]----scanl' :: (Shape sh, Elt a)-       => (Exp a -> Exp a -> Exp a)-       -> Exp a-       -> Acc (Array (sh:.Int) a)-       -> Acc (Array (sh:.Int) a, Array sh a)-scanl' = Acc $$$ Scanl'---- | Data.List style left-to-right scan along the innermost dimension without an--- initial value (aka inclusive scan). The array must not be empty. The first--- argument needs to be an /associative/ function. Denotationally, we have:------ > scanl1 f e arr = tail (scanl f e arr)------ >>> let mat = fromList (Z:.4:.10) [0..]--- >>> scanl (+) (use mat)--- Matrix (Z :. 4 :. 10)---   [  0,  1,  3,   6,  10,  15,  21,  28,  36,  45,---     10, 21, 33,  46,  60,  75,  91, 108, 126, 145,---     20, 41, 63,  86, 110, 135, 161, 188, 216, 245,---     30, 61, 93, 126, 160, 195, 231, 268, 306, 345]----scanl1 :: (Shape sh, Elt a)-       => (Exp a -> Exp a -> Exp a)-       -> Acc (Array (sh:.Int) a)-       -> Acc (Array (sh:.Int) a)-scanl1 = Acc $$ Scanl1---- | Right-to-left variant of 'scanl'.----scanr :: (Shape sh, Elt a)-      => (Exp a -> Exp a -> Exp a)-      -> Exp a-      -> Acc (Array (sh:.Int) a)-      -> Acc (Array (sh:.Int) a)-scanr = Acc $$$ Scanr---- | Right-to-left variant of 'scanl''.----scanr' :: (Shape sh, Elt a)-       => (Exp a -> Exp a -> Exp a)-       -> Exp a-       -> Acc (Array (sh:.Int) a)-       -> Acc (Array (sh:.Int) a, Array sh a)-scanr' = Acc $$$ Scanr'---- | Right-to-left variant of 'scanl1'.----scanr1 :: (Shape sh, Elt a)-       => (Exp a -> Exp a -> Exp a)-       -> Acc (Array (sh:.Int) a)-       -> Acc (Array (sh:.Int) a)-scanr1 = Acc $$ Scanr1---- Permutations--- ---------------- | Generalised forward permutation operation (array scatter).------ Forward permutation specified by a function mapping indices from the source--- array to indices in the result array. The result array is initialised with--- the given defaults and any further values that are permuted into the result--- array are added to the current value using the given combination function.------ The combination function must be /associative/ and /commutative/. Elements--- that are mapped to the magic value 'ignore' by the permutation function are--- dropped.------ The combination function is given the new value being permuted as its first--- argument, and the current value of the array as its second.------ For example, we can use 'permute' to compute the occurrence count (histogram)--- for an array of values in the range @[0,10)@:------ > histogram :: Acc (Vector Int) -> Acc (Vector Int)--- > histogram xs =--- >   let zeros = fill (constant (Z:.10)) 0--- >       ones  = fill (shape xs)         1--- >   in--- >   permute (+) zeros (\ix -> index1 (xs!ix)) ones------ >>> let xs = fromList (Z :. 20) [0,0,1,2,1,1,2,4,8,3,4,9,8,3,2,5,5,3,1,2]--- >>> histogram (use xs)--- Vector (Z :. 10) [2,4,4,3,2,2,0,0,2,1]------ As a second example, note that the dimensionality of the source and--- destination arrays can differ. In this way, we can use 'permute' to create an--- identity matrix by overwriting elements along the diagonal:------ > identity :: Num a => Exp Int -> Acc (Array DIM2 a)--- > identity n =--- >   let zeros = fill (index2 n n) 0--- >       ones  = fill (index1 n)   1--- >   in--- >   permute const zeros (\(unindex1 -> i) -> index2 i i) ones------ >>> identity 5--- Matrix (Z :. 5 :. 5)---   [1,0,0,0,0,---    0,1,0,0,0,---    0,0,1,0,0,---    0,0,0,1,0,---    0,0,0,0,1]------ [/Note:/]------ Regarding array fusion:------   1. The 'permute' operation will always be evaluated; it can not be fused---      into a later step.------   2. Since the index permutation function might not cover all positions in---      the output array (the function is not surjective), the array of default---      values must be evaluated. However, other operations may fuse into this.------   3. The array of source values can fuse into the permutation operation.------   4. If the array of default values is only used once, it will be updated---      in-place.----permute-    :: (Shape sh, Shape sh', Elt a)-    => (Exp a -> Exp a -> Exp a)        -- ^ combination function-    -> Acc (Array sh' a)                -- ^ array of default values-    -> (Exp sh -> Exp sh')              -- ^ index permutation function-    -> Acc (Array sh  a)                -- ^ array of source values to be permuted-    -> Acc (Array sh' a)-permute = Acc $$$$ Permute---- | Generalised backward permutation operation (array gather).------ Backward permutation specified by a function mapping indices in the--- destination array to indices in the source array. Elements of the output--- array are thus generated by reading from the corresponding index in the--- source array.------ For example, backpermute can be used to--- 'Data.Array.Accelerate.Prelude.transpose' a matrix; at every index @Z:.y:.x@--- in the result array, we get the value at that index by reading from the--- source array at index @Z:.x:.y@:------ > swap :: Exp DIM2 -> Exp DIM2--- > swap = lift1 $ \(Z:.y:.x) -> Z:.x:.y------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> let mat' = use mat--- >>> backpermute (swap (shape mat')) swap mat'--- Matrix (Z :. 10 :. 5)---   [ 0, 10, 20, 30, 40,---     1, 11, 21, 31, 41,---     2, 12, 22, 32, 42,---     3, 13, 23, 33, 43,---     4, 14, 24, 34, 44,---     5, 15, 25, 35, 45,---     6, 16, 26, 36, 46,---     7, 17, 27, 37, 47,---     8, 18, 28, 38, 48,---     9, 19, 29, 39, 49]----backpermute-    :: (Shape sh, Shape sh', Elt a)-    => Exp sh'                          -- ^ shape of the result array-    -> (Exp sh' -> Exp sh)              -- ^ index permutation function-    -> Acc (Array sh  a)                -- ^ source array-    -> Acc (Array sh' a)-backpermute = Acc $$$ Backpermute----- Stencil operations--- ---------------------- Common stencil types------- DIM1 stencil type-type Stencil3 a = (Exp a, Exp a, Exp a)-type Stencil5 a = (Exp a, Exp a, Exp a, Exp a, Exp a)-type Stencil7 a = (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)-type Stencil9 a = (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)---- DIM2 stencil type-type Stencil3x3 a = (Stencil3 a, Stencil3 a, Stencil3 a)-type Stencil5x3 a = (Stencil5 a, Stencil5 a, Stencil5 a)-type Stencil3x5 a = (Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a)-type Stencil5x5 a = (Stencil5 a, Stencil5 a, Stencil5 a, Stencil5 a, Stencil5 a)---- DIM3 stencil type-type Stencil3x3x3 a = (Stencil3x3 a, Stencil3x3 a, Stencil3x3 a)-type Stencil5x3x3 a = (Stencil5x3 a, Stencil5x3 a, Stencil5x3 a)-type Stencil3x5x3 a = (Stencil3x5 a, Stencil3x5 a, Stencil3x5 a)-type Stencil3x3x5 a = (Stencil3x3 a, Stencil3x3 a, Stencil3x3 a, Stencil3x3 a, Stencil3x3 a)-type Stencil5x5x3 a = (Stencil5x5 a, Stencil5x5 a, Stencil5x5 a)-type Stencil5x3x5 a = (Stencil5x3 a, Stencil5x3 a, Stencil5x3 a, Stencil5x3 a, Stencil5x3 a)-type Stencil3x5x5 a = (Stencil3x5 a, Stencil3x5 a, Stencil3x5 a, Stencil3x5 a, Stencil3x5 a)-type Stencil5x5x5 a = (Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, Stencil5x5 a)----- | Map a stencil over an array. In contrast to 'map', the domain of a stencil--- function is an entire /neighbourhood/ of each array element. Neighbourhoods--- are sub-arrays centred around a focal point. They are not necessarily--- rectangular, but they are symmetric and have an extent of at least three--- along each axis. Due to the symmetry requirement the extent is necessarily--- odd. The focal point is the array position that is determined by the stencil.------ For those array positions where the neighbourhood extends past the boundaries--- of the source array, a boundary condition determines the contents of the--- out-of-bounds neighbourhood positions.------ Stencil neighbourhoods are specified via nested tuples, where the nesting--- depth is equal to the dimensionality of the array. For example, a 3x1 stencil--- for a one-dimensional array:------ > s31 :: Stencil3 a -> Exp a--- > s31 (l,c,r) = ...------ ...where @c@ is the focal point of the stencil, and @l@ and @r@ represent the--- elements to the left and right of the focal point, respectively. Similarly,--- a 3x3 stencil for a two-dimensional array:------ > s33 :: Stencil3x3 a -> Exp a--- > s33 ((_,t,_)--- >     ,(l,c,r)--- >     ,(_,b,_)) = ...------ ...where @c@ is again the focal point and @t@, @b@, @l@ and @r@ are the--- elements to the top, bottom, left, and right of the focal point, respectively--- (the diagonal elements have been elided).------ For example, the following computes a 5x5--- <https://en.wikipedia.org/wiki/Gaussian_blur Gaussian blur> as a separable--- 2-pass operation.------ > type Stencil5x1 a = (Stencil3 a, Stencil5 a, Stencil3 a)--- > type Stencil1x5 a = (Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a)--- >--- > convolve5x1 :: Num a => [Exp a] -> Stencil5x1 a -> Exp a--- > convolve5x1 kernel (_, (a,b,c,d,e), _)--- >   = Prelude.sum $ Prelude.zipWith (*) kernel [a,b,c,d,e]--- >--- > convolve1x5 :: Num a => [Exp a] -> Stencil1x5 a -> Exp a--- > convolve1x5 kernel ((_,a,_), (_,b,_), (_,c,_), (_,d,_), (_,e,_))--- >   = Prelude.sum $ Prelude.zipWith (*) kernel [a,b,c,d,e]--- >--- > gaussian = [0.06136,0.24477,0.38774,0.24477,0.06136]--- >--- > blur :: Num a => Acc (Array DIM2 a) -> Acc (Array DIM2 a)--- > blur = stencil (convolve5x1 gaussian) clamp--- >      . stencil (convolve1x5 gaussian) clamp----stencil-    :: (Stencil sh a stencil, Elt b)-    => (stencil -> Exp b)                     -- ^ stencil function-    -> Boundary (Array sh a)                  -- ^ boundary condition-    -> Acc (Array sh a)                       -- ^ source array-    -> Acc (Array sh b)                       -- ^ destination array-stencil f (Boundary b) a = Acc $ Stencil f b a---- | Map a binary stencil of an array. The extent of the resulting array is the--- intersection of the extents of the two source arrays. This is the stencil--- equivalent of 'zipWith'.----stencil2-    :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c)-    => (stencil1 -> stencil2 -> Exp c)        -- ^ binary stencil function-    -> Boundary (Array sh a)                  -- ^ boundary condition #1-    -> Acc (Array sh a)                       -- ^ source array #1-    -> Boundary (Array sh b)                  -- ^ boundary condition #2-    -> Acc (Array sh b)                       -- ^ source array #2-    -> Acc (Array sh c)                       -- ^ destination array-stencil2 f (Boundary b1) a1 (Boundary b2) a2 = Acc $ Stencil2 f b1 a1 b2 a2---- | Boundary condition where elements of the stencil which would be--- out-of-bounds are instead clamped to the edges of the array.------ In the following 3x3 stencil, the out-of-bounds element @b@ will instead--- return the value at position @c@:------ >   +------------+--- >   |a           |--- >  b|cd          |--- >   |e           |--- >   +------------+----clamp :: Boundary (Array sh e)-clamp = Boundary Clamp---- | Stencil boundary condition where coordinates beyond the array extent are--- instead mirrored------ In the following 5x3 stencil, the out-of-bounds element @c@ will instead--- return the value at position @d@, and similarly the element at @b@ will--- return the value at @e@:------ >   +------------+--- >   |a           |--- > bc|def         |--- >   |g           |--- >   +------------+----mirror :: Boundary (Array sh e)-mirror = Boundary Mirror---- | Stencil boundary condition where coordinates beyond the array extent--- instead wrap around the array.------ In the following 3x3 stencil, the out of bounds elements will be read as in--- the pattern on the right.------ >  a bc--- >   +------------+      +------------+--- >  d|ef          |      |ef         d|--- >  g|hi          |  ->  |hi         g|--- >   |            |      |bc         a|--- >   +------------+      +------------+----wrap :: Boundary (Array sh e)-wrap = Boundary Wrap---- | Stencil boundary condition where the given function is applied to any--- outlying coordinates.----function-    :: (Shape sh, Elt e)-    => (Exp sh -> Exp e)-    -> Boundary (Array sh e)-function = Boundary . Function---{----- Sequence operations--- ---------------------- Common sequence types-----streamIn :: Arrays a-         => [a]-         -> Seq [a]-streamIn arrs = Seq (StreamIn arrs)---- | Convert the given array to a sequence by dividing the array up into subarrays.--- The first argument captures how to the division should be performed. The--- presence of `All` in the division descriptor indicates that elements in the--- corresponding dimension should be retained in the subarrays, whereas `Split`--- indicates that the input array should divided along this dimension.----toSeq :: (Division slsix, Elt a)-      => slsix-      -> Acc (Array (FullShape (DivisionSlice slsix)) a)-      -> Seq [Array (SliceShape (DivisionSlice slsix)) a]-toSeq spec acc = Seq (ToSeq spec acc)---- | Apply the given array function element-wise to the given sequence.----mapSeq :: (Arrays a, Arrays b)-       => (Acc a -> Acc b)-       -> Seq [a]-       -> Seq [b]-mapSeq = Seq $$ MapSeq---- | Apply the given binary function element-wise to the two sequences.  The length of the resulting--- sequence is the minumum of the lengths of the two source sequences.----zipWithSeq :: (Arrays a, Arrays b, Arrays c)-           => (Acc a -> Acc b -> Acc c)-           -> Seq [a]-           -> Seq [b]-           -> Seq [c]-zipWithSeq = Seq $$$ ZipWithSeq---- | scanSeq (+) a0 x seq. 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 a-        => (Exp a -> Exp a -> Exp a)-        -> Exp a-        -> Seq [Scalar a]-        -> Seq [Scalar a]-scanSeq = Seq $$$ ScanSeq---- | foldSeq (+) a0 x seq. 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-        => (Exp a -> Exp a -> Exp a)-        -> Exp a-        -> Seq [Scalar a]-        -> Seq (Scalar a)-foldSeq = Seq $$$ FoldSeq---- | foldSeqFlatten f a0 x seq. 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 jx, Elt b)-               => (Acc a -> Acc (Vector jx) -> Acc (Vector b) -> Acc a)-               -> Acc a-               -> Seq [Array jx b]-               -> Seq a-foldSeqFlatten = Seq $$$ FoldSeqFlatten--collect :: Arrays arrs => Seq arrs -> Acc arrs-collect = Acc . Collect---}---- Foreign function calling--- ---------------------------- | Call a foreign array function.------ The form the first argument takes is dependent on the backend being targeted.--- Note that the foreign function only has access to the input array(s) passed--- in as its argument.------ In case the operation is being executed on a backend which does not support--- this foreign implementation, the fallback implementation is used instead,--- which itself could be a foreign implementation for a (presumably) different--- backend, or an implementation in pure Accelerate. In this way, multiple--- foreign implementations can be supplied, and will be tested for suitability--- against the target backend in sequence.------ For an example see the <https://hackage.haskell.org/package/accelerate-fft accelerate-fft> package.----foreignAcc-    :: (Arrays as, Arrays bs, Foreign asm)-    => asm (as -> bs)-    -> (Acc as -> Acc bs)-    -> Acc as-    -> Acc bs-foreignAcc = Acc $$$ Aforeign---- | Call a foreign scalar expression.------ The form of the first argument is dependent on the backend being targeted.--- Note that the foreign function only has access to the input element(s) passed--- in as its first argument.------ As with 'foreignAcc', the fallback implementation itself may be a (sequence--- of) foreign implementation(s) for a different backend(s), or implemented--- purely in Accelerate.----foreignExp-    :: (Elt x, Elt y, Foreign asm)-    => asm (x -> y)-    -> (Exp x -> Exp y)-    -> Exp x-    -> Exp y-foreignExp = Exp $$$ Foreign----- Composition of array computations--- ------------------------------------- | Pipelining of two array computations. The first argument will be fully--- evaluated before being passed to the second computation. This can be used to--- prevent the argument being fused into the function, for example.------ Denotationally, we have------ > (acc1 >-> acc2) arrs = let tmp = acc1 arrs--- >                        in  tmp `seq` acc2 tmp------ For an example use of this operation see the 'Data.Array.Accelerate.compute'--- function.----infixl 1 >->-(>->) :: (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b) -> (Acc b -> Acc c) -> (Acc a -> Acc c)-(>->) = Acc $$$ Pipe----- Flow control constructs--- --------------------------- | An array-level if-then-else construct.------ Enabling the @RebindableSyntax@ extension will allow you to use the standard--- if-then-else syntax instead.----acond :: Arrays a-      => Exp Bool               -- ^ if-condition-      -> Acc a                  -- ^ then-array-      -> Acc a                  -- ^ else-array-      -> Acc a-acond = Acc $$$ Acond---- | An array-level 'while' construct. Continue to apply the given function,--- starting with the initial value, until the test function evaluates to--- 'False'.----awhile :: Arrays a-       => (Acc a -> Acc (Scalar Bool))    -- ^ keep evaluating while this returns 'True'-       -> (Acc a -> Acc a)                -- ^ function to apply-       -> Acc a                           -- ^ initial value-       -> Acc a-awhile = Acc $$$ Awhile----- Shapes and indices--- ---------------------- | Get the innermost dimension of a shape.------ The innermost dimension (right-most component of the shape) is the index of--- the array which varies most rapidly, and corresponds to elements of the array--- which are adjacent in memory.------ Another way to think of this is, for example when writing nested loops over--- an array in C, this index corresponds to the index iterated over by the--- innermost nested loop.----indexHead :: (Slice sh, Elt a) => Exp (sh :. a) -> Exp a-indexHead = Exp . IndexHead---- | Get all but the innermost element of a shape----indexTail :: (Slice sh, Elt a) => Exp (sh :. a) -> Exp sh-indexTail = Exp . IndexTail---- | Map a multi-dimensional index into a linear, row-major representation of an--- array.----toIndex-    :: Shape sh-    => Exp sh                     -- ^ extent of the array-    -> Exp sh                     -- ^ index to remap-    -> Exp Int-toIndex = Exp $$ ToIndex---- | Inverse of 'toIndex'----fromIndex :: Shape sh => Exp sh -> Exp Int -> Exp sh-fromIndex = Exp $$ FromIndex---- | Intersection of two shapes----intersect :: Shape sh => Exp sh -> Exp sh -> Exp sh-intersect = Exp $$ Intersect---- | Union of two shapes----union :: Shape sh => Exp sh -> Exp sh -> Exp sh-union = Exp $$ Union----- Flow-control--- ---------------- | A scalar-level if-then-else construct.------ Enabling the @RebindableSyntax@ extension will allow you to use the standard--- if-then-else syntax instead.----cond :: Elt t-     => Exp Bool                -- ^ condition-     -> Exp t                   -- ^ then-expression-     -> Exp t                   -- ^ else-expression-     -> Exp t-cond = Exp $$$ Cond---- | While construct. Continue to apply the given function, starting with the--- initial value, until the test function evaluates to 'False'.----while :: Elt e-      => (Exp e -> Exp Bool)    -- ^ keep evaluating while this returns 'True'-      -> (Exp e -> Exp e)       -- ^ function to apply-      -> Exp e                  -- ^ initial value-      -> Exp e-while = Exp $$$ While----- Array operations with a scalar result--- ----------------------------------------- | Multidimensional array indexing. Extract the value from an array at the--- specified zero-based index.------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> mat ! Z:.1:.2--- 12----infixl 9 !-(!) :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -> Exp e-(!) = Exp $$ Index---- | Extract the value from an array at the specified linear index.--- Multidimensional arrays in Accelerate are stored in row-major order with--- zero-based indexing.------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> mat !! 12--- 12----infixl 9 !!-(!!) :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp Int -> Exp e-(!!) = Exp $$ LinearIndex---- | Extract the shape (extent) of an array.----shape :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh-shape = Exp . Shape---- | The number of elements in the array----size :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp Int-size = shapeSize . shape---- | The number of elements that would be held by an array of the given shape.----shapeSize :: Shape sh => Exp sh -> Exp Int-shapeSize = Exp . ShapeSize----- Numeric functions--- --------------------- | 'subtract' is the same as @'flip' ('-')@.----subtract :: Num a => Exp a -> Exp a -> Exp a-subtract x y = y - x---- | Determine if a number is even----even :: Integral a => Exp a -> Exp Bool-even n = n `rem` 2 == 0---- | Determine if a number is odd----odd :: Integral a => Exp a -> Exp Bool-odd n = n `rem` 2 /= 0---- | @'gcd' x y@ is the non-negative factor of both @x@ and @y@ of which every--- common factor of both @x@ and @y@ is also a factor; for example:------ >>> gcd 4 2 = 2--- >>> gcd (-4) 6 = 2--- >>> gcd 0 4 = 4--- >>> gcd 0 0 = 0------ That is, the common divisor that is \"greatest\" in the divisibility--- preordering.----gcd :: Integral a => Exp a -> Exp a -> Exp a-gcd x y = gcd' (abs x) (abs y)-  where-    gcd' :: Integral a => Exp a -> Exp a -> Exp a-    gcd' u v =-      let (r,_) = untup2-                $ while (\(untup2 -> (_,b)) -> b /= 0)-                        (\(untup2 -> (a,b)) -> tup2 (b, a `rem` b))-                        (tup2 (u,v))-      in r----- | @'lcm' x y@ is the smallest positive integer that both @x@ and @y@ divide.----lcm :: Integral a => Exp a -> Exp a -> Exp a-lcm x y-  = cond (x == 0 || y == 0) 0-  $ abs ((x `quot` (gcd x y)) * y)----- | Raise a number to a non-negative integral power----infixr 8 ^-(^) :: forall a b. (Num a, Integral b) => Exp a -> Exp b -> Exp a-x0 ^ y0 = cond (y0 <= 0) 1 (f x0 y0)-  where-    f :: Exp a -> Exp b -> Exp a-    f x y =-      let (x',y') = untup2-                  $ while (\(untup2 -> (_,v)) -> even v)-                          (\(untup2 -> (u,v)) -> tup2 (u * u, v `quot` 2))-                          (tup2 (x, y))-      in-      cond (y' == 1) x' (g (x'*x') ((y'-1) `quot` 2) x')--    g :: Exp a -> Exp b -> Exp a -> Exp a-    g x y z =-      let (x',_,z') = untup3-                    $ while (\(untup3 -> (_,v,_)) -> v /= 1)-                            (\(untup3 -> (u,v,w)) ->-                              cond (even v) (tup3 (u*u, v     `quot` 2, w))-                                            (tup3 (u*u, (v-1) `quot` 2, w*u)))-                            (tup3 (x,y,z))-      in-      x' * z'---- | Raise a number to an integral power----infixr 8 ^^-(^^) :: (Fractional a, Integral b) => Exp a -> Exp b -> Exp a-x ^^ n-  = cond (n >= 0)-  {- then -} (x ^ n)-  {- else -} (recip (x ^ (negate n)))----- Conversions--- --------------- |Convert a character to an 'Int'.----ord :: Exp Char -> Exp Int-ord = mkOrd---- |Convert an 'Int' into a character.----chr :: Exp Int -> Exp Char-chr = mkChr---- |Convert a Boolean value to an 'Int', where 'False' turns into '0' and 'True'--- into '1'.----boolToInt :: Exp Bool -> Exp Int-boolToInt = mkBoolToInt---- |Reinterpret a value as another type. The two representations must have the--- same bit size.----bitcast :: (Elt a, Elt b, IsScalar a, IsScalar b, BitSizeEq a b) => Exp a -> Exp b-bitcast = mkBitcast----- Constants--- ------------- |Magic value identifying elements that are ignored in a forward permutation.----ignore :: Shape sh => Exp sh-ignore = constant Sugar.ignore-
− Data/Array/Accelerate/Lifetime.hs 
@@ -1,161 +0,0 @@-{-# LANGUAGE CPP           #-}-{-# LANGUAGE MagicHash     #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE UnboxedTuples #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Lifetime--- Copyright   : [2015..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)-----module Data.Array.Accelerate.Lifetime (--  Lifetime(..),-  newLifetime, withLifetime, touchLifetime,-  addFinalizer, finalize, mkWeak, mkWeakPtr,--  unsafeGetValue,--) where--import Data.Function                ( on )-import Data.IORef                   ( mkWeakIORef, atomicModifyIORef' )-import Prelude--import GHC.Base                     ( touch#, IO(..))-import GHC.IORef                    ( IORef(.. ), newIORef )-import GHC.Prim                     ( mkWeak# )-import GHC.STRef                    ( STRef(..) )-import GHC.Weak                     ( Weak(..) )----- | A lifetime represents a value with attached finalizers. This is similar to--- the functionality provided by "System.Mem.Weak", but has the following--- stronger properties:------ * Unless explicitly forced, finalizers will not fire until after the---   'Lifetime' has become unreachable, where \"reachability\" is the same as---   defined in "System.Mem.Weak". That is to say, there is no issue with---   creating a 'Lifetime' for a non-primitve type and finalizers firing while---   an object is still reachable.------ * Finalizers are fired sequentially in reverse of the order in which they---   were attached.------ * As the finalizers are attached to the 'Lifetime' and not the underlying---   value, there is no danger in storing it UNPACKED as part of another---   structure.----type LTF        = IORef [IO ()]-data Lifetime a = Lifetime {-# UNPACK #-} !LTF-                           {-# UNPACK #-} !(Weak LTF)-                           {- LAZY -}     a--instance Eq a => Eq (Lifetime a) where-  (==) = (==) `on` unsafeGetValue---- | Construct a new 'Lifetime' from the given value.----{-# INLINE newLifetime #-}-newLifetime :: a -> IO (Lifetime a)-newLifetime a = do-  ref  <- newIORef []-  weak <- mkWeakIORef ref (finalizer ref)-  return $! Lifetime ref weak a---- | This provides a way of looking at the value inside a 'Lifetime'. The--- supplied function is executed immediately and the 'Lifetime' kept alive--- throughout its execution. It is important to not let the value /leak/ outside--- the function, either by returning it or by lazy IO.----{-# INLINE withLifetime #-}-withLifetime :: Lifetime a -> (a -> IO b) -> IO b-withLifetime (Lifetime ref _ a) f = do-  r <- f a-  touchIORef ref-  return r---- | Ensure that the lifetime is alive at the given place in a sequence of IO--- actions. Does not force the payload.----{-# INLINE touchLifetime #-}-touchLifetime :: Lifetime a -> IO ()-touchLifetime (Lifetime ref _ _) = touchIORef ref---- | Attaches a finalizer to a 'Lifetime'. Like in "System.Mem.Weak", there is--- no guarantee that the finalizers will eventually run. If they do run,--- they will be executed in the order in which they were supplied.----addFinalizer :: Lifetime a -> IO () -> IO ()-addFinalizer (Lifetime ref _ _) f =-  atomicModifyIORef' ref (\fs -> (f:fs,()))---- | Causes any finalizers associated with the given lifetime to be run--- immediately on the calling thread.------ Because the finalizer is run on the calling thread. Care should be taken to--- ensure that the it does not try to acquire any locks the calling thread might--- already possess. This can result in deadlock and is in contrast to calling--- 'System.Mem.Weak.finalize' on 'System.Mem.Weak.Weak'.----finalize :: Lifetime a -> IO ()-finalize (Lifetime ref _ _) = finalizer ref---- | Create a weak pointer from a 'Lifetime' to the supplied value.------ Because weak pointers have their own concept of finalizers, it is important--- to note these behaviours:------ * Calling 'System.Mem.Weak.finalize' causes the finalizers attached to the---   lifetime to be scheduled, and run in the correct order, but does not---   guarantee they will execute on the calling thread.------ * If 'deRefWeak' returns Nothing, there is no guarantee that the finalizers---   have already run.----mkWeak :: Lifetime k -> v -> IO (Weak v)-mkWeak (Lifetime ref@(IORef (STRef r#)) _ _) v = go (finalizer ref)-  where-#if __GLASGOW_HASKELL__ >= 800-    go (IO f)  =  -- GHC-8.x-#else-    go f       =  -- GHC-7.x-#endif-      IO $ \s -> case mkWeak# r# v f s of-                   (# s', w# #) -> (# s', Weak w# #)---- A specialised version of 'mkWeak' where the key and value are the same--- 'Lifetime'.------ > mkWeakPtr key = mkWeak key key----mkWeakPtr :: Lifetime a -> IO (Weak (Lifetime a))-mkWeakPtr l = mkWeak l l---- | Retrieve the value from a lifetime. This is unsafe because, unless the--- 'Lifetime' is still reachable, the finalizers may fire, potentially--- invalidating the value.----{-# INLINE unsafeGetValue #-}-unsafeGetValue :: Lifetime a -> a-unsafeGetValue (Lifetime _ _ a) = a---- The actual finalizer for 'Lifetime's.----finalizer :: IORef [IO ()] -> IO ()-finalizer ref = do-  fins <- atomicModifyIORef' ref ([],)-  sequence_ fins---- Touch an 'IORef', ensuring that it is alive at this point in a sequence of IO--- actions.----{-# INLINE touchIORef #-}-touchIORef :: IORef a -> IO ()-touchIORef r = IO $ \s -> case touch# r s of s' -> (# s', () #)-
− Data/Array/Accelerate/Lift.hs 
@@ -1,747 +0,0 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances  #-}-{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}-#endif--- |--- Module      : Data.Array.Accelerate.Lift--- Copyright   : [2016..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)------ Lifting and lowering surface expressions through constructors.-----module Data.Array.Accelerate.Lift (--  -- * Lifting and unlifting-  Lift(..), Unlift(..),--  lift1, lift2, lift3,-  ilift1, ilift2, ilift3,--) where--import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type----- |Lift a unary function into 'Exp'.----lift1 :: (Unlift Exp a, Lift Exp b)-      => (a -> b)-      -> Exp (Plain a)-      -> Exp (Plain b)-lift1 f = lift . f . unlift---- |Lift a binary function into 'Exp'.----lift2 :: (Unlift Exp a, Unlift Exp b, Lift Exp c)-      => (a -> b -> c)-      -> Exp (Plain a)-      -> Exp (Plain b)-      -> Exp (Plain c)-lift2 f x y = lift $ f (unlift x) (unlift y)---- |Lift a ternary function into 'Exp'.----lift3 :: (Unlift Exp a, Unlift Exp b, Unlift Exp c, Lift Exp d)-      => (a -> b -> c -> d)-      -> Exp (Plain a)-      -> Exp (Plain b)-      -> Exp (Plain c)-      -> Exp (Plain d)-lift3 f x y z = lift $ f (unlift x) (unlift y) (unlift z)---- |Lift a unary function to a computation over rank-1 indices.----ilift1 :: (Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1-ilift1 f = lift1 (\(Z:.i) -> Z :. f i)---- |Lift a binary function to a computation over rank-1 indices.----ilift2 :: (Exp Int -> Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 -> Exp DIM1-ilift2 f = lift2 (\(Z:.i) (Z:.j) -> Z :. f i j)---- |Lift a ternary function to a computation over rank-1 indices.----ilift3 :: (Exp Int -> Exp Int -> Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 -> Exp DIM1 -> Exp DIM1-ilift3 f = lift3 (\(Z:.i) (Z:.j) (Z:.k) -> Z :. f i j k)------ | The class of types @e@ which can be lifted into @c@.-class Lift c e where-  -- | An associated-type (i.e. a type-level function) that strips all-  --   instances of surface type constructors @c@ from the input type @e@.-  ---  --   For example, the tuple types @(Exp Int, Int)@ and @(Int, Exp-  --   Int)@ have the same \"Plain\" representation.  That is, the-  --   following type equality holds:-  ---  --    @Plain (Exp Int, Int) ~ (Int,Int) ~ Plain (Int, Exp Int)@-  type Plain e--  -- | Lift the given value into a surface type 'c' --- either 'Exp' for scalar-  -- expressions or 'Acc' for array computations. The value may already contain-  -- subexpressions in 'c'.-  ---  lift :: e -> c (Plain e)---- | A limited subset of types which can be lifted, can also be unlifted.-class Lift c e => Unlift c e where--  -- | Unlift the outermost constructor through the surface type. This is only-  -- possible if the constructor is fully determined by its type - i.e., it is a-  -- singleton.-  ---  unlift :: c (Plain e) -> e----- identity instances--instance Lift Exp (Exp e) where-  type Plain (Exp e) = e-  lift = id--instance Unlift Exp (Exp e) where-  unlift = id--instance Lift Acc (Acc a) where-  type Plain (Acc a) = a-  lift = id--instance Unlift Acc (Acc a) where-  unlift = id---- instance Lift Seq (Seq a) where---   type Plain (Seq a) = a---   lift = id---- instance Unlift Seq (Seq a) where---   unlift = id----- instances for indices--instance Lift Exp () where-  type Plain () = ()-  lift _ = Exp $ Tuple NilTup--instance Unlift Exp () where-  unlift _ = ()--instance Lift Exp Z where-  type Plain Z = Z-  lift _ = Exp $ IndexNil--instance Unlift Exp Z where-  unlift _ = Z--instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Int) where-  type Plain (ix :. Int) = Plain ix :. Int-  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)--instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. All) where-  type Plain (ix :. All) = Plain ix :. All-  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)--instance (Elt e, Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Exp e) where-  type Plain (ix :. Exp e) = Plain ix :. e-  lift (ix:.i) = Exp $ IndexCons (lift ix) i--instance {-# OVERLAPPABLE #-} (Elt e, Slice (Plain ix), Unlift Exp ix) => Unlift Exp (ix :. Exp e) where-  unlift e = unlift (Exp $ IndexTail e) :. Exp (IndexHead e)--instance {-# OVERLAPPABLE #-} (Elt e, Slice ix) => Unlift Exp (Exp ix :. Exp e) where-  unlift e = (Exp $ IndexTail e) :. Exp (IndexHead e)--instance Shape sh => Lift Exp (Any sh) where- type Plain (Any sh) = Any sh- lift Any = Exp $ IndexAny---- instances for numeric types--instance Lift Exp Int where-  type Plain Int = Int-  lift = Exp . Const--instance Lift Exp Int8 where-  type Plain Int8 = Int8-  lift = Exp . Const--instance Lift Exp Int16 where-  type Plain Int16 = Int16-  lift = Exp . Const--instance Lift Exp Int32 where-  type Plain Int32 = Int32-  lift = Exp . Const--instance Lift Exp Int64 where-  type Plain Int64 = Int64-  lift = Exp . Const--instance Lift Exp Word where-  type Plain Word = Word-  lift = Exp . Const--instance Lift Exp Word8 where-  type Plain Word8 = Word8-  lift = Exp . Const--instance Lift Exp Word16 where-  type Plain Word16 = Word16-  lift = Exp . Const--instance Lift Exp Word32 where-  type Plain Word32 = Word32-  lift = Exp . Const--instance Lift Exp Word64 where-  type Plain Word64 = Word64-  lift = Exp . Const--instance Lift Exp CShort where-  type Plain CShort = CShort-  lift = Exp . Const--instance Lift Exp CUShort where-  type Plain CUShort = CUShort-  lift = Exp . Const--instance Lift Exp CInt where-  type Plain CInt = CInt-  lift = Exp . Const--instance Lift Exp CUInt where-  type Plain CUInt = CUInt-  lift = Exp . Const--instance Lift Exp CLong where-  type Plain CLong = CLong-  lift = Exp . Const--instance Lift Exp CULong where-  type Plain CULong = CULong-  lift = Exp . Const--instance Lift Exp CLLong where-  type Plain CLLong = CLLong-  lift = Exp . Const--instance Lift Exp CULLong where-  type Plain CULLong = CULLong-  lift = Exp . Const--instance Lift Exp Float where-  type Plain Float = Float-  lift = Exp . Const--instance Lift Exp Double where-  type Plain Double = Double-  lift = Exp . Const--instance Lift Exp CFloat where-  type Plain CFloat = CFloat-  lift = Exp . Const--instance Lift Exp CDouble where-  type Plain CDouble = CDouble-  lift = Exp . Const--instance Lift Exp Bool where-  type Plain Bool = Bool-  lift = Exp . Const--instance Lift Exp Char where-  type Plain Char = Char-  lift = Exp . Const--instance Lift Exp CChar where-  type Plain CChar = CChar-  lift = Exp . Const--instance Lift Exp CSChar where-  type Plain CSChar = CSChar-  lift = Exp . Const--instance Lift Exp CUChar where-  type Plain CUChar = CUChar-  lift = Exp . Const---- Instances for tuples--instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b)) => Lift Exp (a, b) where-  type Plain (a, b) = (Plain a, Plain b)-  lift (a, b) = tup2 (lift a, lift b)--instance (Elt a, Elt b) => Unlift Exp (Exp a, Exp b) where-  unlift = untup2--instance (Lift Exp a, Lift Exp b, Lift Exp c,-          Elt (Plain a), Elt (Plain b), Elt (Plain c))-  => Lift Exp (a, b, c) where-  type Plain (a, b, c) = (Plain a, Plain b, Plain c)-  lift (a, b, c) = tup3 (lift a, lift b, lift c)--instance (Elt a, Elt b, Elt c) => Unlift Exp (Exp a, Exp b, Exp c) where-  unlift = untup3--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d))-  => Lift Exp (a, b, c, d) where-  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)-  lift (a, b, c, d) = tup4 (lift a, lift b, lift c, lift d)--instance (Elt a, Elt b, Elt c, Elt d) => Unlift Exp (Exp a, Exp b, Exp c, Exp d) where-  unlift = untup4--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e))-  => Lift Exp (a, b, c, d, e) where-  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)-  lift (a, b, c, d, e) = tup5 (lift a, lift b, lift c, lift d, lift e)--instance (Elt a, Elt b, Elt c, Elt d, Elt e)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e) where-  unlift = untup5--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f))-  => Lift Exp (a, b, c, d, e, f) where-  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)-  lift (a, b, c, d, e, f) = tup6 (lift a, lift b, lift c, lift d, lift e, lift f)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) where-  unlift = untup6--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),-          Elt (Plain g))-  => Lift Exp (a, b, c, d, e, f, g) where-  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)-  lift (a, b, c, d, e, f, g) = tup7 (lift a, lift b, lift c, lift d, lift e, lift f, lift g)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) where-  unlift = untup7--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g, Lift Exp h,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),-          Elt (Plain g), Elt (Plain h))-  => Lift Exp (a, b, c, d, e, f, g, h) where-  type Plain (a, b, c, d, e, f, g, h)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)-  lift (a, b, c, d, e, f, g, h)-    = tup8 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) where-  unlift = untup8--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,-          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),-          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i))-  => Lift Exp (a, b, c, d, e, f, g, h, i) where-  type Plain (a, b, c, d, e, f, g, h, i)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)-  lift (a, b, c, d, e, f, g, h, i)-    = tup9 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) where-  unlift = untup9--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,-          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i, Lift Exp j,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),-          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i), Elt (Plain j))-  => Lift Exp (a, b, c, d, e, f, g, h, i, j) where-  type Plain (a, b, c, d, e, f, g, h, i, j)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j)-  lift (a, b, c, d, e, f, g, h, i, j)-    = tup10 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j) where-  unlift = untup10--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,-          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),-          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k))-  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k)-  lift (a, b, c, d, e, f, g, h, i, j, k)-    = tup11 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k)--instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k) where-  unlift = untup11--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,-          Lift Exp g, Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k, Lift Exp l,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),-          Elt (Plain g), Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k), Elt (Plain l))-  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l)-  lift (a, b, c, d, e, f, g, h, i, j, k, l)-    = tup12 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift 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)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l) where-  unlift = untup12--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,-          Lift Exp g, Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k, Lift Exp l, Lift Exp m,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),-          Elt (Plain g), Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k), Elt (Plain l), Elt (Plain m))-  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l, m) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m)-  lift (a, b, c, d, e, f, g, h, i, j, k, l, m)-    = tup13 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift 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)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m) where-  unlift = untup13--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,-          Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k, Lift Exp l, Lift Exp m, Lift Exp n,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f), Elt (Plain g),-          Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k), Elt (Plain l), Elt (Plain m), Elt (Plain n))-  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n)-  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-    = tup14 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift 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)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n) where-  unlift = untup14--instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,-          Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k, Lift Exp l, Lift Exp m, Lift Exp n, Lift Exp o,-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f), Elt (Plain g),-          Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k), Elt (Plain l), Elt (Plain m), Elt (Plain n), Elt (Plain o))-  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n, Plain o)-  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-    = tup15 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift n, lift o)--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)-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o) where-  unlift = untup15------ Instances for Arrays class----instance Lift Acc () where---  type Plain () = ()---  lift _ = Acc (Atuple NilAtup)--instance (Shape sh, Elt e) => Lift Acc (Array sh e) where-  type Plain (Array sh e) = Array sh e-  lift = Acc . Use--instance (Lift Acc a, Lift Acc b, Arrays (Plain a), Arrays (Plain b)) => Lift Acc (a, b) where-  type Plain (a, b) = (Plain a, Plain b)-  lift (a, b) = atup2 (lift a, lift b)--instance (Arrays a, Arrays b) => Unlift Acc (Acc a, Acc b) where-  unlift = unatup2--instance (Lift Acc a, Lift Acc b, Lift Acc c,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c))-  => Lift Acc (a, b, c) where-  type Plain (a, b, c) = (Plain a, Plain b, Plain c)-  lift (a, b, c) = atup3 (lift a, lift b, lift c)--instance (Arrays a, Arrays b, Arrays c) => Unlift Acc (Acc a, Acc b, Acc c) where-  unlift = unatup3--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d))-  => Lift Acc (a, b, c, d) where-  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)-  lift (a, b, c, d) = atup4 (lift a, lift b, lift c, lift d)--instance (Arrays a, Arrays b, Arrays c, Arrays d) => Unlift Acc (Acc a, Acc b, Acc c, Acc d) where-  unlift = unatup4--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e))-  => Lift Acc (a, b, c, d, e) where-  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)-  lift (a, b, c, d, e) = atup5 (lift a, lift b, lift c, lift d, lift e)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e) where-  unlift = unatup5--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f))-  => Lift Acc (a, b, c, d, e, f) where-  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)-  lift (a, b, c, d, e, f) = atup6 (lift a, lift b, lift c, lift d, lift e, lift f)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) where-  unlift = unatup6--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g))-  => Lift Acc (a, b, c, d, e, f, g) where-  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)-  lift (a, b, c, d, e, f, g) = atup7 (lift a, lift b, lift c, lift d, lift e, lift f, lift g)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) where-  unlift = unatup7--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g, Lift Acc h,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g), Arrays (Plain h))-  => Lift Acc (a, b, c, d, e, f, g, h) where-  type Plain (a, b, c, d, e, f, g, h)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)-  lift (a, b, c, d, e, f, g, h)-    = atup8 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) where-  unlift = unatup8--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,-          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),-          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i))-  => Lift Acc (a, b, c, d, e, f, g, h, i) where-  type Plain (a, b, c, d, e, f, g, h, i)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)-  lift (a, b, c, d, e, f, g, h, i)-    = atup9 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) where-  unlift = unatup9--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,-          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i, Lift Acc j,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),-          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j))-  => Lift Acc (a, b, c, d, e, f, g, h, i, j) where-  type Plain (a, b, c, d, e, f, g, h, i, j)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j)-  lift (a, b, c, d, e, f, g, h, i, j)-    = atup10 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j) where-  unlift = unatup10--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,-          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),-          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k))-  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k)-  lift (a, b, c, d, e, f, g, h, i, j, k)-    = atup11 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k)--instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k) where-  unlift = unatup11--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,-          Lift Acc g, Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k, Lift Acc l,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l))-  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l)-  lift (a, b, c, d, e, f, g, h, i, j, k, l)-    = atup12 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift 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)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l) where-  unlift = unatup12--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,-          Lift Acc g, Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k, Lift Acc l, Lift Acc m,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m))-  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l, m) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m)-  lift (a, b, c, d, e, f, g, h, i, j, k, l, m)-    = atup13 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift 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)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m) where-  unlift = unatup13--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,-          Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k, Lift Acc l, Lift Acc m, Lift Acc n,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f), Arrays (Plain g),-          Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m), Arrays (Plain n))-  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n)-  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-    = atup14 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift 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)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n) where-  unlift = unatup14--instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,-          Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k, Lift Acc l, Lift Acc m, Lift Acc n, Lift Acc o,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f), Arrays (Plain g),-          Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m), Arrays (Plain n), Arrays (Plain o))-  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n, Plain o)-  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-    = atup15 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift n, lift o)--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)-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o) where-  unlift = unatup15--{----- Instances for Seq--instance (Lift Seq a, Lift Seq b, Arrays (Plain a), Arrays (Plain b)) => Lift Seq (a, b) where-  type Plain (a, b) = (Plain a, Plain b)-  lift (a, b) = stup2 (lift a, lift b)--instance (Lift Seq a, Lift Seq b, Lift Seq c,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c))-  => Lift Seq (a, b, c) where-  type Plain (a, b, c) = (Plain a, Plain b, Plain c)-  lift (a, b, c) = stup3 (lift a, lift b, lift c)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d))-  => Lift Seq (a, b, c, d) where-  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)-  lift (a, b, c, d) = stup4 (lift a, lift b, lift c, lift d)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e))-  => Lift Seq (a, b, c, d, e) where-  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)-  lift (a, b, c, d, e) = stup5 (lift a, lift b, lift c, lift d, lift e)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f))-  => Lift Seq (a, b, c, d, e, f) where-  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)-  lift (a, b, c, d, e, f) = stup6 (lift a, lift b, lift c, lift d, lift e, lift f)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f, Lift Seq g,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g))-  => Lift Seq (a, b, c, d, e, f, g) where-  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)-  lift (a, b, c, d, e, f, g) = stup7 (lift a, lift b, lift c, lift d, lift e, lift f, lift g)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f, Lift Seq g, Lift Seq h,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g), Arrays (Plain h))-  => Lift Seq (a, b, c, d, e, f, g, h) where-  type Plain (a, b, c, d, e, f, g, h)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)-  lift (a, b, c, d, e, f, g, h)-    = stup8 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e,-          Lift Seq f, Lift Seq g, Lift Seq h, Lift Seq i,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),-          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i))-  => Lift Seq (a, b, c, d, e, f, g, h, i) where-  type Plain (a, b, c, d, e, f, g, h, i)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)-  lift (a, b, c, d, e, f, g, h, i)-    = stup9 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e,-          Lift Seq f, Lift Seq g, Lift Seq h, Lift Seq i, Lift Seq j,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),-          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j))-  => Lift Seq (a, b, c, d, e, f, g, h, i, j) where-  type Plain (a, b, c, d, e, f, g, h, i, j)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j)-  lift (a, b, c, d, e, f, g, h, i, j)-    = stup10 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e,-          Lift Seq f, Lift Seq g, Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),-          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k))-  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k)-  lift (a, b, c, d, e, f, g, h, i, j, k)-    = stup11 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f,-          Lift Seq g, Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k, Lift Seq l,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l))-  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l)-  lift (a, b, c, d, e, f, g, h, i, j, k, l)-    = stup12 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f,-          Lift Seq g, Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k, Lift Seq l, Lift Seq m,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),-          Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m))-  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l, m) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m)-  lift (a, b, c, d, e, f, g, h, i, j, k, l, m)-    = stup13 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f, Lift Seq g,-          Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k, Lift Seq l, Lift Seq m, Lift Seq n,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f), Arrays (Plain g),-          Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m), Arrays (Plain n))-  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n)-  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-    = stup14 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift n)--instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f, Lift Seq g,-          Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k, Lift Seq l, Lift Seq m, Lift Seq n, Lift Seq o,-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f), Arrays (Plain g),-          Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m), Arrays (Plain n), Arrays (Plain o))-  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where-  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n, Plain o)-  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-    = stup15 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift n, lift o)---}-
− Data/Array/Accelerate/Prelude.hs 
@@ -1,2113 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternGuards         #-}-{-# LANGUAGE RebindableSyntax      #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}--- |--- Module      : Data.Array.Accelerate.Prelude--- Copyright   : [2009..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell---               [2010..2011] Ben Lever--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Standard functions that are not part of the core set (directly represented in--- the AST), but are instead implemented in terms of the core set.-----module Data.Array.Accelerate.Prelude (--  -- * Element-wise operations-  indexed,-  imap,--  -- * Zipping-  zipWith3, zipWith4, zipWith5, zipWith6, zipWith7, zipWith8, zipWith9,-  izipWith, izipWith3, izipWith4, izipWith5, izipWith6, izipWith7, izipWith8, izipWith9,-  zip, zip3, zip4, zip5, zip6, zip7, zip8, zip9,--  -- * Unzipping-  unzip, unzip3, unzip4, unzip5, unzip6, unzip7, unzip8, unzip9,--  -- * Reductions-  foldAll, fold1All,--  -- ** Specialised folds-  all, any, and, or, sum, product, minimum, maximum,--  -- * Scans-  prescanl, postscanl, prescanr, postscanr,--  -- ** Segmented scans-  scanlSeg, scanl'Seg, scanl1Seg, prescanlSeg, postscanlSeg,-  scanrSeg, scanr'Seg, scanr1Seg, prescanrSeg, postscanrSeg,--  -- * Shape manipulation-  flatten,--  -- * Enumeration and filling-  fill, enumFromN, enumFromStepN,--  -- * Concatenation-  (++),--  -- * Working with predicates-  -- ** Filtering-  filter,--  -- ** Scatter / Gather-  scatter, scatterIf,-  gather,  gatherIf,--  -- * Permutations-  reverse, transpose,--  -- * Extracting sub-vectors-  init, tail, take, drop, slit,--  -- * Controlling execution-  compute,--  -- * Flow control-  IfThenElse(..),--  -- ** Array-level-  (?|),--  -- ** Expression-level-  (?), caseof,--  -- * Scalar iteration-  iterate,--  -- * Scalar reduction-  sfoldl, -- sfoldr,--  -- * Lifting and unlifting-  Lift(..), Unlift(..),-  lift1, lift2, lift3, ilift1, ilift2, ilift3,--  -- ** Tuple construction and destruction-  fst, afst, snd, asnd, curry, uncurry,--  -- ** Index construction and destruction-  index0, index1, unindex1, index2, unindex2, index3, unindex3,--  -- * Array operations with a scalar result-  the, null, length,--  -- * Sequence operations-  -- fromSeq, fromSeqElems, fromSeqShapes, toSeqInner, toSeqOuter2, toSeqOuter3, generateSeq,--) where---- avoid clashes with Prelude functions----import Data.Typeable                                                ( gcast )-import GHC.Base                                                     ( Constraint )-import Prelude                                                      ( (.), ($), Maybe(..), const, id, fromInteger, flip, undefined, fail )---- friends-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar                            hiding ( (!), ignore, shape, size, intersect, toIndex, fromIndex )-import Data.Array.Accelerate.Language-import Data.Array.Accelerate.Lift-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.Classes.Eq-import Data.Array.Accelerate.Classes.FromIntegral-import Data.Array.Accelerate.Classes.Integral-import Data.Array.Accelerate.Classes.Num-import Data.Array.Accelerate.Classes.Ord--import Data.Array.Accelerate.Data.Bits----- Element-wise operations--- --------------------------- | Pair each element with its index------ >>> let xs = fromList (Z:.5) [0..]--- >>> indexed (use xs)--- Vector (Z :. 5) [(Z :. 0,0.0),(Z :. 1,1.0),(Z :. 2,2.0),(Z :. 3,3.0),(Z :. 4,4.0)]------ >>> let mat = fromList (Z:.3:.4) [0..]--- >>> indexed (use mat)--- Matrix (Z :. 3 :. 4)---   [(Z :. 0 :. 0,0.0),(Z :. 0 :. 1,1.0), (Z :. 0 :. 2,2.0), (Z :. 0 :. 3,3.0),---    (Z :. 1 :. 0,4.0),(Z :. 1 :. 1,5.0), (Z :. 1 :. 2,6.0), (Z :. 1 :. 3,7.0),---    (Z :. 2 :. 0,8.0),(Z :. 2 :. 1,9.0),(Z :. 2 :. 2,10.0),(Z :. 2 :. 3,11.0)]----indexed :: (Shape sh, Elt a) => Acc (Array sh a) -> Acc (Array sh (sh, a))-indexed xs = zip (generate (shape xs) id) xs---- | Apply a function to every element of an array and its index----imap :: (Shape sh, Elt a, Elt b)-     => (Exp sh -> Exp a -> Exp b)-     -> Acc (Array sh a)-     -> Acc (Array sh b)-imap f xs = zipWith f (generate (shape xs) id) xs----- | Zip three arrays with the given function, analogous to 'zipWith'.----zipWith3-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d)-    => (Exp a -> Exp b -> Exp c -> Exp d)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-zipWith3 f as bs cs-  = generate (shape as `intersect` shape bs `intersect` shape cs)-             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix))---- | Zip four arrays with the given function, analogous to 'zipWith'.----zipWith4-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)-    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-zipWith4 f as bs cs ds-  = generate (shape as `intersect` shape bs `intersect`-              shape cs `intersect` shape ds)-             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix))---- | Zip five arrays with the given function, analogous to 'zipWith'.----zipWith5-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)-    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-zipWith5 f as bs cs ds es-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es)-             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix))---- | Zip six arrays with the given function, analogous to 'zipWith'.----zipWith6-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)-    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-    -> Acc (Array sh g)-zipWith6 f as bs cs ds es fs-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es-                       `intersect` shape fs)-             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix))---- | Zip seven arrays with the given function, analogous to 'zipWith'.----zipWith7-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)-    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-    -> Acc (Array sh g)-    -> Acc (Array sh h)-zipWith7 f as bs cs ds es fs gs-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es-                       `intersect` shape fs `intersect` shape gs)-             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix))---- | Zip eight arrays with the given function, analogous to 'zipWith'.----zipWith8-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)-    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-    -> Acc (Array sh g)-    -> Acc (Array sh h)-    -> Acc (Array sh i)-zipWith8 f as bs cs ds es fs gs hs-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es-                       `intersect` shape fs `intersect` shape gs-                       `intersect` shape hs)-             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix))---- | Zip nine arrays with the given function, analogous to 'zipWith'.----zipWith9-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)-    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-    -> Acc (Array sh g)-    -> Acc (Array sh h)-    -> Acc (Array sh i)-    -> Acc (Array sh j)-zipWith9 f as bs cs ds es fs gs hs is-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es-                       `intersect` shape fs `intersect` shape gs-                       `intersect` shape hs `intersect` shape is)-             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix) (is ! ix))----- | Zip two arrays with a function that also takes the element index----izipWith-    :: (Shape sh, Elt a, Elt b, Elt c)-    => (Exp sh -> Exp a -> Exp b -> Exp c)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-izipWith f as bs-  = generate (shape as `intersect` shape bs)-             (\ix -> f ix (as ! ix) (bs ! ix))---- | Zip three arrays with a function that also takes the element index,--- analogous to 'izipWith'.----izipWith3-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d)-    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-izipWith3 f as bs cs-  = generate (shape as `intersect` shape bs `intersect` shape cs)-             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix))---- | Zip four arrays with the given function that also takes the element index,--- analogous to 'zipWith'.----izipWith4-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)-    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-izipWith4 f as bs cs ds-  = generate (shape as `intersect` shape bs `intersect`-              shape cs `intersect` shape ds)-             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix))---- | Zip five arrays with the given function that also takes the element index,--- analogous to 'zipWith'.----izipWith5-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)-    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-izipWith5 f as bs cs ds es-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es)-             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix))---- | Zip six arrays with the given function that also takes the element index,--- analogous to 'zipWith'.----izipWith6-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)-    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-    -> Acc (Array sh g)-izipWith6 f as bs cs ds es fs-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es-                       `intersect` shape fs)-             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix))---- | Zip seven arrays with the given function that also takes the element--- index, analogous to 'zipWith'.----izipWith7-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)-    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-    -> Acc (Array sh g)-    -> Acc (Array sh h)-izipWith7 f as bs cs ds es fs gs-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es-                       `intersect` shape fs `intersect` shape gs)-             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix))---- | Zip eight arrays with the given function that also takes the element--- index, analogous to 'zipWith'.----izipWith8-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)-    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-    -> Acc (Array sh g)-    -> Acc (Array sh h)-    -> Acc (Array sh i)-izipWith8 f as bs cs ds es fs gs hs-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es-                       `intersect` shape fs `intersect` shape gs-                       `intersect` shape hs)-             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix))---- | Zip nine arrays with the given function that also takes the element index,--- analogous to 'zipWith'.----izipWith9-    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)-    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j)-    -> Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh c)-    -> Acc (Array sh d)-    -> Acc (Array sh e)-    -> Acc (Array sh f)-    -> Acc (Array sh g)-    -> Acc (Array sh h)-    -> Acc (Array sh i)-    -> Acc (Array sh j)-izipWith9 f as bs cs ds es fs gs hs is-  = generate (shape as `intersect` shape bs `intersect` shape cs-                       `intersect` shape ds `intersect` shape es-                       `intersect` shape fs `intersect` shape gs-                       `intersect` shape hs `intersect` shape is)-             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix) (is ! ix))----- | Combine the elements of two arrays pairwise. The shape of the result is the--- intersection of the two argument shapes.----zip :: (Shape sh, Elt a, Elt b)-    => Acc (Array sh a)-    -> Acc (Array sh b)-    -> Acc (Array sh (a, b))-zip = zipWith (curry lift)---- | Take three arrays and return an array of triples, analogous to zip.----zip3 :: (Shape sh, Elt a, Elt b, Elt c)-     => Acc (Array sh a)-     -> Acc (Array sh b)-     -> Acc (Array sh c)-     -> Acc (Array sh (a, b, c))-zip3 = zipWith3 (\a b c -> lift (a,b,c))---- | Take four arrays and return an array of quadruples, analogous to zip.----zip4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d)-     => Acc (Array sh a)-     -> Acc (Array sh b)-     -> Acc (Array sh c)-     -> Acc (Array sh d)-     -> Acc (Array sh (a, b, c, d))-zip4 = zipWith4 (\a b c d -> lift (a,b,c,d))---- | Take five arrays and return an array of five-tuples, analogous to zip.----zip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)-     => Acc (Array sh a)-     -> Acc (Array sh b)-     -> Acc (Array sh c)-     -> Acc (Array sh d)-     -> Acc (Array sh e)-     -> Acc (Array sh (a, b, c, d, e))-zip5 = zipWith5 (\a b c d e -> lift (a,b,c,d,e))---- | Take six arrays and return an array of six-tuples, analogous to zip.----zip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)-     => Acc (Array sh a)-     -> Acc (Array sh b)-     -> Acc (Array sh c)-     -> Acc (Array sh d)-     -> Acc (Array sh e)-     -> Acc (Array sh f)-     -> Acc (Array sh (a, b, c, d, e, f))-zip6 = zipWith6 (\a b c d e f -> lift (a,b,c,d,e,f))---- | Take seven arrays and return an array of seven-tuples, analogous to zip.----zip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)-     => Acc (Array sh a)-     -> Acc (Array sh b)-     -> Acc (Array sh c)-     -> Acc (Array sh d)-     -> Acc (Array sh e)-     -> Acc (Array sh f)-     -> Acc (Array sh g)-     -> Acc (Array sh (a, b, c, d, e, f, g))-zip7 = zipWith7 (\a b c d e f g -> lift (a,b,c,d,e,f,g))---- | Take seven arrays and return an array of seven-tuples, analogous to zip.----zip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)-     => Acc (Array sh a)-     -> Acc (Array sh b)-     -> Acc (Array sh c)-     -> Acc (Array sh d)-     -> Acc (Array sh e)-     -> Acc (Array sh f)-     -> Acc (Array sh g)-     -> Acc (Array sh h)-     -> Acc (Array sh (a, b, c, d, e, f, g, h))-zip8 = zipWith8 (\a b c d e f g h -> lift (a,b,c,d,e,f,g,h))---- | Take seven arrays and return an array of seven-tuples, analogous to zip.----zip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)-     => Acc (Array sh a)-     -> Acc (Array sh b)-     -> Acc (Array sh c)-     -> Acc (Array sh d)-     -> Acc (Array sh e)-     -> Acc (Array sh f)-     -> Acc (Array sh g)-     -> Acc (Array sh h)-     -> Acc (Array sh i)-     -> Acc (Array sh (a, b, c, d, e, f, g, h, i))-zip9 = zipWith9 (\a b c d e f g h i -> lift (a,b,c,d,e,f,g,h,i))----- | The converse of 'zip', but the shape of the two results is identical to the--- shape of the argument.------ If the argument array is manifest in memory, 'unzip' is a no-op.----unzip :: (Shape sh, Elt a, Elt b)-      => Acc (Array sh (a, b))-      -> (Acc (Array sh a), Acc (Array sh b))-unzip arr = (map fst arr, map snd arr)---- | Take an array of triples and return three arrays, analogous to 'unzip'.----unzip3 :: (Shape sh, Elt a, Elt b, Elt c)-       => Acc (Array sh (a, b, c))-       -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c))-unzip3 xs = (map get1 xs, map get2 xs, map get3 xs)-  where-    get1 x = let (a,_,_) = untup3 x in a-    get2 x = let (_,b,_) = untup3 x in b-    get3 x = let (_,_,c) = untup3 x in c----- | Take an array of quadruples and return four arrays, analogous to 'unzip'.----unzip4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d)-       => Acc (Array sh (a, b, c, d))-       -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d))-unzip4 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs)-  where-    get1 x = let (a,_,_,_) = untup4 x in a-    get2 x = let (_,b,_,_) = untup4 x in b-    get3 x = let (_,_,c,_) = untup4 x in c-    get4 x = let (_,_,_,d) = untup4 x in d---- | Take an array of 5-tuples and return five arrays, analogous to 'unzip'.----unzip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)-       => Acc (Array sh (a, b, c, d, e))-       -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d), Acc (Array sh e))-unzip5 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs, map get5 xs)-  where-    get1 x = let (a,_,_,_,_) = untup5 x in a-    get2 x = let (_,b,_,_,_) = untup5 x in b-    get3 x = let (_,_,c,_,_) = untup5 x in c-    get4 x = let (_,_,_,d,_) = untup5 x in d-    get5 x = let (_,_,_,_,e) = untup5 x in e---- | Take an array of 6-tuples and return six arrays, analogous to 'unzip'.----unzip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)-       => Acc (Array sh (a, b, c, d, e, f))-       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)-          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f))-unzip6 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs, map get5 xs, map get6 xs)-  where-    get1 x = let (a,_,_,_,_,_) = untup6 x in a-    get2 x = let (_,b,_,_,_,_) = untup6 x in b-    get3 x = let (_,_,c,_,_,_) = untup6 x in c-    get4 x = let (_,_,_,d,_,_) = untup6 x in d-    get5 x = let (_,_,_,_,e,_) = untup6 x in e-    get6 x = let (_,_,_,_,_,f) = untup6 x in f---- | Take an array of 7-tuples and return seven arrays, analogous to 'unzip'.----unzip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)-       => Acc (Array sh (a, b, c, d, e, f, g))-       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)-          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)-          , Acc (Array sh g))-unzip7 xs = ( map get1 xs, map get2 xs, map get3 xs-            , map get4 xs, map get5 xs, map get6 xs-            , map get7 xs )-  where-    get1 x = let (a,_,_,_,_,_,_) = untup7 x in a-    get2 x = let (_,b,_,_,_,_,_) = untup7 x in b-    get3 x = let (_,_,c,_,_,_,_) = untup7 x in c-    get4 x = let (_,_,_,d,_,_,_) = untup7 x in d-    get5 x = let (_,_,_,_,e,_,_) = untup7 x in e-    get6 x = let (_,_,_,_,_,f,_) = untup7 x in f-    get7 x = let (_,_,_,_,_,_,g) = untup7 x in g---- | Take an array of 8-tuples and return eight arrays, analogous to 'unzip'.----unzip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)-       => Acc (Array sh (a, b, c, d, e, f, g, h))-       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)-          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)-          , Acc (Array sh g), Acc (Array sh h) )-unzip8 xs = ( map get1 xs, map get2 xs, map get3 xs-            , map get4 xs, map get5 xs, map get6 xs-            , map get7 xs, map get8 xs )-  where-    get1 x = let (a,_,_,_,_,_,_,_) = untup8 x in a-    get2 x = let (_,b,_,_,_,_,_,_) = untup8 x in b-    get3 x = let (_,_,c,_,_,_,_,_) = untup8 x in c-    get4 x = let (_,_,_,d,_,_,_,_) = untup8 x in d-    get5 x = let (_,_,_,_,e,_,_,_) = untup8 x in e-    get6 x = let (_,_,_,_,_,f,_,_) = untup8 x in f-    get7 x = let (_,_,_,_,_,_,g,_) = untup8 x in g-    get8 x = let (_,_,_,_,_,_,_,h) = untup8 x in h---- | Take an array of 8-tuples and return eight arrays, analogous to 'unzip'.----unzip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)-       => Acc (Array sh (a, b, c, d, e, f, g, h, i))-       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)-          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)-          , Acc (Array sh g), Acc (Array sh h), Acc (Array sh i))-unzip9 xs = ( map get1 xs, map get2 xs, map get3 xs-            , map get4 xs, map get5 xs, map get6 xs-            , map get7 xs, map get8 xs, map get9 xs )-  where-    get1 x = let (a,_,_,_,_,_,_,_,_) = untup9 x in a-    get2 x = let (_,b,_,_,_,_,_,_,_) = untup9 x in b-    get3 x = let (_,_,c,_,_,_,_,_,_) = untup9 x in c-    get4 x = let (_,_,_,d,_,_,_,_,_) = untup9 x in d-    get5 x = let (_,_,_,_,e,_,_,_,_) = untup9 x in e-    get6 x = let (_,_,_,_,_,f,_,_,_) = untup9 x in f-    get7 x = let (_,_,_,_,_,_,g,_,_) = untup9 x in g-    get8 x = let (_,_,_,_,_,_,_,h,_) = untup9 x in h-    get9 x = let (_,_,_,_,_,_,_,_,i) = untup9 x in i----- Reductions--- -------------- | Reduction of an array of arbitrary rank to a single scalar value. The first--- argument needs to be an /associative/ function to enable efficient parallel--- implementation. The initial element does not need to be an identity element.------ >>> let vec = fromList (Z:.10) [0..]--- >>> foldAll (+) 42 (use vec)--- Scalar Z [87]------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> foldAll (+) 0 (use mat)--- Scalar Z [1225]----foldAll-    :: (Shape sh, Elt a)-    => (Exp a -> Exp a -> Exp a)-    -> Exp a-    -> Acc (Array sh a)-    -> Acc (Scalar a)-foldAll f e arr = fold f e (flatten arr)---- | Variant of 'foldAll' that requires the reduced array to be non-empty and--- does not need a default value. The first argument must be an /associative/--- function.----fold1All-    :: (Shape sh, Elt a)-    => (Exp a -> Exp a -> Exp a)-    -> Acc (Array sh a)-    -> Acc (Scalar a)-fold1All f arr = fold1 f (flatten arr)----- Specialised reductions--- ---------------------------- Leave the results of these as scalar arrays to make it clear that these are--- array computations, and thus can not be nested.---- | Check if all elements along the innermost dimension satisfy a predicate.------ >>> let mat = fromList (Z :. 4 :. 10) [1,2,3,4,5,6,7,8,9,10,1,1,1,1,1,2,2,2,2,2,2,4,6,8,10,12,14,16,18,20,1,3,5,7,9,11,13,15,17,19] :: Array DIM2 Int--- >>> mat--- Matrix (Z :. 4 :. 10)---   [ 1, 2, 3, 4,  5,  6,  7,  8,  9, 10,---     1, 1, 1, 1,  1,  2,  2,  2,  2,  2,---     2, 4, 6, 8, 10, 12, 14, 16, 18, 20,---     1, 3, 5, 7,  9, 11, 13, 15, 17, 19]------ >>> all even (use mat)--- Vector (Z :. 4) [False,False,True,False]----all :: (Shape sh, Elt e)-    => (Exp e -> Exp Bool)-    -> Acc (Array (sh:.Int) e)-    -> Acc (Array sh Bool)-all f = and . map f---- | Check if any element along the innermost dimension satisfies the predicate.------ >>> let mat = fromList (Z :. 4 :. 10) [1,2,3,4,5,6,7,8,9,10,1,1,1,1,1,2,2,2,2,2,2,4,6,8,10,12,14,16,18,20,1,3,5,7,9,11,13,15,17,19] :: Array DIM2 Int--- >>> mat--- Matrix (Z :. 4 :. 10)---   [ 1, 2, 3, 4,  5,  6,  7,  8,  9, 10,---     1, 1, 1, 1,  1,  2,  2,  2,  2,  2,---     2, 4, 6, 8, 10, 12, 14, 16, 18, 20,---     1, 3, 5, 7,  9, 11, 13, 15, 17, 19]------ >>> any even (use mat)--- Vector (Z :. 4) [True,True,True,False]----any :: (Shape sh, Elt e)-    => (Exp e -> Exp Bool)-    -> Acc (Array (sh:.Int) e)-    -> Acc (Array sh Bool)-any f = or . map f---- | Check if all elements along the innermost dimension are 'True'.----and :: Shape sh-    => Acc (Array (sh:.Int) Bool)-    -> Acc (Array sh Bool)-and = fold (&&) (constant True)---- | Check if any element along the innermost dimension is 'True'.----or :: Shape sh-   => Acc (Array (sh:.Int) Bool)-   -> Acc (Array sh Bool)-or = fold (||) (constant False)---- | Compute the sum of elements along the innermost dimension of the array. To--- find the sum of the entire array, 'flatten' it first.------ >>> let mat = fromList (Z:.2:.5) [0..]--- Vector (Z :. 2) [10,35]----sum :: (Shape sh, Num e)-    => Acc (Array (sh:.Int) e)-    -> Acc (Array sh e)-sum = fold (+) 0---- | Compute the product of the elements along the innermost dimension of the--- array. To find the product of the entire array, 'flatten' it first.------ >>> let mat = fromList (Z:.2:.5) [0..]--- Vector (Z :. 2) [0,15120]----product-    :: (Shape sh, Num e)-    => Acc (Array (sh:.Int) e)-    -> Acc (Array sh e)-product = fold (*) 1---- | Yield the minimum element along the innermost dimension of the array. To--- find find the minimum element of the entire array, 'flatten' it first.------ The array must not be empty. See also 'fold1'.------ >>> let mat = fromList (Z :. 3 :. 4) [1,4,3,8, 0,2,8,4, 7,9,8,8]--- >>> mat--- Matrix (Z :. 3 :. 4)---   [ 1, 4, 3, 8,---     0, 2, 8, 4,---     7, 9, 8, 8]------ >>> minimum (use mat)--- Vector (Z :. 3) [1,0,7]----minimum-    :: (Shape sh, Ord e)-    => Acc (Array (sh:.Int) e)-    -> Acc (Array sh e)-minimum = fold1 min---- | Yield the maximum element along the innermost dimension of the array. To--- find the maximum element of the entire array, 'flatten' it first.------ The array must not be empty. See also 'fold1'.------ >>> let mat = fromList (Z :. 3 :. 4) [1,4,3,8, 0,2,8,4, 7,9,8,8]--- >>> mat--- Matrix (Z :. 3 :. 4)---   [ 1, 4, 3, 8,---     0, 2, 8, 4,---     7, 9, 8, 8]------ >>> maximum (use mat)--- Vector (Z :. 3) [8,8,9]----maximum-    :: (Shape sh, Ord e)-    => Acc (Array (sh:.Int) e)-    -> Acc (Array sh e)-maximum = fold1 max----- Composite scans--- ------------------- | Left-to-right pre-scan (aka exclusive scan). As for 'scan', the first--- argument must be an /associative/ function. Denotationally, we have:------ > prescanl f e = afst . scanl' f e------ >>> let vec = fromList (Z:.10) [1..10]--- >>> prescanl (+) 0 (use vec)--- Vector (Z :. 10) [0,1,3,6,10,15,21,28,36,45]----prescanl-    :: (Shape sh, Elt a)-    => (Exp a -> Exp a -> Exp a)-    -> Exp a-    -> Acc (Array (sh:.Int) a)-    -> Acc (Array (sh:.Int) a)-prescanl f e = afst . scanl' f e---- | Left-to-right post-scan, a variant of 'scanl1' with an initial value. As--- with 'scanl1', the array must not be empty. Denotationally, we have:------ > postscanl f e = map (e `f`) . scanl1 f------ >>> let vec = fromList (Z:.10) [1..10]--- >>> postscanl (+) 42 (use vec)--- Vector (Z :. 10) [43,45,48,52,57,63,70,78,87,97]----postscanl-    :: (Shape sh, Elt a)-    => (Exp a -> Exp a -> Exp a)-    -> Exp a-    -> Acc (Array (sh:.Int) a)-    -> Acc (Array (sh:.Int) a)-postscanl f e = map (e `f`) . scanl1 f---- | Right-to-left pre-scan (aka exclusive scan). As for 'scan', the first--- argument must be an /associative/ function. Denotationally, we have:------ > prescanr f e = afst . scanr' f e----prescanr-    :: (Shape sh, Elt a)-    => (Exp a -> Exp a -> Exp a)-    -> Exp a-    -> Acc (Array (sh:.Int) a)-    -> Acc (Array (sh:.Int) a)-prescanr f e = afst . scanr' f e---- | Right-to-left postscan, a variant of 'scanr1' with an initial value.--- Denotationally, we have:------ > postscanr f e = map (e `f`) . scanr1 f----postscanr-    :: (Shape sh, Elt a)-    => (Exp a -> Exp a -> Exp a)-    -> Exp a-    -> Acc (Array (sh:.Int) a)-    -> Acc (Array (sh:.Int) a)-postscanr f e = map (`f` e) . scanr1 f----- Segmented scans--- ------------------- | Segmented version of 'scanl' along the innermost dimension of an array. The--- innermost dimension must have at least as many elements as the sum of the--- segment descriptor.------ >>> let seg = fromList (Z:.4) [1,4,0,3]--- >>> seg--- Vector (Z :. 4) [1,4,0,3]------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> scanlSeg (+) 0 (use mat) (use seg)--- Matrix (Z :. 5 :. 12)---   [ 0,  0, 0,  1,  3,   6,  10, 0, 0,  5, 11,  18,---     0, 10, 0, 11, 23,  36,  50, 0, 0, 15, 31,  48,---     0, 20, 0, 21, 43,  66,  90, 0, 0, 25, 51,  78,---     0, 30, 0, 31, 63,  96, 130, 0, 0, 35, 71, 108,---     0, 40, 0, 41, 83, 126, 170, 0, 0, 45, 91, 138]----scanlSeg-    :: forall sh e i. (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Exp e-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e)-scanlSeg f z arr seg =-  if null arr || null flags-    then fill (lift (sh:.sz + length seg)) z-    else scanl1Seg f arr' seg'-  where-    sh :. sz    = unlift (shape arr) :: Exp sh :. Exp Int--    -- Segmented exclusive scan is implemented by first injecting the seed-    -- element at the head of each segment, and then performing a segmented-    -- inclusive scan.-    ---    -- This is done by creating a creating a vector entirely of the seed-    -- element, and overlaying the input data in all places other than at the-    -- start of a segment.-    ---    seg'        = map (+1) seg-    arr'        = permute const-                          (fill (lift (sh :. sz + length seg)) z)-                          (\ix -> let sx :. i = unlift ix :: Exp sh :. Exp Int-                                  in  lift (sx :. i + fromIntegral (inc ! index1 i)))-                          (take (length flags) arr)--    -- Each element in the segments must be shifted to the right one additional-    -- place for each successive segment, to make room for the seed element.-    -- Here, we make use of the fact that the vector returned by 'mkHeadFlags'-    -- contains non-unit entries, which indicate zero length segments.-    ---    flags       = mkHeadFlags seg-    inc         = scanl1 (+) flags----- | Segmented version of 'scanl'' along the innermost dimension of an array. The--- innermost dimension must have at least as many elements as the sum of the--- segment descriptor.------ The first element of the resulting tuple is a vector of scanned values. The--- second element is a vector of segment scan totals and has the same size as--- the segment vector.------ >>> let seg = fromList (Z:.4) [1,4,0,3]--- >>> seg--- Vector (Z :. 4) [1,4,0,3]------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> let (res,sums) = scanl'Seg (+) 0 (use mat) (use seg)--- >>> res--- Matrix (Z :. 5 :. 8)---   [ 0, 0,  1,  3,   6, 0,  5, 11,---     0, 0, 11, 23,  36, 0, 15, 31,---     0, 0, 21, 43,  66, 0, 25, 51,---     0, 0, 31, 63,  96, 0, 35, 71,---     0, 0, 41, 83, 126, 0, 45, 91]--- >>> sums--- Matrix (Z :. 5 :. 4)---   [  0,  10, 0,  18,---     10,  50, 0,  48,---     20,  90, 0,  78,---     30, 130, 0, 108,---     40, 170, 0, 138]----scanl'Seg-    :: forall sh e i. (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Exp e-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e, Array (sh:.Int) e)-scanl'Seg f z arr seg =-  if null arr-    then lift (arr,  fill (lift (indexTail (shape arr) :. length seg)) z)-    else lift (body, sums)-  where-    -- Segmented scan' is implemented by deconstructing a segmented exclusive-    -- scan, to separate the final value and scan body.-    ---    -- TLM: Segmented scans, and this version in particular, expend a lot of-    --      effort scanning flag arrays. On inspection it appears that several-    --      of these operations are duplicated, but this will not be picked up-    --      by sharing _observation_. Perhaps a global CSE-style pass would be-    --      beneficial.-    ---    arr'        = scanlSeg f z arr seg--    -- Extract the final reduction value for each segment, which is at the last-    -- index of each segment.-    ---    seg'        = map (+1) seg-    tails       = zipWith (+) seg $ prescanl (+) 0 seg'-    sums        = backpermute-                    (lift (indexTail (shape arr') :. length seg))-                    (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int-                            in  lift (sz :. fromIntegral (tails ! index1 i)))-                    arr'--    -- Slice out the body of each segment.-    ---    -- Build a head-flags representation based on the original segment-    -- descriptor. This contains the target length of each of the body segments,-    -- which is one fewer element than the actual bodies stored in arr'. Thus,-    -- the flags align with the last element of each body section, and when-    -- scanned, this element will be incremented over.-    ---    offset      = scanl1 (+) seg-    inc         = scanl1 (+)-                $ permute (+) (fill (index1 $ size arr + 1) 0)-                              (\ix -> index1' $ offset ! ix)-                              (fill (shape seg) (1 :: Exp i))--    len         = offset ! index1 (length offset - 1)-    body        = backpermute-                    (lift (indexTail (shape arr) :. fromIntegral len))-                    (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int-                            in  lift (sz :. i + fromIntegral (inc ! index1 i)))-                    arr'----- | Segmented version of 'scanl1' along the innermost dimension.------ As with 'scanl1', the total number of elements considered, in this case given--- by the 'sum' of segment descriptor, must not be zero. The input vector must--- contain at least this many elements.------ Zero length segments are allowed, and the behaviour is as if those entries--- were not present in the segment descriptor; that is:------ > scanl1Seg f xs [n,0,0] == scanl1Seg f xs [n]   where n /= 0------ >>> let seg = fromList (Z:.4) [1,4,0,3]--- >>> seg--- Vector (Z :. 4) [1,4,0,3]------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> scanl1Seg (+) (use mat) (use seg)--- Matrix (Z :. 5 :. 8)---   [  0,  1,  3,   6,  10,  5, 11,  18,---     10, 11, 23,  36,  50, 15, 31,  48,---     20, 21, 43,  66,  90, 25, 51,  78,---     30, 31, 63,  96, 130, 35, 71, 108,---     40, 41, 83, 126, 170, 45, 91, 138]----scanl1Seg-    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e)-scanl1Seg f arr seg-  = map snd-  . scanl1 (segmented f)-  $ zip (replicate (lift (indexTail (shape arr) :. All)) (mkHeadFlags seg)) arr---- |Segmented version of 'prescanl'.----prescanlSeg-    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Exp e-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e)-prescanlSeg f e vec seg-  = afst-  $ scanl'Seg f e vec seg---- |Segmented version of 'postscanl'.----postscanlSeg-    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Exp e-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e)-postscanlSeg f e vec seg-  = map (f e)-  $ scanl1Seg f vec seg---- | Segmented version of 'scanr' along the innermost dimension of an array. The--- innermost dimension must have at least as many elements as the sum of the--- segment descriptor.------ >>> let seg = fromList (Z:.4) [1,4,0,3]--- >>> seg--- Vector (Z :. 4) [1,4,0,3]------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> scanrSeg (+) 0 (use mat) (use seg)--- Matrix (Z :. 5 :. 12)---   [  2, 0,  18,  15, 11,  6, 0, 0,  24, 17,  9, 0,---     12, 0,  58,  45, 31, 16, 0, 0,  54, 37, 19, 0,---     22, 0,  98,  75, 51, 26, 0, 0,  84, 57, 29, 0,---     32, 0, 138, 105, 71, 36, 0, 0, 114, 77, 39, 0,---     42, 0, 178, 135, 91, 46, 0, 0, 144, 97, 49, 0]----scanrSeg-    :: forall sh e i. (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Exp e-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e)-scanrSeg f z arr seg =-  if null arr || null flags-    then fill (lift (sh :. sz + length seg)) z-    else scanr1Seg f arr' seg'-  where-    sh :. sz    = unlift (shape arr) :: Exp sh :. Exp Int--    -- Using technique described for 'scanlSeg', where we intersperse the array-    -- with the seed element at the start of each segment, and then perform an-    -- inclusive segmented scan.-    ---    flags       = mkHeadFlags seg-    inc         = scanl1 (+) flags--    seg'        = map (+1) seg-    arr'        = permute const-                          (fill (lift (sh :. sz + length seg)) z)-                          (\ix -> let sx :. i = unlift ix :: Exp sh :. Exp Int-                                  in  lift (sx :. i + fromIntegral (inc ! index1 i) - 1))-                          (drop (sz - length flags) arr)----- | Segmented version of 'scanr''.------ >>> let seg = fromList (Z:.4) [1,4,0,3]--- >>> seg--- Vector (Z :. 4) [1,4,0,3]------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> let (res,sums) = scanr'Seg (+) 0 (use mat) (use seg)--- >>> res--- Matrix (Z :. 5 :. 8)---   [ 0,  15, 11,  6, 0, 17,  9, 0,---     0,  45, 31, 16, 0, 37, 19, 0,---     0,  75, 51, 26, 0, 57, 29, 0,---     0, 105, 71, 36, 0, 77, 39, 0,---     0, 135, 91, 46, 0, 97, 49, 0]--- >>> sums--- Matrix (Z :. 5 :. 4)---   [  2,  18, 0,  24,---     12,  58, 0,  54,---     22,  98, 0,  84,---     32, 138, 0, 114,---     42, 178, 0, 144]----scanr'Seg-    :: forall sh e i. (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Exp e-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e, Array (sh:.Int) e)-scanr'Seg f z arr seg =-  if null arr-    then lift (arr,  fill (lift (indexTail (shape arr) :. length seg)) z)-    else lift (body, sums)-  where-    -- Using technique described for scanl'Seg-    ---    arr'        = scanrSeg f z arr seg--    -- reduction values-    seg'        = map (+1) seg-    heads       = prescanl (+) 0 seg'-    sums        = backpermute-                    (lift (indexTail (shape arr') :. length seg))-                    (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int-                            in  lift (sz :. fromIntegral (heads ! index1 i)))-                    arr'--    -- body segments-    flags       = mkHeadFlags seg-    inc         = scanl1 (+) flags-    body        = backpermute-                    (lift (indexTail (shape arr) :. indexHead (shape flags)))-                    (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int-                            in  lift (sz :. i + fromIntegral (inc ! index1 i)))-                    arr'----- | Segmented version of 'scanr1'.------ >>> let seg = fromList (Z:.4) [1,4,0,3]--- >>> seg--- Vector (Z :. 4) [1,4,0,3]------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> scanr1Seg (+) (use mat) (use seg)--- Matrix (Z :. 5 :. 8)---   [  0,  10,   9,  7,  4,  18, 13,  7,---     10,  50,  39, 27, 14,  48, 33, 17,---     20,  90,  69, 47, 24,  78, 53, 27,---     30, 130,  99, 67, 34, 108, 73, 37,---     40, 170, 129, 87, 44, 138, 93, 47]----scanr1Seg-    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e)-scanr1Seg f arr seg-  = map snd-  . scanr1 (flip (segmented f))-  $ zip (replicate (lift (indexTail (shape arr) :. All)) (mkTailFlags seg)) arr----- |Segmented version of 'prescanr'.----prescanrSeg-    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Exp e-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e)-prescanrSeg f e vec seg-  = afst-  $ scanr'Seg f e vec seg---- |Segmented version of 'postscanr'.----postscanrSeg-    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)-    => (Exp e -> Exp e -> Exp e)-    -> Exp e-    -> Acc (Array (sh:.Int) e)-    -> Acc (Segments i)-    -> Acc (Array (sh:.Int) e)-postscanrSeg f e vec seg-  = map (f e)-  $ scanr1Seg f vec seg----- Segmented scan helpers--- -------------------------- |Compute head flags vector from segment vector for left-scans.------ The vector will be full of zeros in the body of a segment, and non-zero--- otherwise. The "flag" value, if greater than one, indicates that several--- empty segments are represented by this single flag entry. This is additional--- data is used by exclusive segmented scan.----mkHeadFlags-    :: (Integral i, FromIntegral i Int)-    => Acc (Segments i)-    -> Acc (Segments i)-mkHeadFlags seg-  = init-  $ permute (+) zeros (\ix -> index1' (offset ! ix)) ones-  where-    (offset, len)       = unlift (scanl' (+) 0 seg)-    zeros               = fill (index1' $ the len + 1) 0-    ones                = fill (index1  $ size offset) 1---- |Compute tail flags vector from segment vector for right-scans. That is, the--- flag is placed at the last place in each segment.----mkTailFlags-    :: (Integral i, FromIntegral i Int)-    => Acc (Segments i)-    -> Acc (Segments i)-mkTailFlags seg-  = init-  $ permute (+) zeros (\ix -> index1' (the len - 1 - offset ! ix)) ones-  where-    (offset, len)       = unlift (scanr' (+) 0 seg)-    zeros               = fill (index1' $ the len + 1) 0-    ones                = fill (index1  $ size offset) 1---- |Construct a segmented version of a function from a non-segmented version.--- The segmented apply operates on a head-flag value tuple, and follows the--- procedure of Sengupta et. al.----segmented-    :: (Elt e, Num i, Bits i)-    => (Exp e -> Exp e -> Exp e)-    -> Exp (i, e)-    -> Exp (i, e)-    -> Exp (i, e)-segmented f a b =-  let (aF, aV) = unlift a-      (bF, bV) = unlift b-  in-  lift (aF .|. bF, bF /= 0 ? (bV, f aV bV))---- |Index construction and destruction generalised to integral types.------ We generalise the segment descriptor to integral types because some--- architectures, such as GPUs, have poor performance for 64-bit types. So,--- there is a tension between performance and requiring 64-bit indices for some--- applications, and we would not like to restrict ourselves to either one.------ As we don't yet support non-Int dimensions in shapes, we will need to convert--- back to concrete Int. However, don't put these generalised forms into the--- base library, because it results in too many ambiguity errors.----index1' ::  (Integral i, FromIntegral i Int) => Exp i -> Exp DIM1-index1' i = lift (Z :. fromIntegral i)----- Reshaping of arrays--- ----------------------- | Flatten the given array of arbitrary dimension into a one-dimensional--- vector. As with 'reshape', this operation performs no work.----flatten :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Acc (Vector e)-flatten a-  | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM1)-  = a-flatten a-  = reshape (index1 (size a)) a----- Enumeration and filling--- --------------------------- | Create an array where all elements are the same value.------ >>> let zeros = fill (Z:.10) 0--- Vector (Z :. 10) [0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0]----fill :: (Shape sh, Elt e) => Exp sh -> Exp e -> Acc (Array sh e)-fill sh c = generate sh (const c)---- | Create an array of the given shape containing the values @x@, @x+1@, etc.--- (in row-major order).------ >>> enumFromN (constant (Z:.5:.10)) 0 :: Array DIM2 Int--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]----enumFromN-    :: (Shape sh, Num e, FromIntegral Int e)-    => Exp sh-    -> Exp e-    -> Acc (Array sh e)-enumFromN sh x = enumFromStepN sh x 1---- | Create an array of the given shape containing the values @x@, @x+y@,--- @x+y+y@ etc. (in row-major order).------ >>> enumFromStepN (constant (Z:.5:.10)) 0 0.5 :: Array DIM2 Float--- Matrix (Z :. 5 :. 10)---   [  0.0,  0.5,  1.0,  1.5,  2.0,  2.5,  3.0,  3.5,  4.0,  4.5,---      5.0,  5.5,  6.0,  6.5,  7.0,  7.5,  8.0,  8.5,  9.0,  9.5,---     10.0, 10.5, 11.0, 11.5, 12.0, 12.5, 13.0, 13.5, 14.0, 14.5,---     15.0, 15.5, 16.0, 16.5, 17.0, 17.5, 18.0, 18.5, 19.0, 19.5,---     20.0, 20.5, 21.0, 21.5, 22.0, 22.5, 23.0, 23.5, 24.0, 24.5]----enumFromStepN-    :: (Shape sh, Num e, FromIntegral Int e)-    => Exp sh-    -> Exp e              -- ^ x: start-    -> Exp e              -- ^ y: step-    -> Acc (Array sh e)-enumFromStepN sh x y-  = reshape sh-  $ generate (index1 $ shapeSize sh)-             (\ix -> (fromIntegral (unindex1 ix :: Exp Int) * y) + x)---- Concatenation--- ----------------- | Concatenate innermost component of two arrays. The extent of the lower---   dimensional component is the intersection of the two arrays.------ >>> let m1 = fromList (Z:.5:.10) [0..]--- >>> m1--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> let m2 = fromList (Z:.10:.3) [0..]--- >>> m2--- Matrix (Z :. 10 :. 3)---   [  0,  1,  2,---      3,  4,  5,---      6,  7,  8,---      9, 10, 11,---     12, 13, 14,---     15, 16, 17,---     18, 19, 20,---     21, 22, 23,---     24, 25, 26,---     27, 28, 29]------ >>> use m1 ++ use m2--- Matrix (Z :. 5 :. 13)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,  0,  1,  2,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,  3,  4,  5,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,  6,  7,  8,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,  9, 10, 11,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 12, 13, 14]----infixr 5 ++-(++) :: forall sh e. (Slice sh, Shape sh, Elt e)-     => Acc (Array (sh :. Int) e)-     -> Acc (Array (sh :. Int) e)-     -> Acc (Array (sh :. Int) e)-(++) xs ys-  = let sh1 :. n        = unlift (shape xs)     :: Exp sh :. Exp Int-        sh2 :. m        = unlift (shape ys)     :: Exp sh :. Exp Int-    in-    generate (lift (intersect sh1 sh2 :. n + m))-             (\ix -> let sh :. i = unlift ix    :: Exp sh :. Exp Int-                     in  i < n ? ( xs ! ix, ys ! lift (sh :. i-n)) )---- TLM: If we have something like (concat . split) then the source array will---      have two use sites, but is actually safe (and better) to inline.----- Filtering--- ------------- | Drop elements that do not satisfy the predicate. Returns the elements which--- pass the predicate, together with a segment descriptor indicating how many--- elements along each outer dimension were valid.------ >>> let vec = fromList (Z :. 10) [1..10] :: Vector Int--- >>> vec--- Vector (Z :. 10) [1,2,3,4,5,6,7,8,9,10]------ >>> filter even (use vec)--- (Vector (Z :. 5) [2,4,6,8,10], Scalar Z [5])------ >>> let mat = fromList (Z :. 4 :. 10) [1,2,3,4,5,6,7,8,9,10,1,1,1,1,1,2,2,2,2,2,2,4,6,8,10,12,14,16,18,20,1,3,5,7,9,11,13,15,17,19] :: Array DIM2 Int--- >>> mat--- Matrix (Z :. 4 :. 10)---   [ 1, 2, 3, 4,  5,  6,  7,  8,  9, 10,---     1, 1, 1, 1,  1,  2,  2,  2,  2,  2,---     2, 4, 6, 8, 10, 12, 14, 16, 18, 20,---     1, 3, 5, 7,  9, 11, 13, 15, 17, 19]------ >>> filter odd (use mat)--- (Vector (Z :. 20) [1,3,5,7,9,1,1,1,1,1,1,3,5,7,9,11,13,15,17,19], Vector (Z :. 4) [5,5,0,10])----filter :: forall sh e. (Shape sh, Slice sh, Elt e)-       => (Exp e -> Exp Bool)-       -> Acc (Array (sh:.Int) e)-       -> Acc (Vector e, Array sh Int)-filter p arr-  -- Optimise 1-dimensional arrays, where we can avoid additional computations-  -- for the offset indices.-  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)-  = let-        keep            = map p arr-        (target, len)   = unlift $ scanl' (+) 0 (map boolToInt keep)-        prj ix          = keep!ix ? ( index1 (target!ix), ignore )-        dummy           = backpermute (index1 (the len)) id arr-        result          = permute const dummy prj arr-    in-    if null arr-      then lift (emptyArray, fill (constant Z) 0)-      else lift (result, len)--filter p arr-  = let-        sz              = indexTail (shape arr)-        keep            = map p arr-        (target, len)   = unlift $ scanl' (+) 0 (map boolToInt keep)-        (offset, valid) = unlift $ scanl' (+) 0 (flatten len)-        prj ix          = if keep!ix-                            then index1 $ offset!index1 (toIndex sz (indexTail ix)) + target!ix-                            else ignore-        dummy           = backpermute (index1 (the valid)) id (flatten arr)-        result          = permute const dummy prj arr-    in-    if null arr-      then lift (emptyArray, fill sz 0)-      else lift (result, len)---- FIXME: [Permute in the filter operation]------ This is abusing 'permute' in that the first two arguments, the combination--- function and array of default values, are only justified because we know the--- permutation function will write to each location in the target exactly once.------ Instead, we should have a primitive that directly encodes the compaction--- pattern of the permutation function. This may be more efficient to compute,--- and avoids the computation of the defaults array, which is ultimately wasted--- work.-----{-# NOINLINE filter #-}-{-# RULES-  "ACC filter/filter" forall f g arr.-    filter f (afst (filter g arr)) = filter (\x -> g x && f x) arr- #-}----- Gather operations--- --------------------- | Gather elements from a source array by reading values at the given indices.------ >>> let input = fromList (Z:.9) [1,9,6,4,4,2,0,1,2]--- >>> let from  = fromList (Z:.6) [1,3,7,2,5,3]--- >>> gather (use from) (use input)--- Vector (Z :. 6) [9,4,1,6,2,4]----gather-    :: (Shape sh, Elt e)-    => Acc (Array sh Int)         -- ^ index of source at each index to gather-    -> Acc (Vector e)             -- ^ source values-    -> Acc (Array sh e)-gather indices input = map (input !!) indices-  -- TLM NOTES:-  --  * (!!) has potential for later optimisation-  --  * We needn't fix the source array to Vector, but this matches the-  --    intuition that 'Int' ~ 'DIM1'.----- | Conditionally copy elements from source array to destination array--- according to an index mapping.------ In addition, the 'mask' vector and associated predication function specifies--- whether the element is copied or a default value is used instead.------ >>> let defaults = fromList (Z :. 6) [6,6,6,6,6,6]--- >>> let from     = fromList (Z :. 6) [1,3,7,2,5,3]--- >>> let mask     = fromList (Z :. 6) [3,4,9,2,7,5]--- >>> let input    = fromList (Z :. 9) [1,9,6,4,4,2,0,1,2]--- >>> gatherIf (use from) (use mask) (> 4) (use defaults) (use input)--- Vector (Z :. 6) [6,6,1,6,2,4]----gatherIf-    :: (Elt a, Elt b)-    => Acc (Vector Int)           -- ^ source indices to gather from-    -> Acc (Vector a)             -- ^ mask vector-    -> (Exp a -> Exp Bool)        -- ^ predicate function-    -> Acc (Vector b)             -- ^ default values-    -> Acc (Vector b)             -- ^ source values-    -> Acc (Vector b)-gatherIf from maskV pred defaults input = zipWith zf pf gatheredV-  where-    zf p g      = p ? (unlift g)-    gatheredV   = zip (gather from input) defaults-    pf          = map pred maskV----- Scatter operations--- ---------------------- | Overwrite elements of the destination by scattering the values of the--- source array according to the given index mapping.------ Note that if the destination index appears more than once in the mapping the--- result is undefined.------ >>> let to    = fromList (Z :. 6) [1,3,7,2,5,8]--- >>> let input = fromList (Z :. 7) [1,9,6,4,4,2,5]--- >>> scatter (use to) (fill (constant (Z:.10)) 0) (use input)--- Vector (Z :. 10) [0,1,4,9,0,4,0,6,2,0]----scatter-    :: Elt e-    => Acc (Vector Int)           -- ^ destination indices to scatter into-    -> Acc (Vector e)             -- ^ default values-    -> Acc (Vector e)             -- ^ source values-    -> Acc (Vector e)-scatter to defaults input = permute const defaults pf input'-  where-    pf ix       = index1 (to ! ix)-    input'      = backpermute (shape to `intersect` shape input) id input----- | Conditionally overwrite elements of the destination by scattering values of--- the source array according to a given index mapping, whenever the masking--- function resolves to 'True'.------ Note that if the destination index appears more than once in the mapping the--- result is undefined.------ >>> let to    = fromList (Z :. 6) [1,3,7,2,5,8]--- >>> let mask  = fromList (Z :. 6) [3,4,9,2,7,5]--- >>> let input = fromList (Z :. 7) [1,9,6,4,4,2,5]--- >>> scatterIf (use to) (use mask) (> 4) (fill (constant (Z:.10)) 0) (use input)--- Vector (Z :. 10) [0,0,0,0,0,4,0,6,2,0]----scatterIf-    :: (Elt e, Elt e')-    => Acc (Vector Int)           -- ^ destination indices to scatter into-    -> Acc (Vector e)             -- ^ mask vector-    -> (Exp e -> Exp Bool)        -- ^ predicate function-    -> Acc (Vector e')            -- ^ default values-    -> Acc (Vector e')            -- ^ source values-    -> Acc (Vector e')-scatterIf to maskV pred defaults input = permute const defaults pf input'-  where-    pf ix       = pred (maskV ! ix) ? ( index1 (to ! ix), ignore )-    input'      = backpermute (shape to `intersect` shape input) id input----- Permutations--- ---------------- | Reverse the elements of a vector.----reverse :: Elt e => Acc (Vector e) -> Acc (Vector e)-reverse xs =-  let len       = unindex1 (shape xs)-      pf i      = len - i - 1-  in  backpermute (shape xs) (ilift1 pf) xs---- | Transpose the rows and columns of a matrix.----transpose :: Elt e => Acc (Array DIM2 e) -> Acc (Array DIM2 e)-transpose mat =-  let swap = lift1 $ \(Z:.x:.y) -> Z:.y:.x :: Z:.Exp Int:.Exp Int-  in  backpermute (swap $ shape mat) swap mat----- Extracting sub-vectors--- -------------------------- | Yield the first @n@ elements in the innermost dimension of the array (plus--- all lower dimensional elements).------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> take 5 (use mat)--- Matrix (Z :. 5 :. 5)---   [  0,  1,  2,  3,  4,---     10, 11, 12, 13, 14,---     20, 21, 22, 23, 24,---     30, 31, 32, 33, 34,---     40, 41, 42, 43, 44]----take :: forall sh e. (Slice sh, Shape sh, Elt e)-     => Exp Int-     -> Acc (Array (sh :. Int) e)-     -> Acc (Array (sh :. Int) e)-take n acc =-  let n'        = the (unit (n `min` sz))-      sh :. sz  = unlift (shape acc)            :: Exp sh :. Exp Int-  in-  backpermute (lift (sh :. n')) id acc----- | Yield all but the first @n@ elements along the innermost dimension of the--- array (plus all lower dimensional elements).------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> drop 7 (use mat)--- Matrix (Z :. 5 :. 3)---   [  7,  8,  9,---     17, 18, 19,---     27, 28, 29,---     37, 38, 39,---     47, 48, 49]----drop :: forall sh e. (Slice sh, Shape sh, Elt e)-     => Exp Int-     -> Acc (Array (sh :. Int) e)-     -> Acc (Array (sh :. Int) e)-drop n acc =-  let n'        = the (unit n)-      sh :. sz  = unlift (shape acc)            :: Exp sh :. Exp Int-      index ix  = let j :. i = unlift ix        :: Exp sh :. Exp Int-                  in  lift (j :. i + n')-  in-  backpermute (lift (sh :. 0 `max` (sz - n'))) index acc----- | Yield all but the elements in the last index of the innermost dimension.------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> init (use mat)--- Matrix (Z :. 5 :. 9)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,---     10, 11, 12, 13, 14, 15, 16, 17, 18,---     20, 21, 22, 23, 24, 25, 26, 27, 28,---     30, 31, 32, 33, 34, 35, 36, 37, 38,---     40, 41, 42, 43, 44, 45, 46, 47, 48]----init :: forall sh e. (Slice sh, Shape sh, Elt e)-     => Acc (Array (sh :. Int) e)-     -> Acc (Array (sh :. Int) e)-init acc =-  let sh :. sz  = unlift (shape acc)            :: Exp sh :. Exp Int-  in  backpermute (lift (sh :. sz `min` (sz - 1))) id acc----- | Yield all but the first element along the innermost dimension of an array.--- The innermost dimension must not be empty.------ >>> let mat = fromList (Z:.5:.10) [0..]--- >>> mat--- Matrix (Z :. 5 :. 10)---   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,---     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,---     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,---     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,---     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]------ >>> tail (use mat)--- Matrix (Z :. 5 :. 9)---   [  1,  2,  3,  4,  5,  6,  7,  8,  9,---     11, 12, 13, 14, 15, 16, 17, 18, 19,---     21, 22, 23, 24, 25, 26, 27, 28, 29,---     31, 32, 33, 34, 35, 36, 37, 38, 39,---     41, 42, 43, 44, 45, 46, 47, 48, 49]----tail :: forall sh e. (Slice sh, Shape sh, Elt e)-     => Acc (Array (sh :. Int) e)-     -> Acc (Array (sh :. Int) e)-tail acc =-  let sh :. sz  = unlift (shape acc)            :: Exp sh :. Exp Int-      index ix  = let j :. i = unlift ix        :: Exp sh :. Exp Int-                  in  lift (j :. i + 1)-  in-  backpermute (lift (sh :. 0 `max` (sz - 1))) index acc----- | Yield a slit (slice) of the innermost indices of an array. Denotationally,--- we have:------ > slit i n = take n . drop i----slit :: forall sh e. (Slice sh, Shape sh, Elt e)-     => Exp Int-     -> Exp Int-     -> Acc (Array (sh :. Int) e)-     -> Acc (Array (sh :. Int) e)-slit m n acc =-  let m'        = the (unit m)-      n'        = the (unit n)-      sh :. sz  = unlift (shape acc)            :: Exp sh :. Exp Int-      index ix  = let j :. i = unlift ix        :: Exp sh :. Exp Int-                  in  lift (j :. i + m')-  in-  backpermute (lift (sh :. (n' `min` ((sz - m') `max` 0)))) index acc----- Controlling execution--- ------------------------- | Force an array expression to be evaluated, preventing it from fusing with--- other operations. Forcing operations to be computed to memory, rather than--- being fused into their consuming function, can sometimes improve performance.--- For example, computing a matrix 'transpose' could provide better memory--- locality for the subsequent operation. Preventing fusion to split large--- operations into several simpler steps could also help by reducing register--- pressure.------ Preventing fusion also means that the individual operations are available to--- be executed concurrently with other kernels. In particular, consider using--- this if you have a series of operations that are compute bound rather than--- memory bound.------ Here is the synthetic example:------ > loop :: Exp Int -> Exp Int--- > loop ticks =--- >   let clockRate = 900000   -- kHz--- >   in  while (\i -> i < clockRate * ticks) (+1) 0--- >--- > test :: Acc (Vector Int)--- > test =--- >   zip3--- >     (compute $ map loop (use $ fromList (Z:.1) [10]))--- >     (compute $ map loop (use $ fromList (Z:.1) [10]))--- >     (compute $ map loop (use $ fromList (Z:.1) [10]))--- >------ Without the use of 'compute', the operations are fused together and the three--- long-running loops are executed sequentially in a single kernel. Instead, the--- individual operations can now be executed concurrently, potentially reducing--- overall runtime.----compute :: Arrays a => Acc a -> Acc a-compute = id >-> id----- Flow control--- ---------------- | Infix version of 'acond'. If the predicate evaluates to 'True', the first--- component of the tuple is returned, else the second.------ Enabling the @RebindableSyntax@ extension will allow you to use the standard--- if-then-else syntax instead.----infix 0 ?|-(?|) :: Arrays a => Exp Bool -> (Acc a, Acc a) -> Acc a-c ?| (t, e) = acond c t e---- | An infix version of 'cond'. If the predicate evaluates to 'True', the first--- component of the tuple is returned, else the second.------ Enabling the @RebindableSyntax@ extension will allow you to use the standard--- if-then-else syntax instead.----infix 0 ?-(?) :: Elt t => Exp Bool -> (Exp t, Exp t) -> Exp t-c ? (t, e) = cond c t e---- | A case-like control structure----caseof :: (Elt a, Elt b)-       => Exp a                         -- ^ case subject-       -> [(Exp a -> Exp Bool, Exp b)]  -- ^ list of cases to attempt-       -> Exp b                         -- ^ default value-       -> Exp b-caseof _ []        e = e-caseof x ((p,b):l) e = cond (p x) b (caseof x l e)----- | For use with @-XRebindableSyntax@, this class provides 'ifThenElse' lifted--- to both scalar and array types.----class IfThenElse t where-  type EltT t a :: Constraint-  ifThenElse :: EltT t a => Exp Bool -> t a -> t a -> t a--instance IfThenElse Exp where-  type EltT Exp t = Elt t-  ifThenElse = cond--instance IfThenElse Acc where-  type EltT Acc a = Arrays a-  ifThenElse = acond----- Scalar iteration--- -------------------- | Repeatedly apply a function a fixed number of times----iterate-    :: forall a. Elt a-    => Exp Int-    -> (Exp a -> Exp a)-    -> Exp a-    -> Exp a-iterate n f z-  = let step :: (Exp Int, Exp a) -> (Exp Int, Exp a)-        step (i, acc)   = ( i+1, f acc )-    in-    snd $ while (\v -> fst v < n) (lift1 step) (lift (constant 0, z))----- Scalar bulk operations--- -------------------------- | Reduce along an innermost slice of an array /sequentially/, by applying a--- binary operator to a starting value and the array from left to right.----sfoldl :: forall sh a b. (Shape sh, Slice sh, Elt a, Elt b)-       => (Exp a -> Exp b -> Exp a)-       -> Exp a-       -> Exp sh-       -> Acc (Array (sh :. Int) b)-       -> Exp a-sfoldl f z ix xs-  = let step :: (Exp Int, Exp a) -> (Exp Int, Exp a)-        step (i, acc)   = ( i+1, acc `f` (xs ! lift (ix :. i)) )-        (_ :. n)        = unlift (shape xs)     :: Exp sh :. Exp Int-    in-    snd $ while (\v -> fst v < n) (lift1 step) (lift (constant 0, z))----- Tuples--- ---------- |Extract the first component of a scalar pair.----fst :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp a-fst e = let (x, _::Exp b) = unlift e in x---- |Extract the first component of an array pair.-{-# NOINLINE[1] afst #-}-afst :: forall a b. (Arrays a, Arrays b) => Acc (a, b) -> Acc a-afst a = let (x, _::Acc b) = unlift a in x---- |Extract the second component of a scalar pair.----snd :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp b-snd e = let (_:: Exp a, y) = unlift e in y---- | Extract the second component of an array pair-asnd :: forall a b. (Arrays a, Arrays b) => Acc (a, b) -> Acc b-asnd a = let (_::Acc a, y) = unlift a in y---- |Converts an uncurried function to a curried function.----curry :: Lift f (f a, f b) => (f (Plain (f a), Plain (f b)) -> f c) -> f a -> f b -> f c-curry f x y = f (lift (x, y))---- |Converts a curried function to a function on pairs.----uncurry :: Unlift f (f a, f b) => (f a -> f b -> f c) -> f (Plain (f a), Plain (f b)) -> f c-uncurry f t = let (x, y) = unlift t in f x y----- Shapes and indices--- ---------------------- | The one index for a rank-0 array.----index0 :: Exp Z-index0 = lift Z---- | Turn an 'Int' expression into a rank-1 indexing expression.----index1 :: Elt i => Exp i -> Exp (Z :. i)-index1 i = lift (Z :. i)---- | Turn a rank-1 indexing expression into an 'Int' expression.----unindex1 :: Elt i => Exp (Z :. i) -> Exp i-unindex1 ix = let Z :. i = unlift ix in i---- | Creates a rank-2 index from two Exp Int`s----index2-    :: (Elt i, Slice (Z :. i))-    => Exp i-    -> Exp i-    -> Exp (Z :. i :. i)-index2 i j = lift (Z :. i :. j)---- | Destructs a rank-2 index to an Exp tuple of two Int`s.----unindex2-    :: forall i. (Elt i, Slice (Z :. i))-    => Exp (Z :. i :. i)-    -> Exp (i, i)-unindex2 ix-  = let Z :. i :. j = unlift ix :: Z :. Exp i :. Exp i-    in  lift (i, j)---- | Create a rank-3 index from three Exp Int`s----index3-    :: (Elt i, Slice (Z :. i), Slice (Z :. i :. i))-    => Exp i-    -> Exp i-    -> Exp i-    -> Exp (Z :. i :. i :. i)-index3 k j i = lift (Z :. k :. j :. i)---- | Destruct a rank-3 index into an Exp tuple of Int`s-unindex3-    :: forall i. (Elt i, Slice (Z :. i), Slice (Z :. i :. i))-    => Exp (Z :. i :. i :. i)-    -> Exp (i, i, i)-unindex3 ix = let Z :. k :. j :. i = unlift ix  :: Z :. Exp i :. Exp i :. Exp i-              in  lift (k, j, i)----- Array operations with a scalar result--- ----------------------------------------- | Extract the element of a singleton array.------ > the xs  ==  xs ! Z----the :: Elt e => Acc (Scalar e) -> Exp e-the = (!index0)---- | Test whether an array is empty.----null :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp Bool-null arr = size arr == 0---- | Get the length of a vector.----length :: Elt e => Acc (Vector e) -> Exp Int-length = unindex1 . shape---{----- Sequence operations--- ------------------------------------------ | Reduce a sequence by appending all the shapes and all the elements in two--- separate vectors.----fromSeq :: (Shape sh, Elt a) => Seq [Array sh a] -> Seq (Vector sh, Vector a)-fromSeq = foldSeqFlatten f (lift (emptyArray, emptyArray))-  where-    f x sh1 a1 =-      let (sh0, a0) = unlift x-      in lift (sh0 ++ sh1, a0 ++ a1)---fromSeqElems :: (Shape sh, Elt a) => Seq [Array sh a] -> Seq (Vector a)-fromSeqElems = foldSeqFlatten f emptyArray-  where-    f a0 _ a1 = a0 ++ a1--fromSeqShapes :: (Shape sh, Elt a) => Seq [Array sh a] -> Seq (Vector sh)-fromSeqShapes = foldSeqFlatten f emptyArray-  where-    f sh0 sh1 _ = sh0 ++ sh1---- | Sequence an array on the innermost dimension.----toSeqInner :: (Shape sh, Elt a) => Acc (Array (sh :. Int) a) -> Seq [Array sh a]-toSeqInner a = toSeq (Any :. Split) a---- | Sequence a 2-dimensional array on the outermost dimension.----toSeqOuter2 :: Elt a => Acc (Array DIM2 a) -> Seq [Array DIM1 a]-toSeqOuter2 a = toSeq (Z :. Split :. All) a---- | Sequence a 3-dimensional array on the outermost dimension.-toSeqOuter3 :: Elt a => Acc (Array DIM3 a) -> Seq [Array DIM2 a]-toSeqOuter3 a = toSeq (Z :. Split :. All :. All) a---- | Generate a scalar sequence of a fixed given length, by applying--- the given scalar function at each index.-generateSeq :: Elt a => Exp Int -> (Exp Int -> Exp a) -> Seq [Scalar a]-generateSeq n f = toSeq (Z :. Split) (generate (index1 n) (f . unindex1))---}---- Utilities--- -----------emptyArray :: (Shape sh, Elt e) => Acc (Array sh e)-emptyArray = use (fromList empty [])----- Utilities--- -----------matchShapeType :: forall s t. (Shape s, Shape t) => s -> t -> Maybe (s :~: t)-matchShapeType _ _-  | Just Refl <- matchTupleType (eltType (undefined::s)) (eltType (undefined::t))-  = gcast Refl--matchShapeType _ _-  = Nothing-
− Data/Array/Accelerate/Pretty.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Pretty--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] 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.Pretty (--  -- * Pretty printing functions-  module Data.Array.Accelerate.Pretty.Print,-  module Data.Array.Accelerate.Pretty.Graphviz,--  -- * Instances of Show--) where---- standard libraries-import Text.PrettyPrint.ANSI.Leijen---- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Trafo.Base-import Data.Array.Accelerate.Pretty.Print-import Data.Array.Accelerate.Pretty.Graphviz----- Show--- -------- Explicitly enumerate Show instances for the Accelerate array AST types. If we--- instead use a generic instance of the form:------   instance Kit acc => Show (acc aenv a) where------ This matches any type of kind (* -> * -> *), which can cause problems--- interacting with other packages. See Issue #108.----instance PrettyEnv aenv => Show (OpenAcc aenv a) where-  showsPrec _ = displayS . renderStyle . pretty--instance PrettyEnv aenv => Show (DelayedOpenAcc aenv a) where-  showsPrec _ = displayS . renderStyle . pretty---- These parameterised instances are fine because there is a concrete kind------ TLM: Ugh, his new 'PrettyEnv' constraint really just enforces something---      that we already know, which is that our environments are nested---      tuples, but our type parameter 'env' doesn't capture that.----instance (Kit acc, PrettyEnv aenv) => Show (PreOpenAfun acc aenv f) where-  showsPrec _ = displayS . renderStyle . pretty--instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Show (PreOpenFun acc env aenv f) where-  showsPrec _ = displayS . renderStyle . pretty--instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Show (PreOpenExp acc env aenv t) where-  showsPrec _ = displayS . renderStyle . pretty---- instance Kit acc => Show (PreOpenSeq acc aenv senv t) where---   show s = renderStyle wide $ sep $ punctuate (text ";") $ prettySeq prettyAcc 0 0 noParens s--renderStyle :: Doc -> SimpleDoc-renderStyle = renderSmart 0.7 120---- Pretty--- --------instance PrettyEnv aenv => Pretty (OpenAcc aenv a) where-  pretty c = prettyAcc noParens prettyEnv c--instance PrettyEnv aenv => Pretty (DelayedOpenAcc aenv a) where-  pretty c = prettyAcc noParens prettyEnv c--instance (Kit acc, PrettyEnv aenv) => Pretty (PreOpenAfun acc aenv f) where-  pretty f = prettyPreOpenAfun prettyAcc prettyEnv f--instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Pretty (PreOpenFun acc env aenv f) where-  pretty f = prettyPreOpenFun prettyAcc prettyEnv prettyEnv f--instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Pretty (PreOpenExp acc env aenv t) where-  pretty e = prettyPreOpenExp prettyAcc noParens prettyEnv prettyEnv e-
− Data/Array/Accelerate/Pretty/Graphviz.hs 
@@ -1,557 +0,0 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE PatternGuards        #-}-{-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns         #-}--- |--- Module      : Data.Array.Accelerate.Pretty.Graphviz--- Copyright   : [2015..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.Pretty.Graphviz (--  Graph,-  PrettyGraph(..), Detail(..),--  graphDelayedAcc, graphDelayedAfun,--) where---- standard libraries-import Control.Applicative                              hiding ( Const, empty )-import Control.Arrow                                    ( (&&&) )-import Control.Monad.State                              ( modify, gets, state )-import Data.HashSet                                     ( HashSet )-import Data.List-import Data.Maybe-import System.IO.Unsafe                                 ( unsafePerformIO )-import Text.PrettyPrint.ANSI.Leijen                     hiding ( (<$>), parens )-import Prelude                                          hiding ( exp )-import qualified Data.Sequence                          as Seq-import qualified Data.HashSet                           as Set-import qualified Text.PrettyPrint.ANSI.Leijen           as PP---- friends-import Data.Array.Accelerate.AST                        ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), PreBoundary(..), Idx(..) )-import Data.Array.Accelerate.Array.Sugar                ( Array, Shape, Elt, Tuple(..), Atuple(..), arrays, toElt, strForeign )-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Trafo.Base-import Data.Array.Accelerate.Pretty.Print-import Data.Array.Accelerate.Pretty.Graphviz.Monad-import Data.Array.Accelerate.Pretty.Graphviz.Type----- Configuration options--- -----------------------cfgIncludeShape, cfgUnique :: Bool-cfgIncludeShape = False             -- draw edges for uses of shape information-cfgUnique       = False             -- draw a single edge per data dependency----- Environments--- ---------------- This is the standard environment typed by de Bruijn indices, where at each--- index we need to record both the pretty printed label as well its 'NodeId',--- which we use to track data dependencies.----data Aval env where-  Aempty ::                                Aval ()-  Apush  :: Aval env -> NodeId -> Label -> Aval (env, t)---- Convert to the 'Val' used by the base pretty printing module by stripping out--- the 'NodeId' part.----avalToVal :: Aval aenv -> Val aenv-avalToVal Aempty           = Empty-avalToVal (Apush aenv _ v) = Push (avalToVal aenv) (text v)--aprj :: Idx aenv t -> Aval aenv -> (NodeId, Label)        -- TLM: (Vertex, Label) ??-aprj ZeroIdx      (Apush _    n v) = (n,v)-aprj (SuccIdx ix) (Apush aenv _ _) = aprj ix aenv-#if __GLASGOW_HASKELL__ < 800-aprj _            _                = $internalError "aprj" "inconsistent valuation"-#endif----- Graph construction--- --------------------mkNode :: PNode -> Maybe Label -> Dot NodeId-mkNode (PNode ident tree deps) label =-  let node  = Node label ident tree-      edges = Seq.fromList-            $ map (\(from, to) -> Edge from (Vertex ident to))-            $ if cfgUnique then nub deps else deps-  in-  state $ \s ->-    ( ident-    , s { dotNodes = node  Seq.<| dotNodes s-        , dotEdges = edges Seq.>< dotEdges s-        }-    )----- Add [T|F] ports underneath the given tree.----mkTF :: Tree (Maybe Port, Doc) -> Tree (Maybe Port, Doc)-mkTF this =-  Forest [ this-         , Forest [ Leaf (Just "T", "T")-                  , Leaf (Just "F", "F")-                  ]-         ]----- Pretty Printing--- ===============------ The use of unsafePerformIO in the below is safe in the sense that we only--- require IO to recover the stable names of terms. At worst, if we do not--- recover the correct stable name for some reason, we will be left with--- dandling edges in the graph.-----class PrettyGraph g where-  ppGraph :: Detail -> g -> Graph--instance PrettyGraph (DelayedAcc a) where-  ppGraph = graphDelayedAcc--instance PrettyGraph (DelayedAfun a) where-  ppGraph = graphDelayedAfun--data Detail = Simple | Full--simple :: Detail -> Bool-simple Simple = True-simple _      = False---- | Generate a dependency graph for the given computation----{-# NOINLINE graphDelayedAcc #-}-graphDelayedAcc :: Detail -> DelayedAcc a -> Graph-graphDelayedAcc detail acc =-  unsafePerformIO $! evalDot (graphDelayedOpenAcc detail Aempty acc)---- | Generate a dependency graph for an array function----{-# NOINLINE graphDelayedAfun #-}-graphDelayedAfun :: Detail -> DelayedAfun f -> Graph-graphDelayedAfun detail afun = unsafePerformIO . evalDot $! do-  l <- prettyDelayedAfun detail Aempty afun-  state $ \s ->-    case Seq.viewl (dotGraph s) of-      g@(Graph l' _) Seq.:< gs | l == l' -> (g, s { dotGraph = gs })-      _                                  -> $internalError "graphDelaydAfun" "unexpected error"----- Pretty-printing data-dependency graphs--- ------------------------------------------ Partially constructed graph nodes, consists of some body text and a list of--- vertices which we will draw edges from (and later, the port we connect into).----data PDoc  = PDoc Doc [Vertex]-data PNode = PNode NodeId (Tree (Maybe Port, Doc)) [(Vertex, Maybe Port)]--graphDelayedOpenAcc-    :: Detail-    -> Aval aenv-    -> DelayedOpenAcc aenv a-    -> Dot Graph-graphDelayedOpenAcc detail aenv acc = do-  r <- prettyDelayedOpenAcc detail noParens aenv acc-  i <- mkNodeId r-  v <- mkNode r Nothing-  _ <- mkNode (PNode i (Leaf (Nothing,"result")) [(Vertex v Nothing, Nothing)]) Nothing-  mkGraph---- Generate a graph for the given term.----prettyDelayedOpenAcc-    :: forall aenv arrs.-       Detail                               -- simplified output: only print operator name-    -> (Doc -> Doc)-    -> Aval aenv-    -> DelayedOpenAcc aenv arrs-    -> Dot PNode-prettyDelayedOpenAcc _      _    _    Delayed{}            = $internalError "prettyDelayedOpenAcc" "expected manifest array"-prettyDelayedOpenAcc detail wrap aenv atop@(Manifest pacc) =-  case pacc of-    Avar ix                 -> pnode (avar ix)-    Alet bnd body           -> do-      bnd'  <- prettyDelayedOpenAcc detail noParens aenv                 bnd-      a     <- mkLabel-      ident <- mkNode bnd' (Just a)-      body' <- prettyDelayedOpenAcc detail noParens (Apush aenv ident a) body-      return body'--    Acond p t e             -> do-      ident <- mkNodeId atop-      vt    <- lift t-      ve    <- lift e-      PDoc p' vs <- ppE p-      let port = Just "P"-          doc  = mkTF $ Leaf (port, if simple detail then "?|" else p')-          deps = (vt, Just "T") : (ve, Just "F") : map (,port) vs-      return $ PNode ident doc deps--    Apply afun acc          -> apply <$> prettyDelayedAfun    detail        aenv afun-                                     <*> prettyDelayedOpenAcc detail parens aenv acc--    Awhile p f x            -> do-      ident <- mkNodeId atop-      x'    <- replant =<< prettyDelayedOpenAcc detail parens aenv x-      p'    <- prettyDelayedAfun detail aenv p-      f'    <- prettyDelayedAfun detail aenv f-      ---      let PNode _ (Leaf (Nothing,xb)) fvs = x'-          loop                            = wrap $ hang 2 (sep ["awhile", text p', text f', xb ])-      return $ PNode ident (Leaf (Nothing,loop)) fvs--    Atuple atup             -> prettyDelayedAtuple detail wrap aenv atup-    Aprj ix atup            -> do-      ident                     <- mkNodeId atop-      PNode _ (Leaf (p,d)) deps <- replant =<< prettyDelayedOpenAcc detail parens aenv atup-      return $ PNode ident (Leaf (p, wrap (prettyTupleIdx ix <+> nest 2 d))) deps--    Use arrs                -> "use"         .$ [ return $ PDoc (prettyArrays (arrays (undefined::arrs)) arrs) [] ]-    Unit e                  -> "unit"        .$ [ ppE e ]-    Generate sh f           -> "generate"    .$ [ ppSh sh, ppF f ]-    Transform sh ix f xs    -> "transform"   .$ [ ppSh sh, ppF ix, ppF f, ppA xs ]-    Reshape sh xs           -> "reshape"     .$ [ ppSh sh, ppA xs ]-    Replicate _ty ix xs     -> "replicate"   .$ [ ppSh ix, ppA xs ]-    Slice _ty xs ix         -> "slice"       .$ [ ppA xs, ppSh ix ]-    Map f xs                -> "map"         .$ [ ppF f, ppA xs ]-    ZipWith f xs ys         -> "zipWith"     .$ [ ppF f, ppA xs, ppA ys ]-    Fold f e xs             -> "fold"        .$ [ ppF f, ppE e, ppA xs ]-    Fold1 f xs              -> "fold1"       .$ [ ppF f, ppA xs ]-    FoldSeg f e xs ys       -> "foldSeg"     .$ [ ppF f, ppE e, ppA xs, ppA ys ]-    Fold1Seg f xs ys        -> "fold1Seg"    .$ [ ppF f, ppA xs, ppA ys ]-    Scanl f e xs            -> "scanl"       .$ [ ppF f, ppE e, ppA xs ]-    Scanl' f e xs           -> "scanl'"      .$ [ ppF f, ppE e, ppA xs ]-    Scanl1 f xs             -> "scanl1"      .$ [ ppF f, ppA xs ]-    Scanr f e xs            -> "scanr"       .$ [ ppF f, ppE e, ppA xs ]-    Scanr' f e xs           -> "scanr'"      .$ [ ppF f, ppE e, ppA xs ]-    Scanr1 f xs             -> "scanr1"      .$ [ ppF f, ppA xs ]-    Permute f dfts p xs     -> "permute"     .$ [ ppF f, ppA dfts, ppF p, ppA xs ]-    Backpermute sh p xs     -> "backpermute" .$ [ ppSh sh, ppF p, ppA xs ]-    Stencil sten bndy xs    -> "stencil"     .$ [ ppF sten, ppB bndy, ppA xs ]-    Stencil2 sten bndy1 acc1 bndy2 acc2-                            -> "stencil2"    .$ [ ppF sten, ppB bndy1, ppA acc1, ppB bndy2, ppA acc2 ]-    Aforeign ff _afun xs    -> "aforeign"    .$ [ return (PDoc (text (strForeign ff)) []), {- ppAf afun, -} ppA xs ]-    -- Collect{}               -> error "Collect"--  where-    (.$) :: String -> [Dot PDoc] -> Dot PNode-    name .$ docs = pnode =<< fmt name docs--    fmt :: String -> [Dot PDoc] -> Dot PDoc-    fmt name docs = do-      docs' <- sequence docs-      let args = [ x | PDoc x _ <- docs' ]-          fvs  = [ x | PDoc _ x <- docs' ]-      return $ PDoc (wrap $ hang 2 (sep [text name, if simple detail then empty else sep args]))-                    (concat fvs)--    pnode :: PDoc -> Dot PNode-    pnode (PDoc doc vs) = do-      let port = Nothing-      ident <- mkNodeId atop-      return $ PNode ident (Leaf (port, doc)) (map (,port) vs)--    -- Free variables-    ---    fvA :: FVAcc DelayedOpenAcc-    fvA env (Manifest (Avar ix)) = [ Vertex (fst $ aprj ix env) Nothing ]-    fvA _   _                    = $internalError "graphviz" "expected array variable"--    fvF :: DelayedFun aenv t -> [Vertex]-    fvF = fvPreOpenFun fvA Empty aenv--    fvE :: DelayedExp aenv t -> [Vertex]-    fvE = fvPreOpenExp fvA Empty aenv--    -- Pretty-printing-    ---    avar :: Idx aenv t -> PDoc-    avar ix = let (ident, v) = aprj ix aenv-              in  PDoc (text v) [Vertex ident Nothing]--    aenv' :: Val aenv-    aenv' = avalToVal aenv--    ppA :: DelayedOpenAcc aenv a -> Dot PDoc-    ppA (Manifest (Avar ix)) = return (avar ix)-    ppA acc@Manifest{}       = do-      -- Lift out and draw as a separate node. This can occur with the manifest-      -- array arguments to permute (defaults array) and stencil[2].-      acc'  <- prettyDelayedOpenAcc detail noParens aenv acc-      v     <- mkLabel-      ident <- mkNode acc' (Just v)-      return $ PDoc (text v) [Vertex ident Nothing]-    ppA (Delayed sh f _)-      | Shape a    <- sh                                             -- identical shape-      , Just Refl  <- match f (Lam (Body (Index a (Var ZeroIdx))))   -- identity function-      = ppA a-    ppA (Delayed sh f _) = do-      PDoc d v <- "Delayed" `fmt` [ ppSh sh, ppF f ]-      return    $ PDoc (parens d) v--    ppB :: forall sh e. (Shape sh, Elt e)-        => PreBoundary DelayedOpenAcc aenv (Array sh e)-        -> Dot PDoc-    ppB Clamp        = return (PDoc "clamp"  [])-    ppB Mirror       = return (PDoc "mirror" [])-    ppB Wrap         = return (PDoc "wrap"   [])-    ppB (Constant e) = return (PDoc (parens $ "constant" <+> text (show (toElt e :: e))) [])-    ppB (Function f) = ppF f--    ppF :: DelayedFun aenv t -> Dot PDoc-    ppF = return . uncurry PDoc . (parens . prettyDelayedFun aenv' &&& fvF)--    ppE :: DelayedExp aenv t -> Dot PDoc-    ppE = return . uncurry PDoc . (prettyDelayedExp parens aenv' &&& fvE)--    ppSh :: DelayedExp aenv sh -> Dot PDoc-    ppSh = return . uncurry PDoc . (parens . prettyDelayedExp noParens aenv' &&& fvE)--    lift :: DelayedOpenAcc aenv a -> Dot Vertex-    lift Delayed{}            = $internalError "prettyDelayedOpenAcc" "expected manifest array"-    lift (Manifest (Avar ix)) = return $ Vertex (fst (aprj ix aenv)) Nothing-    lift acc                  = do-      acc'  <- prettyDelayedOpenAcc detail noParens aenv acc-      ident <- mkNode acc' Nothing-      return $ Vertex ident Nothing--    apply :: Label -> PNode -> PNode-    apply f (PNode ident x vs) =-      let x' = case x of-                 Leaf (p,d) -> Leaf (p, wrap (text f <+> d))-                 Forest ts  -> Forest (Leaf (Nothing,text f) : ts)-      in-      PNode ident x' vs--    parens :: Doc -> Doc-    parens = PP.parens . align----- Pretty print array functions as separate sub-graphs, and return the name of--- the sub-graph as if it can be called like a function. We will add additional--- nodes at the top of the graph to represent the bound variables.------ Note: [Edge placement]------ If a node belongs to a particular graph, so too must all its edges (and--- vertices). This means that if the subgraph references anything from the--- enclosing environment, we must lift those edges out of this subgraph,--- otherwise the referenced node will be drawn inside of the subgraph.----prettyDelayedAfun-    :: Detail-    -> Aval aenv-    -> DelayedOpenAfun aenv afun-    -> Dot Label-prettyDelayedAfun detail aenv afun = do-  Graph _ ss  <- mkSubgraph (go aenv afun)-  n           <- Seq.length <$> gets dotGraph-  let label         = "afun" ++ show (n+1)-      outer         = collect aenv-      (lifted,ss')  =-        flip partition ss $ \s ->-        case s of-          E (Edge (Vertex ident _) _) -> Set.member ident outer-          _                           -> False-  ---  modify $ \s -> s { dotGraph = dotGraph s                         Seq.|> Graph label ss'-                   , dotEdges = Seq.fromList [ e | E e <- lifted ] Seq.>< dotEdges s-                   }-  return label-  where-    go :: Aval aenv' -> DelayedOpenAfun aenv' a' -> Dot Graph-    go aenv' (Abody b) = graphDelayedOpenAcc detail aenv' b-    go aenv' (Alam  f) = do-      a     <- mkLabel-      ident <- mkNodeId f-      _     <- mkNode (PNode ident (Leaf (Nothing, text a)) []) Nothing-      go (Apush aenv' ident a) f--    collect :: Aval aenv' -> HashSet NodeId-    collect Aempty        = Set.empty-    collect (Apush a i _) = Set.insert i (collect a)----- Display array tuples. This is a little tricky...----prettyDelayedAtuple-    :: forall aenv atup.-       Detail-    -> (Doc -> Doc)-    -> Aval aenv-    -> Atuple (DelayedOpenAcc aenv) atup-    -> Dot PNode-prettyDelayedAtuple detail wrap aenv atup = do-  ident         <- mkNodeId atup-  (ids, ts, vs) <- unzip3 . map (\(PNode i t v) -> (i,t,v)) <$> collect [] atup-  modify $ \s -> s { dotEdges = fmap (redirect ident ids) (dotEdges s) }-  return $ PNode ident (forest ts) (concat vs)-  where-    collect :: [PNode] -> Atuple (DelayedOpenAcc aenv) t -> Dot [PNode]-    collect acc NilAtup          = return acc-    collect acc (SnocAtup tup a) = do-      a'   <- replant =<< prettyDelayedOpenAcc detail wrap aenv a-      tup' <- collect (a':acc) tup-      return tup'--    -- Redirect any edges that pointed into one of the nodes now part of this-    -- tuple, to instead point to the container node.-    ---    redirect :: NodeId -> [NodeId] -> Edge -> Edge-    redirect new subs edge@(Edge from (Vertex to port))-      | to `elem` subs = Edge from (Vertex new port)-      | otherwise      = edge--    -- Since we have lifted out any non-leaves into separate nodes, we can-    -- simply tuple-up all of the elements.-    ---    forest :: [Tree (Maybe Port, Doc)] -> Tree (Maybe Port, Doc)-    forest leaves = Leaf (Nothing, tupled [ align d | Leaf (Nothing,d) <- leaves ])----- Lift out anything that isn't a Leaf node and output it to the graph--- immediately as a new labelled node.----replant :: PNode -> Dot PNode-replant pnode@(PNode ident tree _) =-  case tree of-    Leaf (Nothing, _) -> return pnode-    _                 -> do-      vacuous <- mkNodeId pnode-      a       <- mkLabel-      _       <- mkNode pnode (Just a)-      return   $ PNode vacuous (Leaf (Nothing, text a)) [(Vertex ident Nothing, Nothing)]----- Pretty printing scalar functions and expressions--- ------------------------------------------------------ This is done with the usual machinery. Note that we rely on knowing that all--- array operations will be lifted out of scalar expressions. This means that we--- don't really need to recurse into the scalar terms to uncover new graph--- nodes.-----prettyDelayedFun :: Val aenv -> DelayedFun aenv f -> Doc-prettyDelayedFun = prettyDelayedOpenFun Empty--prettyDelayedExp :: (Doc -> Doc) -> Val aenv -> DelayedExp aenv t -> Doc-prettyDelayedExp wrap = prettyDelayedOpenExp wrap Empty---prettyDelayedOpenFun-    :: forall env aenv f.-       Val env-    -> Val aenv-    -> DelayedOpenFun env aenv f-    -> Doc-prettyDelayedOpenFun env aenv fun = "\\\\" <> next env fun-  where-    -- graphviz will silently not print a label containing the string "->",-    -- so instead we use the special token "&rarr" for a short right arrow.-    ---    next :: Val env' -> PreOpenFun DelayedOpenAcc env' aenv f' -> Doc-    next env' (Body body) = "&rarr;" <+> prettyDelayedOpenExp noParens env' aenv body-    next env' (Lam fun')  =-      let x = char 'x' <> int (sizeEnv env')-      in  x <+> next (env' `Push` x) fun'--prettyDelayedOpenExp-    :: (Doc -> Doc)-    -> Val env-    -> Val aenv-    -> DelayedOpenExp env aenv t-    -> Doc-prettyDelayedOpenExp = prettyPreOpenExp pp-  where-    pp :: PrettyAcc DelayedOpenAcc-    pp _ aenv (Manifest (Avar ix)) = prj ix aenv-    pp _ _    _                    = $internalError "prettyDelayedOpenExp" "expected array variable"----- Data dependencies--- ----------------------- Return the data-dependencies of the given term. This is just a tree traversal--- to extract all of the free variables. We will draw an edge from each of those--- nodes (vertices) into the current term.-----type FVAcc acc = forall aenv a. Aval aenv -> acc aenv a -> [Vertex]--fvPreOpenFun-    :: forall acc env aenv fun.-       FVAcc acc-    -> Val env-    -> Aval aenv-    -> PreOpenFun acc env aenv fun-    -> [Vertex]-fvPreOpenFun fvA env aenv (Body b) = fvPreOpenExp fvA env                                          aenv b-fvPreOpenFun fvA env aenv (Lam f)  = fvPreOpenFun fvA (env `Push` (char 'x' <> int (sizeEnv env))) aenv f--fvPreOpenExp-    :: forall acc env aenv exp.-       FVAcc acc-    -> Val env-    -> Aval aenv-    -> PreOpenExp acc env aenv exp-    -> [Vertex]-fvPreOpenExp fvA env aenv = fv-  where-    fvT :: Tuple (PreOpenExp acc env aenv) t -> [Vertex]-    fvT NilTup          = []-    fvT (SnocTup tup e) = concat [ fv e, fvT tup ]--    fvF :: PreOpenFun acc env aenv f -> [Vertex]-    fvF = fvPreOpenFun fvA env aenv--    fv :: PreOpenExp acc env aenv e -> [Vertex]-    fv (Shape acc)              = if cfgIncludeShape then fvA aenv acc else []-    fv (Index acc i)            = concat [ fvA aenv acc, fv i ]-    fv (LinearIndex acc i)      = concat [ fvA aenv acc, fv i ]-    ---    fv (Let e1 e2)              = concat [ fv e1, fvPreOpenExp fvA (env `Push` (char 'x' <> int (sizeEnv env))) aenv e2 ]-    fv Var{}                    = []-    fv Const{}                  = []-    fv PrimConst{}              = []-    fv (PrimApp _ x)            = fv x-    fv (Tuple tup)              = fvT tup-    fv (Prj _ e)                = fv e-    fv IndexNil                 = []-    fv IndexAny                 = []-    fv (IndexHead sh)           = fv sh-    fv (IndexTail sh)           = fv sh-    fv (IndexCons t h)          = concat [ fv t, fv h ]-    fv (IndexSlice _ slix sh)   = concat [ fv slix, fv sh ]-    fv (IndexFull _ slix sh)    = concat [ fv slix, fv sh ]-    fv (ToIndex sh ix)          = concat [ fv sh, fv ix ]-    fv (FromIndex sh ix)        = concat [ fv sh, fv ix ]-    fv (Union sh1 sh2)          = concat [ fv sh1, fv sh2 ]-    fv (Intersect sh1 sh2)      = concat [ fv sh1, fv sh2 ]-    fv (ShapeSize sh)           = fv sh-    fv Foreign{}                = []-    fv (Cond p t e)             = concat [ fv p, fv t, fv e ]-    fv (While p f x)            = concat [ fvF p, fvF f, fv x ]-
− Data/Array/Accelerate/Pretty/Graphviz/Monad.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--- |--- Module      : Data.Array.Accelerate.Pretty.Graphviz.Monad--- Copyright   : [2015..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.Pretty.Graphviz.Monad-  where--import Control.Applicative-import Control.Monad.State-import Data.Foldable                                    ( toList )-import Data.Sequence                                    ( Seq )-import System.Mem.StableName-import Prelude-import qualified Data.Sequence                          as Seq--import Data.Array.Accelerate.Pretty.Graphviz.Type----- Graph construction state ------------------------------------------------------type Dot a    = StateT DotState IO a-data DotState = DotState-  { fresh       :: !Int-  , dotGraph    :: Seq Graph-  , dotEdges    :: Seq Edge-  , dotNodes    :: Seq Node-  }--emptyState :: DotState-emptyState =  DotState 0 Seq.empty Seq.empty Seq.empty--runDot :: Dot a -> IO (a, DotState)-runDot dot = runStateT dot emptyState--evalDot :: Dot a -> IO a-evalDot dot = fst <$> runDot dot--execDot :: Dot a -> IO DotState-execDot dot = snd <$> runDot dot----- Utilities ---------------------------------------------------------------------mkLabel :: Dot Label-mkLabel = state $ \s ->-  let n = fresh s-  in  ( 'a' : show n, s { fresh = n + 1 } )--mkNodeId :: a -> Dot NodeId-mkNodeId node = do-  sn    <- liftIO $ makeStableName node-  return $ NodeId (hashStableName sn)--mkGraph :: Dot Graph-mkGraph =-  state $ \DotState{..} ->-    ( Graph [] (toList $ fmap N dotNodes Seq.>< fmap E dotEdges Seq.>< fmap G dotGraph)-    , emptyState { fresh = fresh }-    )--mkSubgraph :: Dot Graph -> Dot Graph-mkSubgraph g = do-  n       <- gets fresh-  (r, s') <- lift . runDot $ do-    modify $ \s -> s { fresh = n }-    g-  state $ \s -> (r, s { fresh = fresh s' })-
− Data/Array/Accelerate/Pretty/Graphviz/Type.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ViewPatterns       #-}--- |--- Module      : Data.Array.Accelerate.Pretty.Graphviz.Type--- Copyright   : [2015..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)------ Simple data types for representing (simple, directed) graphs and--- pretty-printing to Graphviz dot format.----module Data.Array.Accelerate.Pretty.Graphviz.Type-  where--import Data.Maybe-import Data.Hashable-import Text.Printf-import Text.PrettyPrint.ANSI.Leijen----- Rose tree, with all information at the leaves.----data Tree a = Leaf a-            | Forest [Tree a]--instance Functor Tree where-  fmap f (Leaf x)    = Leaf (f x)-  fmap f (Forest xs) = Forest (map (fmap f) xs)----- Representation for simple Graphviz graphs----data Graph      = Graph Label [Statement]-data Statement  = N Node | E Edge | G Graph--data Node       = Node (Maybe Label) NodeId (Tree (Maybe Port, Doc))-data NodeId     = NodeId !Int---- XXX: Changed from 'Doc' to 'String' because the version of 'pretty' included---      with ghc-7.8 does not have an Eq Doc instance, which was added in---      pretty-1.1.1.2. However, we don't want to simply depend on a newer---      version of the library, because this will indirectly lead to---      a dependency on multiple versions (through, e.g., template-haskell).----type Label      = String-type Port       = String--data Vertex     = Vertex NodeId (Maybe Port)-data Edge       = Edge {- from -} Vertex-                       {-  to  -} Vertex--deriving instance Eq NodeId-deriving instance Eq Vertex--instance Hashable NodeId where-  hashWithSalt salt (NodeId ident) = hashWithSalt salt ident--instance Show Graph where-  show = show . ppGraph----- Pretty print a (directed) graph to dot format----ppGraph :: Graph -> Doc-ppGraph (Graph l ss) =-  vcat [ text "digraph" <+> text l <+> lbrace-       , nest 4 $ vcat-                $ punctuate semi-                $ text "graph [compound=true]"-                : text "node  [shape=record,fontsize=10]"-                : map ppStatement ss-       , rbrace-       ]--ppSubgraph :: Graph -> Doc-ppSubgraph (Graph l ss) =-  vcat [ text "subgraph cluster_" <> text l <+> lbrace-       , nest 4 $ vcat-                $ punctuate semi-                $ text "label" <> equals <> text l-                : map ppStatement ss-       , rbrace-       ]--ppStatement :: Statement -> Doc-ppStatement (N n) = ppNode n-ppStatement (E e) = ppEdge e-ppStatement (G g) = ppSubgraph g--ppEdge :: Edge -> Doc-ppEdge (Edge from to) = ppVertex from <+> text "->" <+> ppVertex to--ppVertex :: Vertex -> Doc-ppVertex (Vertex n p) = ppNodeId n <> maybe empty (colon<>) (fmap text p)--ppNode :: Node -> Doc-ppNode (Node label nid body) =-  hcat [ ppNodeId nid-       , brackets-       $ hcat-       $ punctuate comma-       $ catMaybes [ fmap ((\x -> text "xlabel" <> equals <> x) . dquotes . text) label-                   , Just (       text "label"  <> equals <>      dquotes (ppNodeTree body))-                   ]-       ]--ppNodeTree :: Tree (Maybe Port, Doc) -> Doc-ppNodeTree (Forest trees)      = braces $ hcat (punctuate (char '|') (map ppNodeTree trees))-ppNodeTree (Leaf (port, body)) = maybe empty (\p -> char '<' <> p <> char '>') (fmap text port) <> pp body-  where-    -- In order for the text to be properly rendered by graphviz, we need to-    -- escape some special characters. If the text takes up more than one line,-    -- then newlines '\n' need be be replaced with '\l', to ensure that the text-    -- is left justified rather than centred. The last line also needs a final-    -- '\l'. Single lines of text remain centred, which provides better-    -- formatting for short statements and port labels.-    ---    pp :: Doc -> Doc-    pp = encode . renderSmart 0.7 120--    encode :: SimpleDoc -> Doc-    encode doc =-      let-          go SFail         = error "unexpected failure rendering SimpleDoc"-          go SEmpty        = (empty, False)-          go (SChar c x)   = let (x',m) = go x in (text (escape c) <> x', m)-          go (SText _ t x) = let (x',m) = go x in (text (concatMap escape t) <> x', m)-          go (SLine i x)   = let (x',_) = go x in (text "\\l" <> spaces i <> x', True)  -- [1] left justify-          go (SSGR _ x)    = go x--          (doc',multiline) = go doc-      in-      doc' <> if multiline-                then text "\\l"-                else empty--    spaces :: Int -> Doc-    spaces i | i <= 0    = empty-             | otherwise = text (concat (replicate i "\\ "))--    escape :: Char -> String-    escape ' '  = "\\ "         -- don't collapse multiple spaces-    escape '>'  = "\\>"-    escape '<'  = "\\<"-    escape '|'  = "\\|"-    -- escape '\n' = "\\l"      -- handled at [1] instead-    escape c    = [c]--ppNodeId :: NodeId -> Doc-ppNodeId (NodeId nid) = text (printf "Node_%#0x" nid)-
− Data/Array/Accelerate/Pretty/Print.hs 
@@ -1,620 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators       #-}--- |--- Module      : Data.Array.Accelerate.Pretty.Print--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] 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.Pretty.Print (--  -- * Pretty printing-  -- ** 'OpenAcc'-  ---  prettyOpenAcc,-  prettyOpenAfun,-  prettyOpenExp,-  prettyOpenFun,--  -- ** 'PreOpenAcc'-  PrettyAcc,-  prettyPreOpenAcc,-  prettyPreOpenAfun,-  -- prettyPreOpenSeq,-  prettyPreExp, prettyPreOpenExp,-  prettyPreFun, prettyPreOpenFun,-  prettyPrim,-  prettyArrays,-  prettyTupleIdx,--  -- ** Utilities-  Val(..), PrettyEnv(..), prj, sizeEnv,-  noParens,--) where---- standard libraries-import Prelude                                          hiding ( (<$>), exp, seq )-import Data.List                                        ( isPrefixOf )-import Text.PrettyPrint.ANSI.Leijen                     hiding ( parens, tupled )-import qualified Text.PrettyPrint.ANSI.Leijen           as PP---- friends-import Data.Array.Accelerate.AST                        hiding ( Val(..), prj )-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Product----- Pretty printing--- ===============---- Pretty printing for the knot-tied 'OpenAcc'--- ----------------------------------------------- Pretty print an array expression----prettyOpenAcc :: PrettyAcc OpenAcc-prettyOpenAcc wrap aenv (OpenAcc acc) = prettyPreOpenAcc prettyOpenAcc wrap aenv acc--prettyOpenAfun :: Val aenv -> OpenAfun aenv t -> Doc-prettyOpenAfun = prettyPreOpenAfun prettyOpenAcc----- Pretty print scalar expressions----prettyOpenFun :: Val env -> Val aenv -> OpenFun env aenv fun -> Doc-prettyOpenFun = prettyPreOpenFun prettyOpenAcc--prettyOpenExp :: (Doc -> Doc) -> Val env -> Val aenv -> OpenExp env aenv t -> Doc-prettyOpenExp = prettyPreOpenExp prettyOpenAcc----- Pretty printing for open 'PreOpenAcc'--- ----------------------------------------- The type of pretty printing functions for array computations.----type PrettyAcc acc = forall aenv t.-       (Doc -> Doc)-    -> Val aenv-    -> acc aenv t-    -> Doc--prettyPreOpenAcc-    :: forall acc aenv arrs.-       PrettyAcc acc-    -> (Doc -> Doc)                             -- apply to compound expressions-    -> Val aenv                                 -- environment of array variables-    -> PreOpenAcc acc aenv arrs-    -> Doc-prettyPreOpenAcc prettyAcc wrap aenv = pp-  where-    ppE :: PreExp acc aenv e -> Doc-    ppE = prettyPreExp prettyAcc parens aenv--    ppSh :: PreExp acc aenv sh -> Doc-    ppSh x = encase (prettyPreExp prettyAcc noParens aenv x)-      where-        encase = case x of-                   Var{}    -> id-                   IndexNil -> id-                   IndexAny -> id-                   Const{}  -> id-                   _        -> parens--    ppF :: PreFun acc aenv f -> Doc-    ppF = parens . prettyPreFun prettyAcc aenv--    ppA :: acc aenv a -> Doc-    ppA = prettyAcc parens aenv--    ppAF :: PreOpenAfun acc aenv f -> Doc-    ppAF = parens . prettyPreOpenAfun prettyAcc aenv--    ppB :: forall sh e. (Shape sh, Elt e)-        => PreBoundary acc aenv (Array sh e)-        -> Doc-    ppB Clamp        = text "clamp"-    ppB Mirror       = text "mirror"-    ppB Wrap         = text "wrap"-    ppB (Constant e) = parens $ text "constant" <+> text (show (toElt e :: e))-    ppB (Function f) = ppF f--    -- pretty print a named array operation with its arguments-    name .$ docs = wrap $ hang 2 (sep (manifest (text name) : docs))--    -- The main pretty-printer-    -- ------------------------    ---    pp :: PreOpenAcc acc aenv arrs -> Doc-    pp (Alet acc1 acc2)-      | isAlet acc2'-      = if isAlet acc1'-          then wrap $ vsep [ let_ <+> a <+> equals <$> indent 2 acc1'    <+> in_, acc2' ]-          else wrap $ vsep [ hang 2 (sep [let_ <+> a <+> equals, acc1']) <+> in_, acc2' ]--      | otherwise-      = wrap $ vsep [ hang 2 (sep [let_ <+> a <+> equals, acc1']), in_ </> acc2' ]-      where-        -- TLM: derp, can't unwrap into a PreOpenAcc to pattern match on Alet-        render doc  = displayS (renderCompact (plain doc)) ""-        isAlet doc  = "let" `isPrefixOf` render doc-        acc1'       = prettyAcc noParens aenv            acc1-        acc2'       = prettyAcc noParens (aenv `Push` a) acc2-        a           = char 'a' <> int (sizeEnv aenv)--    pp (Awhile p afun acc)      = "awhile" .$ [ppAF p, ppAF afun, ppA acc]-    pp (Atuple tup)             = prettyAtuple prettyAcc aenv tup-    pp (Avar idx)               = prj idx aenv-    pp (Aprj ix arrs)           = wrap $ prettyTupleIdx ix <+> ppA arrs-    pp (Apply afun acc)         = wrap $ sep [ ppAF afun, ppA acc ]-    pp (Acond e acc1 acc2)      = wrap $ hang 3 (vsep [if_ <+> ppE e, then_ <+> ppA acc1, else_ <+> ppA acc2])-    pp (Slice _ty acc ix)       = "slice"       .$ [ ppA acc, ppE ix ]-    pp (Use arrs)               = "use"         .$ [ prettyArrays (arrays (undefined :: arrs)) arrs ]-    pp (Unit e)                 = "unit"        .$ [ ppE e ]-    pp (Generate sh f)          = "generate"    .$ [ ppSh sh, ppF f ]-    pp (Transform sh ix f acc)  = "transform"   .$ [ ppSh sh, ppF ix, ppF f, ppA acc ]-    pp (Reshape sh acc)         = "reshape"     .$ [ ppSh sh, ppA acc ]-    pp (Replicate _ty ix acc)   = "replicate"   .$ [ ppSh ix, ppA acc ]-    pp (Map f acc)              = "map"         .$ [ ppF f, ppA acc ]-    pp (ZipWith f acc1 acc2)    = "zipWith"     .$ [ ppF f, ppA acc1, ppA acc2 ]-    pp (Fold f e acc)           = "fold"        .$ [ ppF f, ppE e, ppA acc ]-    pp (Fold1 f acc)            = "fold1"       .$ [ ppF f, ppA acc ]-    pp (FoldSeg f e acc1 acc2)  = "foldSeg"     .$ [ ppF f, ppE e, ppA acc1, ppA acc2 ]-    pp (Fold1Seg f acc1 acc2)   = "fold1Seg"    .$ [ ppF f, ppA acc1, ppA acc2 ]-    pp (Scanl f e acc)          = "scanl"       .$ [ ppF f, ppE e, ppA acc ]-    pp (Scanl' f e acc)         = "scanl'"      .$ [ ppF f, ppE e, ppA acc ]-    pp (Scanl1 f acc)           = "scanl1"      .$ [ ppF f, ppA acc ]-    pp (Scanr f e acc)          = "scanr"       .$ [ ppF f, ppE e, ppA acc ]-    pp (Scanr' f e acc)         = "scanr'"      .$ [ ppF f, ppE e, ppA acc ]-    pp (Scanr1 f acc)           = "scanr1"      .$ [ ppF f, ppA acc ]-    pp (Permute f dfts p acc)   = "permute"     .$ [ ppF f, ppA dfts, ppF p, ppA acc ]-    pp (Backpermute sh p acc)   = "backpermute" .$ [ ppSh sh, ppF p, ppA acc ]-    pp (Aforeign ff _afun acc)  = "aforeign"    .$ [ text (strForeign ff), {- ppAf afun, -} ppA acc ]-    pp (Stencil sten bndy acc)  = "stencil"     .$ [ ppF sten, ppB bndy, ppA acc ]-    pp (Stencil2 sten bndy1 acc1 bndy2 acc2)-                                = "stencil2"    .$ [ ppF sten, ppB bndy1, ppA acc1, ppB bndy2, ppA acc2 ]--    -- pp (Collect s)              = wrap $ hang (text "collect") 2-    --                                    $ encloseSep lbrace rbrace semi-    --                                    $ prettyPreOpenSeq prettyAcc wrap aenv Empty s---{----- Pretty print a computation over sequences----prettyPreOpenSeq-    :: forall acc aenv senv arrs.-       PrettyAcc acc-    -> (Doc -> Doc)                             -- apply to compound expressions-    -> Val aenv                                 -- environment of array variables-    -> Val senv                                 -- environment of sequence variables-    -> PreOpenSeq acc aenv senv arrs-    -> [Doc]-prettyPreOpenSeq prettyAcc wrap aenv senv seq =-  case seq of-    Producer p s' -> prettyP p : prettyPreOpenSeq prettyAcc wrap aenv (senv `Push` var (sizeEnv senv)) s'-    Consumer c    -> [prettyC c]-    Reify ix      -> [var (idxToInt ix)]-  where-    var n         = char 's' <> int n-    name .$  docs = wrap $ hang (var (sizeEnv senv) <+> text ":=" <+> text name) 2 (sep docs)-    name ..$ docs = wrap $ hang (text name) 2 (sep docs)--    ppE :: PreExp acc aenv e -> Doc-    ppE = prettyPreExp prettyAcc parens aenv--    ppF :: PreFun acc aenv f -> Doc-    ppF = parens . prettyPreFun prettyAcc aenv--    ppA :: acc aenv a -> Doc-    ppA = prettyAcc parens aenv--    ppAF :: PreOpenAfun acc aenv f -> Doc-    ppAF = parens . prettyPreOpenAfun prettyAcc aenv--    ppX :: Idx aenv' a -> Doc-    ppX x = var (idxToInt x)--    ppSlix :: SliceIndex slix sl co sh -> Doc-    ppSlix SliceNil       = text "Z"-    ppSlix (SliceAll s)   = sep [ ppSlix s, text ":.", text "All"   ]-    ppSlix (SliceFixed s) = sep [ ppSlix s, text ":.", text "Split" ]--    prettyP :: forall a. Producer acc aenv senv a -> Doc-    prettyP p =-      case p of-        StreamIn _        -> "streamIn"      .$ [ text "..." ]-        ToSeq slix _ a    -> "toSeq"         .$ [ ppSlix slix, ppA a ]-        MapSeq f x        -> "mapSeq"        .$ [ ppAF f , ppX x ]-        ChunkedMapSeq f x -> "chunkedMapSeq" .$ [ ppAF f , ppX x ]-        ZipWithSeq f x y  -> "zipWithSeq"    .$ [ ppAF f , ppX x , ppX y ]-        ScanSeq f e x     -> "foldSeq"       .$ [ ppF f , ppE e , ppX x ]--    prettyC :: forall a. Consumer acc aenv senv a -> Doc-    prettyC c =-      case c of-        FoldSeq f e x        -> "foldSeq"        ..$ [ ppF f , ppE e , ppX x ]-        FoldSeqFlatten f a x -> "foldSeqFlatten" ..$ [ ppAF f , ppA a , ppX x ]-        Stuple t             -> tupled (prettyT t)--    prettyT :: forall t. Atuple (Consumer acc aenv senv) t -> [Doc]-    prettyT NilAtup        = []-    prettyT (SnocAtup t c) = prettyT t ++ [prettyC c]---}----- Pretty print a function over array computations.----prettyPreOpenAfun-    :: forall acc aenv f.-       PrettyAcc acc-    -> Val aenv-    -> PreOpenAfun acc aenv f-    -> Doc-prettyPreOpenAfun pp aenv afun = char '\\' <> next aenv afun-  where-    next :: Val aenv' -> PreOpenAfun acc aenv' f' -> Doc-    next aenv' (Abody body) = text "->" <+> align (pp noParens aenv' body)-    next aenv' (Alam afun') =-      let a = char 'a' <> int (sizeEnv aenv')-      in  a <+> next (aenv' `Push` a) afun'----- Pretty print a scalar function.----prettyPreFun :: PrettyAcc acc -> Val aenv -> PreFun acc aenv fun -> Doc-prettyPreFun pp = prettyPreOpenFun pp Empty--prettyPreOpenFun-    :: forall acc env aenv f.-       PrettyAcc acc-    -> Val env                                  -- environment of scalar variables-    -> Val aenv                                 -- environment of array variables-    -> PreOpenFun acc env aenv f-    -> Doc-prettyPreOpenFun pp env aenv fun = char '\\' <> next env fun-  where-    next :: Val env' -> PreOpenFun acc env' aenv f' -> Doc-    next env' (Body body) = text "->" <+> align (prettyPreOpenExp pp noParens env' aenv body)-    next env' (Lam fun')  =-      let x = char 'x' <> int (sizeEnv env')-      in  x <+> next (env' `Push` x) fun'----- Pretty print a scalar expression.----prettyPreExp :: PrettyAcc acc -> (Doc -> Doc) -> Val aenv -> PreExp acc aenv t -> Doc-prettyPreExp pp wrap = prettyPreOpenExp pp wrap Empty--prettyPreOpenExp-    :: forall acc t env aenv.-       PrettyAcc acc-    -> (Doc -> Doc)                             -- apply to compound expressions-    -> Val env                                  -- environment of scalar variables-    -> Val aenv                                 -- environment of array variables-    -> PreOpenExp acc env aenv t-    -> Doc-prettyPreOpenExp prettyAcc wrap env aenv = pp-  where-    ppE, ppE' :: PreOpenExp acc env aenv e -> Doc-    ppE  = prettyPreOpenExp prettyAcc parens env aenv-    ppE' = prettyPreOpenExp prettyAcc noParens env aenv--    ppE'' :: PreOpenExp acc env aenv sh -> Doc-    ppE'' x = encase (ppE' x)-      where-        encase = case x of-                   Var{}    -> id-                   IndexNil -> id-                   IndexAny -> id-                   Const{}  -> id-                   _        -> parens--    ppF :: PreOpenFun acc env aenv f -> Doc-    ppF = parens . prettyPreOpenFun prettyAcc env aenv--    ppA :: acc aenv a -> Doc-    ppA = prettyAcc parens aenv--    -- pretty print a named array operation with its arguments-    name .$ docs = wrap $ hang 2 (sep (text name : docs))--    -- The main pretty-printer-    -- ------------------------    ---    pp :: PreOpenExp acc env aenv t -> Doc-    pp (Let e1 e2)-      | isLet e2-      = if isLet e1-          then wrap $ vsep [ let_ <+> x <+> equals <$> indent 2 e1'    <+> in_, e2' ]-          else wrap $ vsep [ hang 2 (sep [let_ <+> x <+> equals, e1']) <+> in_, e2' ]-      | otherwise-      = wrap $ vsep [ hang 2 (sep [let_ <+> x <+> equals, e1']), in_ </> e2' ]-      where-        isLet (Let _ _)     = True-        isLet _             = False-        e1'                 = align $ prettyPreOpenExp prettyAcc noParens env            aenv e1-        e2'                 = align $ prettyPreOpenExp prettyAcc noParens (env `Push` x) aenv e2-        x                   = char 'x' <> int (sizeEnv env)--    pp (PrimApp p a)-      | Tuple (NilTup `SnocTup` x `SnocTup` y) <- a-      = if infixOp-          then wrap $ sep [ppE x, f, ppE y]-          else hang 2 (sep [f, ppE'' x, ppE'' y])-      | otherwise-      = wrap $ hang 2 (sep [f', ppE a])-      where-        -- sometimes the infix function arguments are obstructed. If so, add-        -- parentheses and print prefix.-        ---        (infixOp, f) = prettyPrim p-        f'           = if infixOp then parens f else f--    pp (PrimConst a)            = prettyConst a-    pp (Tuple tup)              = prettyTuple prettyAcc env aenv tup-    pp (Var idx)                = prj idx env-    pp (Const v)                = text $ show (toElt v :: t)-    pp (Prj idx e)              = wrap $ prettyTupleIdx idx <+> ppE e-    pp (Cond c t e)             = wrap $ hang 3 (vsep [ if_ <+> ppE' c, then_ <+> ppE' t, else_ <+> ppE' e ])-    pp IndexNil                 = char 'Z'-    pp IndexAny                 = text "indexAny"-    pp (IndexCons t h)          = sep [ ppE' t, text ":.", ppE' h ]-    pp (IndexHead ix)           = "indexHead"  .$ [ ppE ix ]-    pp (IndexTail ix)           = "indexTail"  .$ [ ppE ix ]-    pp (IndexSlice _ slix sh)   = "indexSlice" .$ [ ppE slix, ppE sh ]-    pp (IndexFull _ slix sl)    = "indexFull"  .$ [ ppE slix, ppE sl ]-    pp (ToIndex sh ix)          = "toIndex"    .$ [ ppE'' sh, ppE'' ix ]-    pp (FromIndex sh ix)        = "fromIndex"  .$ [ ppE'' sh, ppE ix ]-    pp (While p f x)            = "while"      .$ [ ppF p, ppF f, ppE x ]-    pp (Foreign ff _f e)        = "foreign"    .$ [ text (strForeign ff), {- ppF f, -} ppE e ]-    pp (Shape idx)              = "shape"      .$ [ ppA idx ]-    pp (ShapeSize idx)          = "shapeSize"  .$ [ ppE'' idx ]-    pp (Intersect sh1 sh2)      = "intersect"  .$ [ ppE'' sh1, ppE'' sh2 ]-    pp (Union sh1 sh2)          = "union"      .$ [ ppE'' sh1, ppE'' sh2 ]-    pp (Index idx i)            = wrap $ cat [ ppA idx, char '!',  ppE'' i ]-    pp (LinearIndex idx i)      = wrap $ cat [ ppA idx, text "!!", ppE'' i ]----- Pretty print nested pairs as a proper tuple.----prettyAtuple-    :: forall acc aenv t.-       PrettyAcc acc-    -> Val aenv-    -> Atuple (acc aenv) t-    -> Doc-prettyAtuple pp aenv = tupled . collect-  where-    collect :: Atuple (acc aenv) t' -> [Doc]-    collect NilAtup          = []-    collect (SnocAtup tup a) = collect tup ++ [pp noParens aenv a]--prettyTuple-    :: forall acc env aenv t.-       PrettyAcc acc-    -> Val env-    -> Val aenv-    -> Tuple (PreOpenExp acc env aenv) t-    -> Doc-prettyTuple pp env aenv = tupled . collect-  where-    collect :: Tuple (PreOpenExp acc env aenv) t' -> [Doc]-    collect NilTup          = []-    collect (SnocTup tup e) = collect tup ++ [prettyPreOpenExp pp noParens env aenv e]----- Pretty print an index for a tuple projection----prettyTupleIdx :: TupleIdx t e -> Doc-prettyTupleIdx ix = char '#' <> int (toInt ix)-  where-    toInt :: TupleIdx t e -> Int-    toInt ZeroTupIdx       = 0-    toInt (SuccTupIdx tup) = toInt tup + 1---- Pretty print a primitive constant----prettyConst :: PrimConst a -> Doc-prettyConst (PrimMinBound _) = text "minBound"-prettyConst (PrimMaxBound _) = text "maxBound"-prettyConst (PrimPi       _) = text "pi"---- Pretty print a primitive operation. The first parameter indicates whether the--- operator should be printed infix.----prettyPrim :: PrimFun a -> (Bool, Doc)-prettyPrim PrimAdd{}                = (True,  char '+')-prettyPrim PrimSub{}                = (True,  char '-')-prettyPrim PrimMul{}                = (True,  char '*')-prettyPrim PrimNeg{}                = (False, text "negate")-prettyPrim PrimAbs{}                = (False, text "abs")-prettyPrim PrimSig{}                = (False, text "signum")-prettyPrim PrimQuot{}               = (False, text "quot")-prettyPrim PrimRem{}                = (False, text "rem")-prettyPrim PrimQuotRem{}            = (False, text "quotRem")-prettyPrim PrimIDiv{}               = (False, text "div")-prettyPrim PrimMod{}                = (False, text "mod")-prettyPrim PrimDivMod{}             = (False, text "divMod")-prettyPrim PrimBAnd{}               = (True,  text ".&.")-prettyPrim PrimBOr{}                = (True,  text ".|.")-prettyPrim PrimBXor{}               = (False, text "xor")-prettyPrim PrimBNot{}               = (False, text "complement")-prettyPrim PrimBShiftL{}            = (False, text "shiftL")-prettyPrim PrimBShiftR{}            = (False, text "shiftR")-prettyPrim PrimBRotateL{}           = (False, text "rotateL")-prettyPrim PrimBRotateR{}           = (False, text "rotateR")-prettyPrim PrimPopCount{}           = (False, text "popCount")-prettyPrim PrimCountLeadingZeros{}  = (False, text "countLeadingZeros")-prettyPrim PrimCountTrailingZeros{} = (False, text "countTrailingZeros")-prettyPrim PrimFDiv{}               = (True,  char '/')-prettyPrim PrimRecip{}              = (False, text "recip")-prettyPrim PrimSin{}                = (False, text "sin")-prettyPrim PrimCos{}                = (False, text "cos")-prettyPrim PrimTan{}                = (False, text "tan")-prettyPrim PrimAsin{}               = (False, text "asin")-prettyPrim PrimAcos{}               = (False, text "acos")-prettyPrim PrimAtan{}               = (False, text "atan")-prettyPrim PrimSinh{}               = (False, text "sinh")-prettyPrim PrimCosh{}               = (False, text "cosh")-prettyPrim PrimTanh{}               = (False, text "tanh")-prettyPrim PrimAsinh{}              = (False, text "asinh")-prettyPrim PrimAcosh{}              = (False, text "acosh")-prettyPrim PrimAtanh{}              = (False, text "atanh")-prettyPrim PrimExpFloating{}        = (False, text "exp")-prettyPrim PrimSqrt{}               = (False, text "sqrt")-prettyPrim PrimLog{}                = (False, text "log")-prettyPrim PrimFPow{}               = (True,  text "**")-prettyPrim PrimLogBase{}            = (False, text "logBase")-prettyPrim PrimTruncate{}           = (False, text "truncate")-prettyPrim PrimRound{}              = (False, text "round")-prettyPrim PrimFloor{}              = (False, text "floor")-prettyPrim PrimCeiling{}            = (False, text "ceiling")-prettyPrim PrimAtan2{}              = (False, text "atan2")-prettyPrim PrimIsNaN{}              = (False, text "isNaN")-prettyPrim PrimIsInfinite{}         = (False, text "isInfinite")-prettyPrim PrimLt{}                 = (True,  text "<")-prettyPrim PrimGt{}                 = (True,  text ">")-prettyPrim PrimLtEq{}               = (True,  text "<=")-prettyPrim PrimGtEq{}               = (True,  text ">=")-prettyPrim PrimEq{}                 = (True,  text "==")-prettyPrim PrimNEq{}                = (True,  text "/=")-prettyPrim PrimMax{}                = (False, text "max")-prettyPrim PrimMin{}                = (False, text "min")-prettyPrim PrimLAnd                 = (True,  text "&&")-prettyPrim PrimLOr                  = (True,  text "||")-prettyPrim PrimLNot                 = (False, text "not")-prettyPrim PrimOrd                  = (False, text "ord")-prettyPrim PrimChr                  = (False, text "chr")-prettyPrim PrimBoolToInt            = (False, text "boolToInt")-prettyPrim PrimFromIntegral{}       = (False, text "fromIntegral")-prettyPrim PrimToFloating{}         = (False, text "toFloating")-prettyPrim (PrimCoerce _ t)         = (False, text "reinterpret_cast" <> char '<' <> text (show t) <> char '>')--{---- Pretty print type----prettyAnyType :: ScalarType a -> Doc-prettyAnyType ty = text $ show ty--}---- TLM: seems to flatten the nesting structure----prettyArrays :: ArraysR arrs -> arrs -> Doc-prettyArrays arrs = tupled . collect arrs-  where-    collect :: ArraysR arrs -> arrs -> [Doc]-    collect ArraysRunit         _        = []-    collect ArraysRarray        arr      = [prettyArray arr]-    collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2--prettyArray :: forall dim e. Array dim e -> Doc-prettyArray arr@(Array sh _)-  = hang 2 $ sep [ text "Array"-                 , parens . text $ showShape (toElt sh :: dim)-                 , dataDoc ]-  where-    showDoc :: forall a. Show a => a -> Doc-    showDoc = text . show-    l       = toList arr-    dataDoc | length l <= 1000 = showDoc l-            | otherwise        = showDoc (take 1000 l) <+>-                                 text "{truncated at 1000 elements}"----- Auxiliary pretty printing combinators-----parens :: Doc -> Doc-parens = PP.parens . align--noParens :: Doc -> Doc-noParens = id--tupled :: [Doc] -> Doc-tupled = PP.tupled . map align----- ANSI colourisation-----control :: Doc -> Doc-control = dullyellow--manifest :: Doc -> Doc-manifest = blue---- delayed :: Doc -> Doc--- delayed = green--let_, in_ :: Doc-let_ = control (text "let")-in_  = control (text "in")--if_, then_, else_ :: Doc-if_   = control (text "if")-then_ = control (text "then")-else_ = control (text "else")----- Environments--- --------------data Val env where-  Empty ::                   Val ()-  Push  :: Val env -> Doc -> Val (env, t)--class PrettyEnv env where-  prettyEnv :: Val env--instance PrettyEnv () where-  prettyEnv = Empty--instance PrettyEnv env => PrettyEnv (env, t) where-  prettyEnv =-    let env = prettyEnv :: Val env-        x   = char 'a' <> int (sizeEnv env)-    in-    env `Push` x--sizeEnv :: Val env -> Int-sizeEnv Empty        = 0-sizeEnv (Push env _) = 1 + sizeEnv env--prj :: Idx env t -> Val env -> Doc-prj ZeroIdx      (Push _ v)   = v-prj (SuccIdx ix) (Push env _) = prj ix env-#if __GLASGOW_HASKELL__ < 800-prj _            _            = error "inconsistent valuation"-#endif----- Auxiliary operations--- ------------------------ Auxiliary dictionary operations-----{---- Show scalar values----runScalarShow :: ScalarType a -> (a -> String)-runScalarShow (NumScalarType (IntegralNumType ty))-  | IntegralDict <- integralDict ty = show-runScalarShow (NumScalarType (FloatingNumType ty))-  | FloatingDict <- floatingDict ty = show-runScalarShow (NonNumScalarType ty)-  | NonNumDict   <- nonNumDict ty   = show--}-
− Data/Array/Accelerate/Product.hs 
@@ -1,177 +0,0 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE UndecidableInstances  #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Product--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell---               [2013..2017] Robert Clifton-Everest--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Our representation of products are heterogenous snoc lists, which are typed by--- type lists, where '()' and '(,)' are type-level nil and snoc, respectively.--- The components may only be drawn from types that can be used as array--- elements.-----module Data.Array.Accelerate.Product (--  -- * Tuple representation-  TupleIdx(..), IsProduct(..), ProdR(..)--) where----- |Type-safe projection indices for tuples.------ NB: We index tuples by starting to count from the *right*!----data TupleIdx t e where-  ZeroTupIdx ::                 TupleIdx (t, s) s-  SuccTupIdx :: TupleIdx t e -> TupleIdx (t, s) e---- |Product reification----data ProdR cst t where-  ProdRunit   :: ProdR cst ()-  ProdRsnoc   :: cst e => ProdR cst t -> ProdR cst (t,e)---- |Conversion between surface product types and our product representation.------ We parameterise our products by a constraint on their elements (the 'cst' argument). Every element--- in the product must obey this constraint, but the products themselves do necessarily not have to.----class IsProduct cst tup where-  type ProdRepr tup-  fromProd :: proxy cst -> tup -> ProdRepr tup-  toProd   :: proxy cst -> ProdRepr tup -> tup-  prod     :: proxy cst -> {- dummy -} tup -> ProdR cst (ProdRepr tup)--instance IsProduct cst () where-  type ProdRepr ()   = ()-  fromProd _         = id-  toProd _           = id-  prod _ _           = ProdRunit--instance (cst a, cst b) => IsProduct cst (a, b) where-  type ProdRepr (a, b)   = (((), a), b)-  fromProd _ (a, b)      = (((), a), b)-  toProd _ (((), a), b)  = (a, b)-  prod _ _               = ProdRsnoc $ ProdRsnoc ProdRunit--instance (cst a, cst b, cst c) => IsProduct cst (a, b, c) where-  type ProdRepr (a, b, c)    = (ProdRepr (a, b), c)-  fromProd _ (a, b, c)       = ((((), a), b), c)-  toProd _ ((((), a), b), c) = (a, b, c)-  prod p _                   = ProdRsnoc (prod p (undefined :: (a,b)))--instance (cst a, cst b, cst c, cst d) => IsProduct cst (a, b, c, d) where-  type ProdRepr (a, b, c, d)      = (ProdRepr (a, b, c), d)-  fromProd _ (a, b, c, d)         = (((((), a), b), c), d)-  toProd _ (((((), a), b), c), d) = (a, b, c, d)-  prod p _                        = ProdRsnoc (prod p (undefined :: (a,b,c)))--instance (cst a, cst b, cst c, cst d, cst e) => IsProduct cst (a, b, c, d, e) where-  type ProdRepr (a, b, c, d, e)        = (ProdRepr (a, b, c, d), e)-  fromProd _ (a, b, c, d, e)           = ((((((), a), b), c), d), e)-  toProd _ ((((((), a), b), c), d), e) = (a, b, c, d, e)-  prod p _                             = ProdRsnoc (prod p (undefined :: (a,b,c,d)))--instance (cst a, cst b, cst c, cst d, cst e, cst f) => IsProduct cst (a, b, c, d, e, f) where-  type ProdRepr (a, b, c, d, e, f)          = (ProdRepr (a, b, c, d, e), f)-  fromProd _ (a, b, c, d, e, f)             = (((((((), a), b), c), d), e), f)-  toProd _ (((((((), a), b), c), d), e), f) = (a, b, c, d, e, f)-  prod p _                                  = ProdRsnoc (prod p (undefined :: (a,b,c,d,e)))--instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g)-  => IsProduct cst (a, b, c, d, e, f, g) where-  type ProdRepr (a, b, c, d, e, f, g)            = (ProdRepr (a, b, c, d, e, f), g)-  fromProd _ (a, b, c, d, e, f, g)               = ((((((((), a), b), c), d), e), f), g)-  toProd _ ((((((((), a), b), c), d), e), f), g) = (a, b, c, d, e, f, g)-  prod p _                                       = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f)))--instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h)-  => IsProduct cst (a, b, c, d, e, f, g, h) where-  type ProdRepr (a, b, c, d, e, f, g, h)              = (ProdRepr (a, b, c, d, e, f, g), h)-  fromProd _ (a, b, c, d, e, f, g, h)                 = (((((((((), a), b), c), d), e), f), g), h)-  toProd _ (((((((((), a), b), c), d), e), f), g), h) = (a, b, c, d, e, f, g, h)-  prod p _                                            = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g)))--instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i)-  => IsProduct cst (a, b, c, d, e, f, g, h, i) where-  type ProdRepr (a, b, c, d, e, f, g, h, i) = (ProdRepr (a, b, c, d, e, f, g, h), i)-  fromProd _ (a, b, c, d, e, f, g, h, i)-    = ((((((((((), a), b), c), d), e), f), g), h), i)-  toProd _ ((((((((((), a), b), c), d), e), f), g), h), i)-    = (a, b, c, d, e, f, g, h, i)-  prod p _-    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h)))--instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j)-  => IsProduct cst (a, b, c, d, e, f, g, h, i, j) where-  type ProdRepr (a, b, c, d, e, f, g, h, i, j) = (ProdRepr (a, b, c, d, e, f, g, h, i), j)-  fromProd _ (a, b, c, d, e, f, g, h, i, j)-    = (((((((((((), a), b), c), d), e), f), g), h), i), j)-  toProd _ (((((((((((), a), b), c), d), e), f), g), h), i), j)-    = (a, b, c, d, e, f, g, h, i, j)-  prod p _-    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i)))--instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k)-  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k) where-  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k) = (ProdRepr (a, b, c, d, e, f, g, h, i, j), k)-  fromProd _ (a, b, c, d, e, f, g, h, i, j, k)-    = ((((((((((((), a), b), c), d), e), f), g), h), i), j), k)-  toProd _ ((((((((((((), a), b), c), d), e), f), g), h), i), j), k)-    = (a, b, c, d, e, f, g, h, i, j, k)-  prod p _-    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j)))--instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k, cst l)-  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k, l) where-  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l) = (ProdRepr (a, b, c, d, e, f, g, h, i, j, k), l)-  fromProd _ (a, b, c, d, e, f, g, h, i, j, k, l)-    = (((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l)-  toProd _ (((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l)-    = (a, b, c, d, e, f, g, h, i, j, k, l)-  prod p _-    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j,k)))--instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k, cst l, cst m)-  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k, l, m) where-  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m) = (ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l), m)-  fromProd _ (a, b, c, d, e, f, g, h, i, j, k, l, m)-    = ((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m)-  toProd _ ((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m)-    = (a, b, c, d, e, f, g, h, i, j, k, l, m)-  prod p _-    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j,k,l)))--instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k, cst l, cst m, cst n)-  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where-  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = (ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m), n)-  fromProd _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-    = (((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n)-  toProd _ (((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n)-    = (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-  prod p _-    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j,k,l,m)))--instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k, cst l, cst m, cst n, cst o)-  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where-  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = (ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n), o)-  fromProd _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-    = ((((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n), o)-  toProd _ ((((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n), o)-    = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-  prod p _-    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n)))-
− Data/Array/Accelerate/Smart.hs 
@@ -1,2129 +0,0 @@-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Smart--- 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)------ This modules defines the AST of the user-visible embedded language using more--- convenient higher-order abstract syntax (instead of de Bruijn indices).--- Moreover, it defines smart constructors to construct programs.-----module Data.Array.Accelerate.Smart (--  -- * HOAS AST-  Acc(..), PreAcc(..), Exp(..), PreExp(..), Boundary(..), PreBoundary(..), Stencil(..), Level,--  -- * Smart constructors for literals-  constant,--  -- * Smart constructors and destructors for tuples-  tup2, tup3, tup4, tup5, tup6, tup7, tup8, tup9, tup10, tup11, tup12, tup13, tup14, tup15,-  untup2, untup3, untup4, untup5, untup6, untup7, untup8, untup9, untup10, untup11, untup12, untup13, untup14, untup15,--  atup2, atup3, atup4, atup5, atup6, atup7, atup8, atup9, atup10, atup11, atup12, atup13, atup14, atup15,-  unatup2, unatup3, unatup4, unatup5, unatup6, unatup7, unatup8, unatup9, unatup10, unatup11, unatup12, unatup13, unatup14, unatup15,--  -- * Smart constructors for constants-  mkMinBound, mkMaxBound, mkPi,-  mkSin, mkCos, mkTan,-  mkAsin, mkAcos, mkAtan,-  mkSinh, mkCosh, mkTanh,-  mkAsinh, mkAcosh, mkAtanh,-  mkExpFloating, mkSqrt, mkLog,-  mkFPow, mkLogBase,-  mkTruncate, mkRound, mkFloor, mkCeiling,-  mkAtan2,--  -- * Smart constructors for primitive functions-  mkAdd, mkSub, mkMul, mkNeg, mkAbs, mkSig, mkQuot, mkRem, mkQuotRem, mkIDiv, mkMod, mkDivMod,-  mkBAnd, mkBOr, mkBXor, mkBNot, mkBShiftL, mkBShiftR, mkBRotateL, mkBRotateR, mkPopCount, mkCountLeadingZeros, mkCountTrailingZeros,-  mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq, mkEq, mkNEq, mkMax, mkMin,-  mkLAnd, mkLOr, mkLNot, mkIsNaN, mkIsInfinite,--  -- * Smart constructors for type coercion functions-  mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkUnsafeCoerce,--  -- * Auxiliary functions-  ($$), ($$$), ($$$$), ($$$$$),--  -- Debugging-  showPreAccOp, showPreExpOp,--) where---- standard library-import Prelude                                  hiding ( exp )-import Data.List-import Data.Typeable---- friends-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.AST                hiding ( PreOpenAcc(..), OpenAcc(..), Acc-                                                       , PreOpenExp(..), OpenExp, PreExp, Exp-                                                       , Stencil(..), PreBoundary(..), Boundary-                                                       , showPreAccOp, showPreExpOp )-import qualified Data.Array.Accelerate.AST      as AST---- Array computations--- ---------------------- | Accelerate is an /embedded language/ that distinguishes between vanilla--- arrays (e.g. in Haskell memory on the CPU) and embedded arrays (e.g. in--- device memory on a GPU), as well as the computations on both of these. Since--- Accelerate is an embedded language, programs written in Accelerate are not--- compiled by the Haskell compiler (GHC). Rather, each Accelerate backend is--- a /runtime compiler/ which generates and executes parallel SIMD code of the--- target language at application /runtime/.------ The type constructor 'Acc' represents embedded collective array operations.--- A term of type @Acc a@ is an Accelerate program which, once executed, will--- produce a value of type 'a' (an 'Array' or a tuple of 'Arrays'). Collective--- operations of type @Acc a@ comprise many /scalar expressions/, wrapped in--- type constructor 'Exp', which will be executed in parallel. Although--- collective operations comprise many scalar operations executed in parallel,--- scalar operations /cannot/ initiate new collective operations: this--- stratification between scalar operations in 'Exp' and array operations in--- 'Acc' helps statically exclude /nested data parallelism/, which is difficult--- to execute efficiently on constrained hardware such as GPUs.------ For example, to compute a vector dot product we could write:------ > dotp :: Num a => Vector a -> Vector a -> Acc (Scalar a)--- > dotp xs ys =--- >   let--- >       xs' = use xs--- >       ys' = use ys--- >   in--- >   fold (+) 0 ( zipWith (*) xs' ys' )------ The function @dotp@ consumes two one-dimensional arrays ('Vector's) of--- values, and produces a single ('Scalar') result as output. As the return type--- is wrapped in the type 'Acc', we see that it is an embedded Accelerate--- computation - it will be evaluated in the /object/ language of dynamically--- generated parallel code, rather than the /meta/ language of vanilla Haskell.------ As the arguments to @dotp@ are plain Haskell arrays, to make these available--- to Accelerate computations they must be embedded with the--- 'Data.Array.Accelerate.Language.use' function.------ An Accelerate backend is used to evaluate the embedded computation and return--- the result back to vanilla Haskell. Calling the 'run' function of a backend--- will generate code for the target architecture, compile, and execute it. For--- example, the following backends are available:------  * <http://hackage.haskell.org/package/accelerate-llvm-native accelerate-llvm-native>: for execution on multicore CPUs---  * <http://hackage.haskell.org/package/accelerate-llvm-ptx accelerate-llvm-ptx>: for execution on NVIDIA CUDA-capable GPUs------ See also 'Exp', which encapsulates embedded /scalar/ computations.------ [/Fusion:/]------ Array computations of type 'Acc' will be subject to /array fusion/;--- Accelerate will combine individual 'Acc' computations into a single--- computation, which reduces the number of traversals over the input data and--- thus improves performance. As such, it is often useful to have some intuition--- on when fusion should occur.------ The main idea is to first partition array operations into two categories:------   1. Element-wise operations, such as 'Data.Array.Accelerate.map',---      'Data.Array.Accelerate.generate', and---      'Data.Array.Accelerate.backpermute'. Each element of these operations---      can be computed independently of all others.------   2. Collective operations such as 'Data.Array.Accelerate.fold',---      'Data.Array.Accelerate.scanl', and 'Data.Array.Accelerate.stencil'. To---      compute each output element of these operations requires reading---      multiple elements from the input array(s).------ Element-wise operations fuse together whenever the consumer operation uses--- a single element of the input array. Element-wise operations can both fuse--- their inputs into themselves, as well be fused into later operations. Both--- these examples should fuse into a single loop:------ > map -> reverse -> reshape -> map -> map------ > map -> backpermute ->--- >                       zipWith -> map--- >           generate ->------ If the consumer operation uses more than one element of the input array--- (typically, via 'Data.Array.Accelerate.generate' indexing an array multiple--- times), then the input array will be completely evaluated first; no fusion--- occurs in this case, because fusing the first operation into the second--- implies duplicating work.------ On the other hand, collective operations can fuse their input arrays into--- themselves, but on output always evaluate to an array; collective operations--- will not be fused into a later step. For example:------ >      use ->--- >             zipWith -> fold |-> map--- > generate ->------ Here the element-wise sequence ('Data.Array.Accelerate.use'--- + 'Data.Array.Accelerate.generate' + 'Data.Array.Accelerate.zipWith') will--- fuse into a single operation, which then fuses into the collective--- 'Data.Array.Accelerate.fold' operation. At this point in the program the--- 'Data.Array.Accelerate.fold' must now be evaluated. In the final step the--- 'Data.Array.Accelerate.map' reads in the array produced by--- 'Data.Array.Accelerate.fold'. As there is no fusion between the--- 'Data.Array.Accelerate.fold' and 'Data.Array.Accelerate.map' steps, this--- program consists of two "loops"; one for the 'Data.Array.Accelerate.use'--- + 'Data.Array.Accelerate.generate' + 'Data.Array.Accelerate.zipWith'--- + 'Data.Array.Accelerate.fold' step, and one for the final--- 'Data.Array.Accelerate.map' step.------ You can see how many operations will be executed in the fused program by--- 'Show'-ing the 'Acc' program, or by using the debugging option @-ddump-dot@--- to save the program as a graphviz DOT file.------ As a special note, the operations 'Data.Array.Accelerate.unzip' and--- 'Data.Array.Accelerate.reshape', when applied to a real array, are executed--- in constant time, so in this situation these operations will not be fused.------ [/Tips:/]------  * Since 'Acc' represents embedded computations that will only be executed---    when evaluated by a backend, we can programatically generate these---    computations using the meta language Haskell; for example, unrolling loops---    or embedding input values into the generated code.------  * It is usually best to keep all intermediate computations in 'Acc', and---    only 'run' the computation at the very end to produce the final result.---    This enables optimisations between intermediate results (e.g. array---    fusion) and, if the target architecture has a separate memory space as is---    the case of GPUs, to prevent excessive data transfers.----newtype Acc a = Acc (PreAcc Acc Exp a)-deriving instance Typeable Acc----- The level of lambda-bound variables. The root has level 0; then it increases with each bound--- variable — i.e., it is the same as the size of the environment at the defining occurrence.----type Level = Int---- | Array-valued collective computations without a recursive knot----data PreAcc acc exp as where-    -- Needed for conversion to de Bruijn form-  Atag          :: Arrays as-                => Level                        -- environment size at defining occurrence-                -> PreAcc acc exp as--  Pipe          :: (Arrays as, Arrays bs, Arrays cs)-                => (Acc as -> acc bs)-                -> (Acc bs -> acc cs)-                -> acc as-                -> PreAcc acc exp cs--  Aforeign      :: (Arrays as, Arrays bs, Foreign asm)-                => asm (as -> bs)-                -> (Acc as -> Acc bs)-                -> acc as-                -> PreAcc acc exp bs--  Acond         :: Arrays as-                => exp Bool-                -> acc as-                -> acc as-                -> PreAcc acc exp as--  Awhile        :: Arrays arrs-                => (Acc arrs -> acc (Scalar Bool))-                -> (Acc arrs -> acc arrs)-                -> acc arrs-                -> PreAcc acc exp arrs--  Atuple        :: (Arrays arrs, IsAtuple arrs)-                => Atuple acc (TupleRepr arrs)-                -> PreAcc acc exp arrs--  Aprj          :: (Arrays arrs, IsAtuple arrs, Arrays a)-                => TupleIdx (TupleRepr arrs) a-                ->        acc     arrs-                -> PreAcc acc exp a--  Use           :: Arrays arrs-                => arrs-                -> PreAcc acc exp arrs--  Unit          :: Elt e-                => exp e-                -> PreAcc acc exp (Scalar e)--  Generate      :: (Shape sh, Elt e)-                => exp sh-                -> (Exp sh -> exp e)-                -> PreAcc acc exp (Array sh e)--  Reshape       :: (Shape sh, Shape sh', Elt e)-                => exp sh-                -> acc (Array sh' e)-                -> PreAcc acc exp (Array sh e)--  Replicate     :: (Slice slix, Elt e)-                => exp slix-                -> acc            (Array (SliceShape slix) e)-                -> PreAcc acc exp (Array (FullShape  slix) e)--  Slice         :: (Slice slix, Elt e)-                => acc            (Array (FullShape  slix) e)-                -> exp slix-                -> PreAcc acc exp (Array (SliceShape slix) e)--  Map           :: (Shape sh, Elt e, Elt e')-                => (Exp e -> exp e')-                -> acc (Array sh e)-                -> PreAcc acc exp (Array sh e')--  ZipWith       :: (Shape sh, Elt e1, Elt e2, Elt e3)-                => (Exp e1 -> Exp e2 -> exp e3)-                -> acc (Array sh e1)-                -> acc (Array sh e2)-                -> PreAcc acc exp (Array sh e3)--  Fold          :: (Shape sh, Elt e)-                => (Exp e -> Exp e -> exp e)-                -> exp e-                -> acc (Array (sh:.Int) e)-                -> PreAcc acc exp (Array sh e)--  Fold1         :: (Shape sh, Elt e)-                => (Exp e -> Exp e -> exp e)-                -> acc (Array (sh:.Int) e)-                -> PreAcc acc exp (Array sh e)--  FoldSeg       :: (Shape sh, Elt e, Elt i, IsIntegral i)-                => (Exp e -> Exp e -> exp e)-                -> exp e-                -> acc (Array (sh:.Int) e)-                -> acc (Segments i)-                -> PreAcc acc exp (Array (sh:.Int) e)--  Fold1Seg      :: (Shape sh, Elt e, Elt i, IsIntegral i)-                => (Exp e -> Exp e -> exp e)-                -> acc (Array (sh:.Int) e)-                -> acc (Segments i)-                -> PreAcc acc exp (Array (sh:.Int) e)--  Scanl         :: (Shape sh, Elt e)-                => (Exp e -> Exp e -> exp e)-                -> exp e-                -> acc (Array (sh :. Int) e)-                -> PreAcc acc exp (Array (sh :. Int) e)--  Scanl'        :: (Shape sh, Elt e)-                => (Exp e -> Exp e -> exp e)-                -> exp e-                -> acc (Array (sh :. Int) e)-                -> PreAcc acc exp (Array (sh :. Int) e, Array sh e)--  Scanl1        :: (Shape sh, Elt e)-                => (Exp e -> Exp e -> exp e)-                -> acc (Array (sh :. Int) e)-                -> PreAcc acc exp (Array (sh :. Int) e)--  Scanr         :: (Shape sh, Elt e)-                => (Exp e -> Exp e -> exp e)-                -> exp e-                -> acc (Array (sh :. Int) e)-                -> PreAcc acc exp (Array (sh :. Int) e)--  Scanr'        :: (Shape sh, Elt e)-                => (Exp e -> Exp e -> exp e)-                -> exp e-                -> acc (Array (sh :. Int) e)-                -> PreAcc acc exp (Array (sh :. Int) e, Array sh e)--  Scanr1        :: (Shape sh, Elt e)-                => (Exp e -> Exp e -> exp e)-                -> acc (Array (sh :. Int) e)-                -> PreAcc acc exp (Array (sh :. Int) e)--  Permute       :: (Shape sh, Shape sh', Elt e)-                => (Exp e -> Exp e -> exp e)-                -> acc (Array sh' e)-                -> (Exp sh -> exp sh')-                -> acc (Array sh e)-                -> PreAcc acc exp (Array sh' e)--  Backpermute   :: (Shape sh, Shape sh', Elt e)-                => exp sh'-                -> (Exp sh' -> exp sh)-                -> acc (Array sh e)-                -> PreAcc acc exp (Array sh' e)--  Stencil       :: (Shape sh, Elt a, Elt b, Stencil sh a stencil)-                => (stencil -> exp b)-                -> PreBoundary acc exp (Array sh a)-                -> acc (Array sh a)-                -> PreAcc acc exp (Array sh b)--  Stencil2      :: (Shape sh, Elt a, Elt b, Elt c, Stencil sh a stencil1, Stencil sh b stencil2)-                => (stencil1 -> stencil2 -> exp c)-                -> PreBoundary acc exp (Array sh a)-                -> acc (Array sh a)-                -> PreBoundary acc exp (Array sh b)-                -> acc (Array sh b)-                -> PreAcc acc exp (Array sh c)--  -- Collect       :: Arrays arrs-  --               => seq arrs-  --               -> PreAcc acc seq exp arrs---{---data PreSeq acc seq exp arrs where-  -- Convert the given Haskell-list of arrays to a sequence.-  StreamIn :: Arrays a-           => [a]-           -> PreSeq acc seq exp [a]--  -- Convert the given array to a sequence.-  -- Example:-  -- slix = Z :. All :. Split :. All :. All :. Split-  --              ^       ^       ^      ^      ^-  --              |        \     /      /       |-  --              |         \___/______/_______ Iteration space.-  --              |            /      /-  --           Element________/______/-  --            shape.-  ---  ToSeq :: ( Elt e-           , Slice slix-           , Division slsix-           , DivisionSlice slsix ~ slix-           , Typeable (FullShape slix)-           , Typeable (SliceShape slix)-           )-        => slsix-        -> acc (Array (FullShape slix) e)-        -> PreSeq acc seq exp [Array (SliceShape slix) e]--  -- Apply the given the given function to all elements of the given sequence.-  MapSeq :: (Arrays a, Arrays b)-         => (Acc a -> acc b)-         -> seq [a]-         -> PreSeq acc seq exp [b]--  -- Apply a given binary function pairwise to all elements of the given sequences.-  -- The length of the result is the length of the shorter of the two argument-  -- arrays.-  ZipWithSeq :: (Arrays a, Arrays b, Arrays c)-             => (Acc a -> Acc b -> acc c)-             -> seq [a]-             -> seq [b]-             -> PreSeq acc seq exp [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 a-          => (Exp a -> Exp a -> exp a)-          -> exp a-          -> seq [Scalar a]-          -> PreSeq acc seq exp [Scalar a]--  -- 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-          => (Exp a -> Exp a -> exp a)-          -> exp a-          -> seq [Scalar a]-          -> PreSeq acc seq exp (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 s1 a2 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)-                 => (Acc a -> Acc (Vector sh) -> Acc (Vector e) -> acc a)-                 -> acc a-                 -> seq [Array sh e]-                 -> PreSeq acc seq exp a--  -- Tuple up the results of a sequence computation. Note that the Arrays-  -- constraint requires that the elements of the tuple are Arrays, not-  -- streams ([]).-  Stuple :: (Arrays arrs, IsAtuple arrs)-         => Atuple (seq) (TupleRepr arrs)-         -> PreSeq acc seq exp arrs---- |Array-valued sequence computations----newtype Seq a = Seq (PreSeq Acc Seq Exp a)--deriving instance Typeable Seq---}----- Embedded expressions of the surface language--- ------------------------------------------------ HOAS expressions mirror the constructors of 'AST.OpenExp', but with the 'Tag'--- constructor instead of variables in the form of de Bruijn indices. Moreover,--- HOAS expression use n-tuples and the type class 'Elt' to constrain element--- types, whereas 'AST.OpenExp' uses nested pairs and the GADT 'TupleType'.------- | The type 'Exp' represents embedded scalar expressions. The collective--- operations of Accelerate 'Acc' consist of many scalar expressions executed in--- data-parallel.------ Note that scalar expressions can not initiate new collective operations:--- doing so introduces /nested data parallelism/, which is difficult to execute--- efficiently on constrained hardware such as GPUs, and is thus currently--- unsupported.----newtype Exp t = Exp (PreExp Acc Exp t)--deriving instance Typeable Exp---- | Scalar expressions to parametrise collective array operations, themselves parameterised over--- the type of collective array operations.----data PreExp acc exp t where-    -- Needed for conversion to de Bruijn form-  Tag           :: Elt t-                => Level                        -- environment size at defining occurrence-                -> PreExp acc exp t--  -- All the same constructors as 'AST.Exp'-  Const         :: Elt t-                => t-                -> PreExp acc exp t--  Tuple         :: (Elt t, IsTuple t)-                => Tuple exp (TupleRepr t)-                -> PreExp acc exp t--  Prj           :: (Elt t, IsTuple t, Elt e)-                => TupleIdx (TupleRepr t) e-                -> exp t-                -> PreExp acc exp e--  IndexNil      :: PreExp acc exp Z--  IndexCons     :: (Slice sl, Elt a)-                => exp sl-                -> exp a-                -> PreExp acc exp (sl:.a)--  IndexHead     :: (Slice sl, Elt a)-                => exp (sl:.a)-                -> PreExp acc exp a--  IndexTail     :: (Slice sl, Elt a)-                => exp (sl:.a)-                -> PreExp acc exp sl--  IndexAny      :: Shape sh-                => PreExp acc exp (Any sh)--  ToIndex       :: Shape sh-                => exp sh-                -> exp sh-                -> PreExp acc exp Int--  FromIndex     :: Shape sh-                => exp sh-                -> exp Int-                -> PreExp acc exp sh--  Cond          :: Elt t-                => exp Bool-                -> exp t-                -> exp t-                -> PreExp acc exp t--  While         :: Elt t-                => (Exp t -> exp Bool)-                -> (Exp t -> exp t)-                -> exp t-                -> PreExp acc exp t--  PrimConst     :: Elt t-                => PrimConst t-                -> PreExp acc exp t--  PrimApp       :: (Elt a, Elt r)-                => PrimFun (a -> r)-                -> exp a-                -> PreExp acc exp r--  Index         :: (Shape sh, Elt t)-                => acc (Array sh t)-                -> exp sh-                -> PreExp acc exp t--  LinearIndex   :: (Shape sh, Elt t)-                => acc (Array sh t)-                -> exp Int-                -> PreExp acc exp t--  Shape         :: (Shape sh, Elt e)-                => acc (Array sh e)-                -> PreExp acc exp sh--  ShapeSize     :: Shape sh-                => exp sh-                -> PreExp acc exp Int--  Intersect     :: Shape sh-                => exp sh-                -> exp sh-                -> PreExp acc exp sh--  Union         :: Shape sh-                => exp sh-                -> exp sh-                -> PreExp acc exp sh--  Foreign       :: (Elt x, Elt y, Foreign asm)-                => asm (x -> y)-                -> (Exp x -> Exp y) -- RCE: Using Exp instead of exp to aid in sharing recovery.-                -> exp x-                -> PreExp acc exp y----- Smart constructors and destructors for array tuples--- -----------------------------------------------------atup2 :: (Arrays a, Arrays b)-      => (Acc a, Acc b)-      -> Acc (a, b)-atup2 (a, b)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b--atup3 :: (Arrays a, Arrays b, Arrays c)-      => (Acc a, Acc b, Acc c)-      -> Acc (a, b, c)-atup3 (a, b, c)-  = Acc $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c--atup4 :: (Arrays a, Arrays b, Arrays c, Arrays d)-      => (Acc a, Acc b, Acc c, Acc d)-      -> Acc (a, b, c, d)-atup4 (a, b, c, d)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d--atup5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)-      => (Acc a, Acc b, Acc c, Acc d, Acc e)-      -> Acc (a, b, c, d, e)-atup5 (a, b, c, d, e)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e--atup6 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)-      => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f)-      -> Acc (a, b, c, d, e, f)-atup6 (a, b, c, d, e, f)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f--atup7 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)-      => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g)-      -> Acc (a, b, c, d, e, f, g)-atup7 (a, b, c, d, e, f, g)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f-            `SnocAtup` g--atup8 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)-      => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h)-      -> Acc (a, b, c, d, e, f, g, h)-atup8 (a, b, c, d, e, f, g, h)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f-            `SnocAtup` g-            `SnocAtup` h--atup9 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)-      => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i)-      -> Acc (a, b, c, d, e, f, g, h, i)-atup9 (a, b, c, d, e, f, g, h, i)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f-            `SnocAtup` g-            `SnocAtup` h-            `SnocAtup` i--atup10 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j)-       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j)-       -> Acc (a, b, c, d, e, f, g, h, i, j)-atup10 (a, b, c, d, e, f, g, h, i, j)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f-            `SnocAtup` g-            `SnocAtup` h-            `SnocAtup` i-            `SnocAtup` j--atup11 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k)-       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k)-       -> Acc (a, b, c, d, e, f, g, h, i, j, k)-atup11 (a, b, c, d, e, f, g, h, i, j, k)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f-            `SnocAtup` g-            `SnocAtup` h-            `SnocAtup` i-            `SnocAtup` j-            `SnocAtup` k--atup12 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l)-       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l)-       -> Acc (a, b, c, d, e, f, g, h, i, j, k, l)-atup12 (a, b, c, d, e, f, g, h, i, j, k, l)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f-            `SnocAtup` g-            `SnocAtup` h-            `SnocAtup` i-            `SnocAtup` j-            `SnocAtup` k-            `SnocAtup` l--atup13 :: (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)-       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m)-       -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m)-atup13 (a, b, c, d, e, f, g, h, i, j, k, l, m)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f-            `SnocAtup` g-            `SnocAtup` h-            `SnocAtup` i-            `SnocAtup` j-            `SnocAtup` k-            `SnocAtup` l-            `SnocAtup` m--atup14 :: (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)-       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n)-       -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-atup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f-            `SnocAtup` g-            `SnocAtup` h-            `SnocAtup` i-            `SnocAtup` j-            `SnocAtup` k-            `SnocAtup` l-            `SnocAtup` m-            `SnocAtup` n--atup15 :: (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)-       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o)-       -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-atup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-  = Acc-  $ Atuple-  $ NilAtup `SnocAtup` a-            `SnocAtup` b-            `SnocAtup` c-            `SnocAtup` d-            `SnocAtup` e-            `SnocAtup` f-            `SnocAtup` g-            `SnocAtup` h-            `SnocAtup` i-            `SnocAtup` j-            `SnocAtup` k-            `SnocAtup` l-            `SnocAtup` m-            `SnocAtup` n-            `SnocAtup` o--unatup2 :: (Arrays a, Arrays b)-        => Acc (a, b)-        -> (Acc a, Acc b)-unatup2 e =-  ( Acc $ tix1 `Aprj` e-  , Acc $ tix0 `Aprj` e )--unatup3 :: (Arrays a, Arrays b, Arrays c)-        => Acc (a, b, c)-        -> (Acc a, Acc b, Acc c)-unatup3 e =-  ( Acc $ tix2 `Aprj` e-  , Acc $ tix1 `Aprj` e-  , Acc $ tix0 `Aprj` e )--unatup4-    :: (Arrays a, Arrays b, Arrays c, Arrays d)-    => Acc (a, b, c, d)-    -> (Acc a, Acc b, Acc c, Acc d)-unatup4 e =-  ( Acc $ tix3 `Aprj` e-  , Acc $ tix2 `Aprj` e-  , Acc $ tix1 `Aprj` e-  , Acc $ tix0 `Aprj` e )--unatup5-    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)-    => Acc (a, b, c, d, e)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e)-unatup5 e =-  ( Acc $ tix4 `Aprj` e-  , Acc $ tix3 `Aprj` e-  , Acc $ tix2 `Aprj` e-  , Acc $ tix1 `Aprj` e-  , Acc $ tix0 `Aprj` e )--unatup6-    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)-    => Acc (a, b, c, d, e, f)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f)-unatup6 e =-  ( Acc $ tix5 `Aprj` e-  , Acc $ tix4 `Aprj` e-  , Acc $ tix3 `Aprj` e-  , Acc $ tix2 `Aprj` e-  , Acc $ tix1 `Aprj` e-  , Acc $ tix0 `Aprj` e )--unatup7-    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)-    => Acc (a, b, c, d, e, f, g)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g)-unatup7 e =-  ( Acc $ tix6 `Aprj` e-  , Acc $ tix5 `Aprj` e-  , Acc $ tix4 `Aprj` e-  , Acc $ tix3 `Aprj` e-  , Acc $ tix2 `Aprj` e-  , Acc $ tix1 `Aprj` e-  , Acc $ tix0 `Aprj` e )--unatup8-    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)-    => Acc (a, b, c, d, e, f, g, h)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h)-unatup8 e =-  ( Acc $ tix7 `Aprj` e-  , Acc $ tix6 `Aprj` e-  , Acc $ tix5 `Aprj` e-  , Acc $ tix4 `Aprj` e-  , Acc $ tix3 `Aprj` e-  , Acc $ tix2 `Aprj` e-  , Acc $ tix1 `Aprj` e-  , Acc $ tix0 `Aprj` e )--unatup9-    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)-    => Acc (a, b, c, d, e, f, g, h, i)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i)-unatup9 e =-  ( Acc $ tix8 `Aprj` e-  , Acc $ tix7 `Aprj` e-  , Acc $ tix6 `Aprj` e-  , Acc $ tix5 `Aprj` e-  , Acc $ tix4 `Aprj` e-  , Acc $ tix3 `Aprj` e-  , Acc $ tix2 `Aprj` e-  , Acc $ tix1 `Aprj` e-  , Acc $ tix0 `Aprj` e )--unatup10-    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j)-    => Acc (a, b, c, d, e, f, g, h, i, j)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j)-unatup10 e =-  ( Acc $ tix9 `Aprj` e-  , Acc $ tix8 `Aprj` e-  , Acc $ tix7 `Aprj` e-  , Acc $ tix6 `Aprj` e-  , Acc $ tix5 `Aprj` e-  , Acc $ tix4 `Aprj` e-  , Acc $ tix3 `Aprj` e-  , Acc $ tix2 `Aprj` e-  , Acc $ tix1 `Aprj` e-  , Acc $ tix0 `Aprj` e )--unatup11-    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k)-    => Acc (a, b, c, d, e, f, g, h, i, j, k)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k)-unatup11 e =-  ( Acc $ tix10 `Aprj` e-  , Acc $ tix9  `Aprj` e-  , Acc $ tix8  `Aprj` e-  , Acc $ tix7  `Aprj` e-  , Acc $ tix6  `Aprj` e-  , Acc $ tix5  `Aprj` e-  , Acc $ tix4  `Aprj` e-  , Acc $ tix3  `Aprj` e-  , Acc $ tix2  `Aprj` e-  , Acc $ tix1  `Aprj` e-  , Acc $ tix0  `Aprj` e )--unatup12-    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l)-    => Acc (a, b, c, d, e, f, g, h, i, j, k, l)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l)-unatup12 e =-  ( Acc $ tix11 `Aprj` e-  , Acc $ tix10 `Aprj` e-  , Acc $ tix9  `Aprj` e-  , Acc $ tix8  `Aprj` e-  , Acc $ tix7  `Aprj` e-  , Acc $ tix6  `Aprj` e-  , Acc $ tix5  `Aprj` e-  , Acc $ tix4  `Aprj` e-  , Acc $ tix3  `Aprj` e-  , Acc $ tix2  `Aprj` e-  , Acc $ tix1  `Aprj` e-  , Acc $ tix0  `Aprj` e )--unatup13-    :: (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)-    => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m)-unatup13 e =-  ( Acc $ tix12 `Aprj` e-  , Acc $ tix11 `Aprj` e-  , Acc $ tix10 `Aprj` e-  , Acc $ tix9  `Aprj` e-  , Acc $ tix8  `Aprj` e-  , Acc $ tix7  `Aprj` e-  , Acc $ tix6  `Aprj` e-  , Acc $ tix5  `Aprj` e-  , Acc $ tix4  `Aprj` e-  , Acc $ tix3  `Aprj` e-  , Acc $ tix2  `Aprj` e-  , Acc $ tix1  `Aprj` e-  , Acc $ tix0  `Aprj` e )--unatup14-    :: (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)-    => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n)-unatup14 e =-  ( Acc $ tix13 `Aprj` e-  , Acc $ tix12 `Aprj` e-  , Acc $ tix11 `Aprj` e-  , Acc $ tix10 `Aprj` e-  , Acc $ tix9  `Aprj` e-  , Acc $ tix8  `Aprj` e-  , Acc $ tix7  `Aprj` e-  , Acc $ tix6  `Aprj` e-  , Acc $ tix5  `Aprj` e-  , Acc $ tix4  `Aprj` e-  , Acc $ tix3  `Aprj` e-  , Acc $ tix2  `Aprj` e-  , Acc $ tix1  `Aprj` e-  , Acc $ tix0  `Aprj` e )--unatup15-    :: (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)-    => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o)-unatup15 e =-  ( Acc $ tix14 `Aprj` e-  , Acc $ tix13 `Aprj` e-  , Acc $ tix12 `Aprj` e-  , Acc $ tix11 `Aprj` e-  , Acc $ tix10 `Aprj` e-  , Acc $ tix9  `Aprj` e-  , Acc $ tix8  `Aprj` e-  , Acc $ tix7  `Aprj` e-  , Acc $ tix6  `Aprj` e-  , Acc $ tix5  `Aprj` e-  , Acc $ tix4  `Aprj` e-  , Acc $ tix3  `Aprj` e-  , Acc $ tix2  `Aprj` e-  , Acc $ tix1  `Aprj` e-  , Acc $ tix0  `Aprj` e )----- Smart constructors for stencils--- ----------------------------------- | Boundary condition specification for stencil operations----newtype Boundary t = Boundary (PreBoundary Acc Exp t)--data PreBoundary acc exp t where-  Clamp     :: PreBoundary acc exp t-  Mirror    :: PreBoundary acc exp t-  Wrap      :: PreBoundary acc exp t--  Constant  :: Elt e-            => e-            -> PreBoundary acc exp (Array sh e)--  Function  :: (Shape sh, Elt e)-            => (Exp sh -> exp e)-            -> PreBoundary acc exp (Array sh e)----- Stencil reification------ In the AST representation, we turn the stencil type from nested tuples of Accelerate expressions--- into an Accelerate expression whose type is a tuple nested in the same manner.  This enables us--- to represent the stencil function as a unary function (which also only needs one de Bruijn--- index). The various positions in the stencil are accessed via tuple indices (i.e., projections).----class (Elt (StencilRepr sh stencil), AST.Stencil sh a (StencilRepr sh stencil)) => Stencil sh a stencil where-  type StencilRepr sh stencil :: *-  stencilPrj :: {-dummy-} sh-             -> {-dummy-} a-             -> Exp (StencilRepr sh stencil)-             -> stencil---- DIM1-instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e) where-  type StencilRepr DIM1 (Exp e, Exp e, Exp e)-    = (e, e, e)-  stencilPrj _ _ s = (Exp $ Prj tix2 s,-                      Exp $ Prj tix1 s,-                      Exp $ Prj tix0 s)--instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e) where-  type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e)-    = (e, e, e, e, e)-  stencilPrj _ _ s = (Exp $ Prj tix4 s,-                      Exp $ Prj tix3 s,-                      Exp $ Prj tix2 s,-                      Exp $ Prj tix1 s,-                      Exp $ Prj tix0 s)--instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) where-  type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)-    = (e, e, e, e, e, e, e)-  stencilPrj _ _ s = (Exp $ Prj tix6 s,-                      Exp $ Prj tix5 s,-                      Exp $ Prj tix4 s,-                      Exp $ Prj tix3 s,-                      Exp $ Prj tix2 s,-                      Exp $ Prj tix1 s,-                      Exp $ Prj tix0 s)--instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)-  where-  type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)-    = (e, e, e, e, e, e, e, e, e)-  stencilPrj _ _ s = (Exp $ Prj tix8 s,-                      Exp $ Prj tix7 s,-                      Exp $ Prj tix6 s,-                      Exp $ Prj tix5 s,-                      Exp $ Prj tix4 s,-                      Exp $ Prj tix3 s,-                      Exp $ Prj tix2 s,-                      Exp $ Prj tix1 s,-                      Exp $ Prj tix0 s)---- DIM(n+1)-instance (Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row2, row1, row0) where-  type StencilRepr (sh:.Int:.Int) (row2, row1, row0)-    = (StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row0)-  stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))--instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3,-          Stencil (sh:.Int) a row4,-          Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where-  type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5)-    = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,-       StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5)-  stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))--instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3,-          Stencil (sh:.Int) a row4,-          Stencil (sh:.Int) a row5,-          Stencil (sh:.Int) a row6,-          Stencil (sh:.Int) a row7)-  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where-  type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7)-    = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,-       StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6,-       StencilRepr (sh:.Int) row7)-  stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))--instance (Stencil (sh:.Int) a row1,-          Stencil (sh:.Int) a row2,-          Stencil (sh:.Int) a row3,-          Stencil (sh:.Int) a row4,-          Stencil (sh:.Int) a row5,-          Stencil (sh:.Int) a row6,-          Stencil (sh:.Int) a row7,-          Stencil (sh:.Int) a row8,-          Stencil (sh:.Int) a row9)-  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where-  type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7, row8, row9)-    = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,-       StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6,-       StencilRepr (sh:.Int) row7, StencilRepr (sh:.Int) row8, StencilRepr (sh:.Int) row9)-  stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix8 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix7 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),-                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))---- Auxiliary tuple index constants----tix0 :: TupleIdx (t, s0) s0-tix0 = ZeroTupIdx--tix1 :: TupleIdx ((t, s1), s0) s1-tix1 = SuccTupIdx tix0--tix2 :: TupleIdx (((t, s2), s1), s0) s2-tix2 = SuccTupIdx tix1--tix3 :: TupleIdx ((((t, s3), s2), s1), s0) s3-tix3 = SuccTupIdx tix2--tix4 :: TupleIdx (((((t, s4), s3), s2), s1), s0) s4-tix4 = SuccTupIdx tix3--tix5 :: TupleIdx ((((((t, s5), s4), s3), s2), s1), s0) s5-tix5 = SuccTupIdx tix4--tix6 :: TupleIdx (((((((t, s6), s5), s4), s3), s2), s1), s0) s6-tix6 = SuccTupIdx tix5--tix7 :: TupleIdx ((((((((t, s7), s6), s5), s4), s3), s2), s1), s0) s7-tix7 = SuccTupIdx tix6--tix8 :: TupleIdx (((((((((t, s8), s7), s6), s5), s4), s3), s2), s1), s0) s8-tix8 = SuccTupIdx tix7--tix9 :: TupleIdx ((((((((((t, s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s9-tix9 = SuccTupIdx tix8--tix10 :: TupleIdx (((((((((((t, s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s10-tix10 = SuccTupIdx tix9--tix11 :: TupleIdx ((((((((((((t, s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s11-tix11 = SuccTupIdx tix10--tix12 :: TupleIdx (((((((((((((t, s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s12-tix12 = SuccTupIdx tix11--tix13 :: TupleIdx ((((((((((((((t, s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s13-tix13 = SuccTupIdx tix12--tix14 :: TupleIdx (((((((((((((((t, s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s14-tix14 = SuccTupIdx tix13--{----- Smart constructors for array tuples in sequence computations--- -----------------------------------------------------stup2 :: (Arrays a, Arrays b) => (Seq a, Seq b) -> Seq (a, b)-stup2 (a, b) = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b)--stup3 :: (Arrays a, Arrays b, Arrays c) => (Seq a, Seq b, Seq c) -> Seq (a, b, c)-stup3 (a, b, c) = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c)--stup4 :: (Arrays a, Arrays b, Arrays c, Arrays d)-      => (Seq a, Seq b, Seq c, Seq d) -> Seq (a, b, c, d)-stup4 (a, b, c, d)-  = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d)--stup5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)-      => (Seq a, Seq b, Seq c, Seq d, Seq e) -> Seq (a, b, c, d, e)-stup5 (a, b, c, d, e)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e--stup6 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)-      => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f) -> Seq (a, b, c, d, e, f)-stup6 (a, b, c, d, e, f)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c-              `SnocAtup` d `SnocAtup` e `SnocAtup` f--stup7 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)-      => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g)-      -> Seq (a, b, c, d, e, f, g)-stup7 (a, b, c, d, e, f, g)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c-              `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g--stup8 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)-      => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h)-      -> Seq (a, b, c, d, e, f, g, h)-stup8 (a, b, c, d, e, f, g, h)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d-              `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h--stup9 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)-      => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i)-      -> Seq (a, b, c, d, e, f, g, h, i)-stup9 (a, b, c, d, e, f, g, h, i)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d-              `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i--stup10 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j)-       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j)-       -> Seq (a, b, c, d, e, f, g, h, i, j)-stup10 (a, b, c, d, e, f, g, h, i, j)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e-              `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j--stup11 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k)-       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k)-       -> Seq (a, b, c, d, e, f, g, h, i, j, k)-stup11 (a, b, c, d, e, f, g, h, i, j, k)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e-              `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k--stup12 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l)-       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l)-       -> Seq (a, b, c, d, e, f, g, h, i, j, k, l)-stup12 (a, b, c, d, e, f, g, h, i, j, k, l)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f-              `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l--stup13 :: (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)-       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m)-       -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m)-stup13 (a, b, c, d, e, f, g, h, i, j, k, l, m)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f-              `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m--stup14 :: (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)-       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m, Seq n)-       -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-stup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g-              `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n--stup15 :: (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)-       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m, Seq n, Seq o)-       -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-stup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-  = Seq $ Stuple $-      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g-              `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n `SnocAtup` o---}---- Smart constructor for literals------- | Scalar expression inlet: make a Haskell value available for processing in--- an Accelerate scalar expression.------ Note that this embeds the value directly into the expression. Depending on--- the backend used to execute the computation, this might not always be--- desirable. For example, a backend that does external code generation may--- embed this constant directly into the generated code, which means new code--- will need to be generated and compiled every time the value changes. In such--- cases, consider instead lifting scalar values into (singleton) arrays so that--- they can be passed as an input to the computation and thus the value can--- change without the need to generate fresh code.----constant :: Elt t => t -> Exp t-constant = Exp . Const---- Smart constructor and destructors for scalar tuples----tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b)-tup2 (a, b)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b--tup3 :: (Elt a, Elt b, Elt c)-     => (Exp a, Exp b, Exp c)-     -> Exp (a, b, c)-tup3 (a, b, c)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c--tup4 :: (Elt a, Elt b, Elt c, Elt d)-     => (Exp a, Exp b, Exp c, Exp d)-     -> Exp (a, b, c, d)-tup4 (a, b, c, d)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d--tup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e)-     => (Exp a, Exp b, Exp c, Exp d, Exp e)-     -> Exp (a, b, c, d, e)-tup5 (a, b, c, d, e)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e--tup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)-     => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)-     -> Exp (a, b, c, d, e, f)-tup6 (a, b, c, d, e, f)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f--tup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)-     => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)-     -> Exp (a, b, c, d, e, f, g)-tup7 (a, b, c, d, e, f, g)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f-           `SnocTup` g--tup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)-     => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)-     -> Exp (a, b, c, d, e, f, g, h)-tup8 (a, b, c, d, e, f, g, h)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f-           `SnocTup` g-           `SnocTup` h--tup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)-     => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)-     -> Exp (a, b, c, d, e, f, g, h, i)-tup9 (a, b, c, d, e, f, g, h, i)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f-           `SnocTup` g-           `SnocTup` h-           `SnocTup` i--tup10 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)-      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j)-      -> Exp (a, b, c, d, e, f, g, h, i, j)-tup10 (a, b, c, d, e, f, g, h, i, j)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f-           `SnocTup` g-           `SnocTup` h-           `SnocTup` i-           `SnocTup` j--tup11 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k)-      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k)-      -> Exp (a, b, c, d, e, f, g, h, i, j, k)-tup11 (a, b, c, d, e, f, g, h, i, j, k)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f-           `SnocTup` g-           `SnocTup` h-           `SnocTup` i-           `SnocTup` j-           `SnocTup` k--tup12 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l)-      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l)-      -> Exp (a, b, c, d, e, f, g, h, i, j, k, l)-tup12 (a, b, c, d, e, f, g, h, i, j, k, l)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f-           `SnocTup` g-           `SnocTup` h-           `SnocTup` i-           `SnocTup` j-           `SnocTup` k-           `SnocTup` l--tup13 :: (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)-      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m)-      -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m)-tup13 (a, b, c, d, e, f, g, h, i, j, k, l, m)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f-           `SnocTup` g-           `SnocTup` h-           `SnocTup` i-           `SnocTup` j-           `SnocTup` k-           `SnocTup` l-           `SnocTup` m--tup14 :: (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)-      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n)-      -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-tup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f-           `SnocTup` g-           `SnocTup` h-           `SnocTup` i-           `SnocTup` j-           `SnocTup` k-           `SnocTup` l-           `SnocTup` m-           `SnocTup` n--tup15 :: (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)-      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o)-      -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-tup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-  = Exp-  $ Tuple-  $ NilTup `SnocTup` a-           `SnocTup` b-           `SnocTup` c-           `SnocTup` d-           `SnocTup` e-           `SnocTup` f-           `SnocTup` g-           `SnocTup` h-           `SnocTup` i-           `SnocTup` j-           `SnocTup` k-           `SnocTup` l-           `SnocTup` m-           `SnocTup` n-           `SnocTup` o--untup2 :: (Elt a, Elt b) => Exp (a, b) -> (Exp a, Exp b)-untup2 e =-  ( Exp $ tix1 `Prj` e-  , Exp $ tix0 `Prj` e )--untup3 :: (Elt a, Elt b, Elt c) => Exp (a, b, c) -> (Exp a, Exp b, Exp c)-untup3 e =-  ( Exp $ tix2 `Prj` e-  , Exp $ tix1 `Prj` e-  , Exp $ tix0 `Prj` e )--untup4 :: (Elt a, Elt b, Elt c, Elt d)-       => Exp (a, b, c, d)-       -> (Exp a, Exp b, Exp c, Exp d)-untup4 e =-  ( Exp $ tix3 `Prj` e-  , Exp $ tix2 `Prj` e-  , Exp $ tix1 `Prj` e-  , Exp $ tix0 `Prj` e )--untup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e)-       => Exp (a, b, c, d, e)-       -> (Exp a, Exp b, Exp c, Exp d, Exp e)-untup5 e =-  ( Exp $ tix4 `Prj` e-  , Exp $ tix3 `Prj` e-  , Exp $ tix2 `Prj` e-  , Exp $ tix1 `Prj` e-  , Exp $ tix0 `Prj` e )--untup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)-       => Exp (a, b, c, d, e, f)-       -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)-untup6 e =-  ( Exp $ tix5 `Prj` e-  , Exp $ tix4 `Prj` e-  , Exp $ tix3 `Prj` e-  , Exp $ tix2 `Prj` e-  , Exp $ tix1 `Prj` e-  , Exp $ tix0 `Prj` e )--untup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)-       => Exp (a, b, c, d, e, f, g)-       -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)-untup7 e =-  ( Exp $ tix6 `Prj` e-  , Exp $ tix5 `Prj` e-  , Exp $ tix4 `Prj` e-  , Exp $ tix3 `Prj` e-  , Exp $ tix2 `Prj` e-  , Exp $ tix1 `Prj` e-  , Exp $ tix0 `Prj` e )--untup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)-       => Exp (a, b, c, d, e, f, g, h)-       -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)-untup8 e =-  ( Exp $ tix7 `Prj` e-  , Exp $ tix6 `Prj` e-  , Exp $ tix5 `Prj` e-  , Exp $ tix4 `Prj` e-  , Exp $ tix3 `Prj` e-  , Exp $ tix2 `Prj` e-  , Exp $ tix1 `Prj` e-  , Exp $ tix0 `Prj` e )--untup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)-       => Exp (a, b, c, d, e, f, g, h, i)-       -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)-untup9 e =-  ( Exp $ tix8 `Prj` e-  , Exp $ tix7 `Prj` e-  , Exp $ tix6 `Prj` e-  , Exp $ tix5 `Prj` e-  , Exp $ tix4 `Prj` e-  , Exp $ tix3 `Prj` e-  , Exp $ tix2 `Prj` e-  , Exp $ tix1 `Prj` e-  , Exp $ tix0 `Prj` e )--untup10 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)-        => Exp (a, b, c, d, e, f, g, h, i, j)-        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j)-untup10 e =-  ( Exp $ tix9 `Prj` e-  , Exp $ tix8 `Prj` e-  , Exp $ tix7 `Prj` e-  , Exp $ tix6 `Prj` e-  , Exp $ tix5 `Prj` e-  , Exp $ tix4 `Prj` e-  , Exp $ tix3 `Prj` e-  , Exp $ tix2 `Prj` e-  , Exp $ tix1 `Prj` e-  , Exp $ tix0 `Prj` e )--untup11 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k)-        => Exp (a, b, c, d, e, f, g, h, i, j, k)-        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k)-untup11 e =-  ( Exp $ tix10 `Prj` e-  , Exp $ tix9  `Prj` e-  , Exp $ tix8  `Prj` e-  , Exp $ tix7  `Prj` e-  , Exp $ tix6  `Prj` e-  , Exp $ tix5  `Prj` e-  , Exp $ tix4  `Prj` e-  , Exp $ tix3  `Prj` e-  , Exp $ tix2  `Prj` e-  , Exp $ tix1  `Prj` e-  , Exp $ tix0  `Prj` e )--untup12 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l)-        => Exp (a, b, c, d, e, f, g, h, i, j, k, l)-        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l)-untup12 e =-  ( Exp $ tix11 `Prj` e-  , Exp $ tix10 `Prj` e-  , Exp $ tix9  `Prj` e-  , Exp $ tix8  `Prj` e-  , Exp $ tix7  `Prj` e-  , Exp $ tix6  `Prj` e-  , Exp $ tix5  `Prj` e-  , Exp $ tix4  `Prj` e-  , Exp $ tix3  `Prj` e-  , Exp $ tix2  `Prj` e-  , Exp $ tix1  `Prj` e-  , Exp $ tix0  `Prj` e )--untup13 :: (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)-        => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m)-        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m)-untup13 e =-  ( Exp $ tix12 `Prj` e-  , Exp $ tix11 `Prj` e-  , Exp $ tix10 `Prj` e-  , Exp $ tix9  `Prj` e-  , Exp $ tix8  `Prj` e-  , Exp $ tix7  `Prj` e-  , Exp $ tix6  `Prj` e-  , Exp $ tix5  `Prj` e-  , Exp $ tix4  `Prj` e-  , Exp $ tix3  `Prj` e-  , Exp $ tix2  `Prj` e-  , Exp $ tix1  `Prj` e-  , Exp $ tix0  `Prj` e )--untup14 :: (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)-        => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n)-        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n)-untup14 e =-  ( Exp $ tix13 `Prj` e-  , Exp $ tix12 `Prj` e-  , Exp $ tix11 `Prj` e-  , Exp $ tix10 `Prj` e-  , Exp $ tix9  `Prj` e-  , Exp $ tix8  `Prj` e-  , Exp $ tix7  `Prj` e-  , Exp $ tix6  `Prj` e-  , Exp $ tix5  `Prj` e-  , Exp $ tix4  `Prj` e-  , Exp $ tix3  `Prj` e-  , Exp $ tix2  `Prj` e-  , Exp $ tix1  `Prj` e-  , Exp $ tix0  `Prj` e )--untup15 :: (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)-        => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)-        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o)-untup15 e =-  ( Exp $ tix14 `Prj` e-  , Exp $ tix13 `Prj` e-  , Exp $ tix12 `Prj` e-  , Exp $ tix11 `Prj` e-  , Exp $ tix10 `Prj` e-  , Exp $ tix9  `Prj` e-  , Exp $ tix8  `Prj` e-  , Exp $ tix7  `Prj` e-  , Exp $ tix6  `Prj` e-  , Exp $ tix5  `Prj` e-  , Exp $ tix4  `Prj` e-  , Exp $ tix3  `Prj` e-  , Exp $ tix2  `Prj` e-  , Exp $ tix1  `Prj` e-  , Exp $ tix0  `Prj` e )----- Smart constructor for constants-----mkMinBound :: (Elt t, IsBounded t) => Exp t-mkMinBound = Exp $ PrimConst (PrimMinBound boundedType)--mkMaxBound :: (Elt t, IsBounded t) => Exp t-mkMaxBound = Exp $ PrimConst (PrimMaxBound boundedType)--mkPi :: (Elt r, IsFloating r) => Exp r-mkPi = Exp $ PrimConst (PrimPi floatingType)----- Smart constructors for primitive applications------- Operators from Floating--mkSin :: (Elt t, IsFloating t) => Exp t -> Exp t-mkSin x = Exp $ PrimSin floatingType `PrimApp` x--mkCos :: (Elt t, IsFloating t) => Exp t -> Exp t-mkCos x = Exp $ PrimCos floatingType `PrimApp` x--mkTan :: (Elt t, IsFloating t) => Exp t -> Exp t-mkTan x = Exp $ PrimTan floatingType `PrimApp` x--mkAsin :: (Elt t, IsFloating t) => Exp t -> Exp t-mkAsin x = Exp $ PrimAsin floatingType `PrimApp` x--mkAcos :: (Elt t, IsFloating t) => Exp t -> Exp t-mkAcos x = Exp $ PrimAcos floatingType `PrimApp` x--mkAtan :: (Elt t, IsFloating t) => Exp t -> Exp t-mkAtan x = Exp $ PrimAtan floatingType `PrimApp` x--mkSinh :: (Elt t, IsFloating t) => Exp t -> Exp t-mkSinh x = Exp $ PrimSinh floatingType `PrimApp` x--mkCosh :: (Elt t, IsFloating t) => Exp t -> Exp t-mkCosh x = Exp $ PrimCosh floatingType `PrimApp` x--mkTanh :: (Elt t, IsFloating t) => Exp t -> Exp t-mkTanh x = Exp $ PrimTanh floatingType `PrimApp` x--mkAsinh :: (Elt t, IsFloating t) => Exp t -> Exp t-mkAsinh x = Exp $ PrimAsinh floatingType `PrimApp` x--mkAcosh :: (Elt t, IsFloating t) => Exp t -> Exp t-mkAcosh x = Exp $ PrimAcosh floatingType `PrimApp` x--mkAtanh :: (Elt t, IsFloating t) => Exp t -> Exp t-mkAtanh x = Exp $ PrimAtanh floatingType `PrimApp` x--mkExpFloating :: (Elt t, IsFloating t) => Exp t -> Exp t-mkExpFloating x = Exp $ PrimExpFloating floatingType `PrimApp` x--mkSqrt :: (Elt t, IsFloating t) => Exp t -> Exp t-mkSqrt x = Exp $ PrimSqrt floatingType `PrimApp` x--mkLog :: (Elt t, IsFloating t) => Exp t -> Exp t-mkLog x = Exp $ PrimLog floatingType `PrimApp` x--mkFPow :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t-mkFPow x y = Exp $ PrimFPow floatingType `PrimApp` tup2 (x, y)--mkLogBase :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t-mkLogBase x y = Exp $ PrimLogBase floatingType `PrimApp` tup2 (x, y)---- Operators from Num--mkAdd :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t-mkAdd x y = Exp $ PrimAdd numType `PrimApp` tup2 (x, y)--mkSub :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t-mkSub x y = Exp $ PrimSub numType `PrimApp` tup2 (x, y)--mkMul :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t-mkMul x y = Exp $ PrimMul numType `PrimApp` tup2 (x, y)--mkNeg :: (Elt t, IsNum t) => Exp t -> Exp t-mkNeg x = Exp $ PrimNeg numType `PrimApp` x--mkAbs :: (Elt t, IsNum t) => Exp t -> Exp t-mkAbs x = Exp $ PrimAbs numType `PrimApp` x--mkSig :: (Elt t, IsNum t) => Exp t -> Exp t-mkSig x = Exp $ PrimSig numType `PrimApp` x---- Operators from Integral--mkQuot :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkQuot x y = Exp $ PrimQuot integralType `PrimApp` tup2 (x, y)--mkRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkRem x y = Exp $ PrimRem integralType `PrimApp` tup2 (x, y)--mkQuotRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t)-mkQuotRem x y = untup2 $ Exp $ PrimQuotRem integralType `PrimApp` tup2 (x ,y)--mkIDiv :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkIDiv x y = Exp $ PrimIDiv integralType `PrimApp` tup2 (x, y)--mkMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkMod x y = Exp $ PrimMod integralType `PrimApp` tup2 (x, y)--mkDivMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t)-mkDivMod x y = untup2 $ Exp $ PrimDivMod integralType `PrimApp` tup2 (x ,y)----- Operators from Bits and FiniteBits--mkBAnd :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkBAnd x y = Exp $ PrimBAnd integralType `PrimApp` tup2 (x, y)--mkBOr :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkBOr x y = Exp $ PrimBOr integralType `PrimApp` tup2 (x, y)--mkBXor :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t-mkBXor x y = Exp $ PrimBXor integralType `PrimApp` tup2 (x, y)--mkBNot :: (Elt t, IsIntegral t) => Exp t -> Exp t-mkBNot x = Exp $ PrimBNot integralType `PrimApp` x--mkBShiftL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t-mkBShiftL x i = Exp $ PrimBShiftL integralType `PrimApp` tup2 (x, i)--mkBShiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t-mkBShiftR x i = Exp $ PrimBShiftR integralType `PrimApp` tup2 (x, i)--mkBRotateL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t-mkBRotateL x i = Exp $ PrimBRotateL integralType `PrimApp` tup2 (x, i)--mkBRotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t-mkBRotateR x i = Exp $ PrimBRotateR integralType `PrimApp` tup2 (x, i)--mkPopCount :: (Elt t, IsIntegral t) => Exp t -> Exp Int-mkPopCount x = Exp $ PrimPopCount integralType `PrimApp` x--mkCountLeadingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int-mkCountLeadingZeros x = Exp $ PrimCountLeadingZeros integralType `PrimApp` x--mkCountTrailingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int-mkCountTrailingZeros x = Exp $ PrimCountTrailingZeros integralType `PrimApp` x----- Operators from Fractional--mkFDiv :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t-mkFDiv x y = Exp $ PrimFDiv floatingType `PrimApp` tup2 (x, y)--mkRecip :: (Elt t, IsFloating t) => Exp t -> Exp t-mkRecip x = Exp $ PrimRecip floatingType `PrimApp` x---- Operators from RealFrac--mkTruncate :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b-mkTruncate x = Exp $ PrimTruncate floatingType integralType `PrimApp` x--mkRound :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b-mkRound x = Exp $ PrimRound floatingType integralType `PrimApp` x--mkFloor :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b-mkFloor x = Exp $ PrimFloor floatingType integralType `PrimApp` x--mkCeiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b-mkCeiling x = Exp $ PrimCeiling floatingType integralType `PrimApp` x---- Operators from RealFloat--mkAtan2 :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t-mkAtan2 x y = Exp $ PrimAtan2 floatingType `PrimApp` tup2 (x, y)--mkIsNaN :: (Elt t, IsFloating t) => Exp t -> Exp Bool-mkIsNaN x = Exp $ PrimIsNaN floatingType `PrimApp` x--mkIsInfinite :: (Elt t, IsFloating t) => Exp t -> Exp Bool-mkIsInfinite x = Exp $ PrimIsInfinite floatingType `PrimApp` x---- FIXME: add missing operations from Floating, RealFrac & RealFloat---- Relational and equality operators--mkLt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkLt x y = Exp $ PrimLt scalarType `PrimApp` tup2 (x, y)--mkGt :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkGt x y = Exp $ PrimGt scalarType `PrimApp` tup2 (x, y)--mkLtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkLtEq x y = Exp $ PrimLtEq scalarType `PrimApp` tup2 (x, y)--mkGtEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkGtEq x y = Exp $ PrimGtEq scalarType `PrimApp` tup2 (x, y)--mkEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkEq x y = Exp $ PrimEq scalarType `PrimApp` tup2 (x, y)--mkNEq :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool-mkNEq x y = Exp $ PrimNEq scalarType `PrimApp` tup2 (x, y)--mkMax :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t-mkMax x y = Exp $ PrimMax scalarType `PrimApp` tup2 (x, y)--mkMin :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t-mkMin x y = Exp $ PrimMin scalarType `PrimApp` tup2 (x, y)---- Logical operators--mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool-mkLAnd x y = Exp $ PrimLAnd `PrimApp` tup2 (x, y)--mkLOr :: Exp Bool -> Exp Bool -> Exp Bool-mkLOr x y = Exp $ PrimLOr `PrimApp` tup2 (x, y)--mkLNot :: Exp Bool -> Exp Bool-mkLNot x = Exp $ PrimLNot `PrimApp` x---- Character conversions--mkOrd :: Exp Char -> Exp Int-mkOrd x = Exp $ PrimOrd `PrimApp` x--mkChr :: Exp Int -> Exp Char-mkChr x = Exp $ PrimChr `PrimApp` x---- Numeric conversions--mkFromIntegral :: (Elt a, Elt b, IsIntegral a, IsNum b) => Exp a -> Exp b-mkFromIntegral x = Exp $ PrimFromIntegral integralType numType `PrimApp` x--mkToFloating :: (Elt a, Elt b, IsNum a, IsFloating b) => Exp a -> Exp b-mkToFloating x = Exp $ PrimToFloating numType floatingType `PrimApp` x---- Other conversions--mkBoolToInt :: Exp Bool -> Exp Int-mkBoolToInt b = Exp $ PrimBoolToInt `PrimApp` b---- NOTE: BitSizeEq constraint is used to make this version "safe"-mkBitcast :: (Elt a, Elt b, IsScalar a, IsScalar b, BitSizeEq a b) => Exp a -> Exp b-mkBitcast = mkUnsafeCoerce--mkUnsafeCoerce :: (Elt a, Elt b, IsScalar a, IsScalar b) => Exp a -> Exp b-mkUnsafeCoerce x = Exp $ PrimCoerce scalarType scalarType `PrimApp` x----- Auxiliary functions--- ----------------------infixr 0 $$-($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a-(f $$ g) x y = f (g x y)--infixr 0 $$$-($$$) :: (b -> a) -> (c -> d -> e -> b) -> c -> d -> e -> a-(f $$$ g) x y z = f (g x y z)--infixr 0 $$$$-($$$$) :: (b -> a) -> (c -> d -> e -> f -> b) -> c -> d -> e -> f -> a-(f $$$$ g) x y z u = f (g x y z u)--infixr 0 $$$$$-($$$$$) :: (b -> a) -> (c -> d -> e -> f -> g -> b) -> c -> d -> e -> f -> g-> a-(f $$$$$ g) x y z u v = f (g x y z u v)----- Debugging--- -----------showPreAccOp :: forall acc exp arrs. PreAcc acc exp arrs -> String-showPreAccOp (Atag i)           = "Atag " ++ show i-showPreAccOp (Use a)            = "Use "  ++ showArrays a-showPreAccOp Pipe{}             = "Pipe"-showPreAccOp Acond{}            = "Acond"-showPreAccOp Awhile{}           = "Awhile"-showPreAccOp Atuple{}           = "Atuple"-showPreAccOp Aprj{}             = "Aprj"-showPreAccOp Unit{}             = "Unit"-showPreAccOp Generate{}         = "Generate"-showPreAccOp Reshape{}          = "Reshape"-showPreAccOp Replicate{}        = "Replicate"-showPreAccOp Slice{}            = "Slice"-showPreAccOp Map{}              = "Map"-showPreAccOp ZipWith{}          = "ZipWith"-showPreAccOp Fold{}             = "Fold"-showPreAccOp Fold1{}            = "Fold1"-showPreAccOp FoldSeg{}          = "FoldSeg"-showPreAccOp Fold1Seg{}         = "Fold1Seg"-showPreAccOp Scanl{}            = "Scanl"-showPreAccOp Scanl'{}           = "Scanl'"-showPreAccOp Scanl1{}           = "Scanl1"-showPreAccOp Scanr{}            = "Scanr"-showPreAccOp Scanr'{}           = "Scanr'"-showPreAccOp Scanr1{}           = "Scanr1"-showPreAccOp Permute{}          = "Permute"-showPreAccOp Backpermute{}      = "Backpermute"-showPreAccOp Stencil{}          = "Stencil"-showPreAccOp Stencil2{}         = "Stencil2"-showPreAccOp Aforeign{}         = "Aforeign"--- showPreAccOp Collect{}          = "Collect"--{---showPreSeqOp :: PreSeq acc seq exp arrs -> String-showPreSeqOp (StreamIn{})       = "StreamIn"-showPreSeqOp (ToSeq{})          = "ToSeq"-showPreSeqOp (MapSeq{})         = "MapSeq"-showPreSeqOp (ZipWithSeq{})     = "ZipWithSeq"-showPreSeqOp (ScanSeq{})        = "ScanSeq"-showPreSeqOp (FoldSeq{})        = "FoldSeq"-showPreSeqOp (FoldSeqFlatten{}) = "FoldSeqFlatten"-showPreSeqOp (Stuple{})         = "Stuple"---}--showArrays :: forall arrs. Arrays arrs => arrs -> String-showArrays = display . collect (arrays (undefined::arrs)) . fromArr-  where-    collect :: ArraysR a -> a -> [String]-    collect ArraysRunit         _        = []-    collect ArraysRarray        arr      = [showShortendArr arr]-    collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2-    ---    display []  = []-    display [x] = x-    display xs  = "(" ++ intercalate ", " xs ++ ")"---showShortendArr :: Elt e => Array sh e -> String-showShortendArr arr-  = show (take cutoff l) ++ if length l > cutoff then ".." else ""-  where-    l      = toList arr-    cutoff = 5---showPreExpOp :: PreExp acc exp t -> String-showPreExpOp (Const c)          = "Const " ++ show c-showPreExpOp (Tag i)            = "Tag" ++ show i-showPreExpOp Tuple{}            = "Tuple"-showPreExpOp Prj{}              = "Prj"-showPreExpOp IndexNil           = "IndexNil"-showPreExpOp IndexCons{}        = "IndexCons"-showPreExpOp IndexHead{}        = "IndexHead"-showPreExpOp IndexTail{}        = "IndexTail"-showPreExpOp IndexAny           = "IndexAny"-showPreExpOp ToIndex{}          = "ToIndex"-showPreExpOp FromIndex{}        = "FromIndex"-showPreExpOp Cond{}             = "Cond"-showPreExpOp While{}            = "While"-showPreExpOp PrimConst{}        = "PrimConst"-showPreExpOp PrimApp{}          = "PrimApp"-showPreExpOp Index{}            = "Index"-showPreExpOp LinearIndex{}      = "LinearIndex"-showPreExpOp Shape{}            = "Shape"-showPreExpOp ShapeSize{}        = "ShapeSize"-showPreExpOp Intersect{}        = "Intersect"-showPreExpOp Union{}            = "Union"-showPreExpOp Foreign{}          = "Foreign"-
− Data/Array/Accelerate/Trafo.hs 
@@ -1,242 +0,0 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE MonoLocalBinds       #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Trafo--- 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.Trafo (--  -- * HOAS -> de Bruijn conversion-  Phase(..), phases,--  -- ** Array computations-  convertAcc, convertAccWith,--  -- ** Array functions-  Afunction, AfunctionR,-  convertAfun, convertAfunWith,--  -- ** Sequence computations-  -- convertSeq, convertSeqWith,--  -- * Fusion-  module Data.Array.Accelerate.Trafo.Fusion,-  -- DelayedSeq(..), Extend(..),--  -- * Substitution-  module Data.Array.Accelerate.Trafo.Substitution,--  -- * Term equality-  Match(..), (:~:)(..),--  -- ** Auxiliary-  matchDelayedOpenAcc, hashDelayedOpenAcc,--) where--import Control.DeepSeq-import Data.Typeable--import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Pretty                     ( ) -- show instances-import Data.Array.Accelerate.Array.Sugar                ( Arrays, Elt )-import Data.Array.Accelerate.Trafo.Base-import Data.Array.Accelerate.Trafo.Fusion               hiding ( convertAcc, convertAfun ) -- to export types-import Data.Array.Accelerate.Trafo.Sharing              ( Function, FunctionR, Afunction, AfunctionR )-import Data.Array.Accelerate.Trafo.Substitution-import qualified Data.Array.Accelerate.AST              as AST-import qualified Data.Array.Accelerate.Trafo.Fusion     as Fusion-import qualified Data.Array.Accelerate.Trafo.Rewrite    as Rewrite-import qualified Data.Array.Accelerate.Trafo.Simplify   as Rewrite-import qualified Data.Array.Accelerate.Trafo.Sharing    as Sharing--- import qualified Data.Array.Accelerate.Trafo.Vectorise  as Vectorise--#ifdef ACCELERATE_DEBUG-import Text.Printf-import System.IO.Unsafe-import Data.Array.Accelerate.Debug                      hiding ( when )-import qualified Data.Array.Accelerate.Debug            as Debug-#endif----- Configuration--- ---------------data Phase = Phase-  {-    -- | Recover sharing of array computations?-    recoverAccSharing           :: Bool--    -- | Recover sharing of scalar expressions?-  , recoverExpSharing           :: Bool--    -- | Recover sharing of sequence computations?-  , recoverSeqSharing           :: Bool--    -- | Are array computations floated out of expressions irrespective of-    --   whether they are shared or not? Requires 'recoverAccSharing'.-  , floatOutAccFromExp          :: Bool--    -- | Fuse array computations? This also implies simplifying scalar-    --   expressions. NOTE: currently always enabled.-  , enableAccFusion             :: Bool--    -- | Convert segment length arrays into segment offset arrays?-  , convertOffsetOfSegment      :: Bool--    --   Vectorise maps and zipwiths in sequence computations to-    --   enable chunked execution?-  -- , vectoriseSequences          :: Bool-  }----- | The default method of converting from HOAS to de Bruijn; incorporating---   sharing recovery and fusion optimisation.----phases :: Phase-phases =  Phase-  { recoverAccSharing      = True-  , recoverExpSharing      = True-  , recoverSeqSharing      = True-  , floatOutAccFromExp     = True-  , enableAccFusion        = True-  , convertOffsetOfSegment = False-  -- , vectoriseSequences     = True-  }--when :: (a -> a) -> Bool -> a -> a-when f True  = f-when _ False = id----- HOAS -> de Bruijn conversion--- -------------------------------- | Convert a closed array expression to de Bruijn form while also---   incorporating sharing observation and array fusion.----convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc arrs-convertAcc = convertAccWith phases--convertAccWith :: Arrays arrs => Phase -> Acc arrs -> DelayedAcc arrs-convertAccWith Phase{..} acc-  = phase "array-fusion"           (Fusion.convertAcc enableAccFusion)-  -- phase "vectorise-sequences"    Vectorise.vectoriseSeqAcc `when` vectoriseSequences-  $ phase "rewrite-segment-offset" Rewrite.convertSegments   `when` convertOffsetOfSegment-  $ phase "sharing-recovery"       (Sharing.convertAcc recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp)-  $ acc----- | Convert a unary function over array computations, incorporating sharing---   observation and array fusion----convertAfun :: Afunction f => f -> DelayedAfun (AfunctionR f)-convertAfun = convertAfunWith phases--convertAfunWith :: Afunction f => Phase -> f -> DelayedAfun (AfunctionR f)-convertAfunWith Phase{..} acc-  = phase "array-fusion"           (Fusion.convertAfun enableAccFusion)-  -- phase "vectorise-sequences"    Vectorise.vectoriseSeqAfun  `when` vectoriseSequences-  $ phase "rewrite-segment-offset" Rewrite.convertSegmentsAfun `when` convertOffsetOfSegment-  $ phase "sharing-recovery"       (Sharing.convertAfun recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp)-  $ acc----- | Convert a closed scalar expression, incorporating sharing observation and---   optimisation.----convertExp :: Elt e => Exp e -> AST.Exp () e-convertExp-  = phase "exp-simplify"      Rewrite.simplify-  . phase "sharing-recovery" (Sharing.convertExp (recoverExpSharing phases))----- | Convert closed scalar functions, incorporating sharing observation and---   optimisation.----convertFun :: Function f => f -> AST.Fun () (FunctionR f)-convertFun-  = phase "exp-simplify"      Rewrite.simplify-  . phase "sharing-recovery" (Sharing.convertFun (recoverExpSharing phases))--{----- | Convert a closed sequence computation, incorporating sharing observation and---   optimisation.----convertSeq :: Typeable s => Seq s -> DelayedSeq s-convertSeq = convertSeqWith phases--convertSeqWith :: Typeable s => Phase -> Seq s -> DelayedSeq s-convertSeqWith Phase{..} s-  = phase "array-fusion"           (Fusion.convertSeq enableAccFusion)-  -- $ phase "vectorise-sequences"    Vectorise.vectoriseSeq     `when` vectoriseSequences-  $ phase "rewrite-segment-offset" Rewrite.convertSegmentsSeq `when` convertOffsetOfSegment-  $ phase "sharing-recovery"       (Sharing.convertSeq recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp)-  $ s---}---- Pretty printing--- -----------------instance Arrays arrs => Show (Acc arrs) where-  show = withSimplStats . show . convertAcc--instance Afunction (Acc a -> f) => Show (Acc a -> f) where-  show = withSimplStats . show . convertAfun--instance Elt e => Show (Exp e) where-  show = withSimplStats . show . convertExp--instance Function (Exp a -> f) => Show (Exp a -> f) where-  show = withSimplStats . show . convertFun---- instance Typeable a => Show (Seq a) where---   show = withSimplStats . show . convertSeq----- Debugging--- ------------- Attach simplifier statistics to the tail of the given string. Since the--- statistics rely on fully evaluating the expression this is difficult to do--- generally (without an additional deepseq), but easy enough for our show--- instances.------ For now, we just reset the statistics at the beginning of a conversion, and--- leave it to a backend to choose an appropriate moment to dump the summary.----withSimplStats :: String -> String-#ifdef ACCELERATE_DEBUG-withSimplStats x = unsafePerformIO $ do-  Debug.when dump_simpl_stats $ x `deepseq` dumpSimplStats-  return x-#else-withSimplStats x = x-#endif---- Execute a phase of the compiler and (possibly) print some timing/gc--- statistics.----phase :: NFData b => String -> (a -> b) -> a -> b-#ifdef ACCELERATE_DEBUG-phase n f x = unsafePerformIO $ do-  enabled <- queryFlag dump_phases-  if enabled-    then timed dump_phases (\wall cpu -> printf "phase %s: %s" n (elapsed wall cpu)) (return $!! f x)-    else return (f x)-#else-phase _ f x = f x-#endif-
− Data/Array/Accelerate/Trafo/Algebra.hs 
@@ -1,740 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE ViewPatterns        #-}--- |--- Module      : Data.Array.Accelerate.Trafo.Algebra--- 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)------ Algebraic simplifications of scalar expressions, including constant folding--- and using algebraic properties of particular operator-operand combinations.-----module Data.Array.Accelerate.Trafo.Algebra (--  evalPrimApp--) where--import Prelude                                          hiding ( exp )-import Data.Bits-import Data.Char-import Data.Monoid-import GHC.Float                                        ( float2Double, double2Float )-import Text.PrettyPrint.ANSI.Leijen-import Unsafe.Coerce-import qualified Prelude                                as P---- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Pretty.Print               ( prettyPrim )-import Data.Array.Accelerate.Array.Sugar                ( (:.)(..), Elt(..), Tuple(..), fromTuple )-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Trafo.Base--import qualified Data.Array.Accelerate.Debug            as Stats----- Propagate constant expressions, which are either constant valued expressions--- or constant let bindings. Be careful not to follow self-cycles.----propagate-    :: forall acc env aenv exp. Kit acc-    => Gamma acc env env aenv-    -> PreOpenExp acc env aenv exp-    -> Maybe exp-propagate env = cvtE-  where-    cvtE :: PreOpenExp acc env aenv e -> Maybe e-    cvtE exp = case exp of-      Const c                                   -> Just (toElt c)-      PrimConst c                               -> Just (evalPrimConst c)-      Prj ix (Var v) | Tuple t <- prjExp v env  -> cvtT ix t-      Prj ix e       | Just c  <- cvtE e        -> cvtP ix (fromTuple c)-      Var ix-        | e             <- prjExp ix env-        , Nothing       <- match exp e          -> cvtE e-      ---      IndexHead (cvtE -> Just (_  :. z))        -> Just z-      IndexTail (cvtE -> Just (sh :. _))        -> Just sh-      _                                         -> Nothing--    cvtP :: TupleIdx t e -> t -> Maybe e-    cvtP ZeroTupIdx       (_, v)   = Just v-    cvtP (SuccTupIdx idx) (tup, _) = cvtP idx tup--    cvtT :: TupleIdx t e -> Tuple (PreOpenExp acc env aenv) t -> Maybe e-    cvtT ZeroTupIdx       (SnocTup _   e) = cvtE e-    cvtT (SuccTupIdx idx) (SnocTup tup _) = cvtT idx tup-#if __GLASGOW_HASKELL__ < 800-    cvtT _                _               = error "hey what's the head angle on that thing?"-#endif----- Attempt to evaluate primitive function applications----evalPrimApp-    :: forall acc env aenv a r. (Kit acc, Elt a, Elt r)-    => Gamma acc env env aenv-    -> PrimFun (a -> r)-    -> PreOpenExp acc env aenv a-    -> (Any, PreOpenExp acc env aenv r)-evalPrimApp env f x-  -- First attempt to move constant values towards the left-  | Just r      <- commutes f x env     = evalPrimApp env f r---  | Just r      <- associates f x       = r--  -- Now attempt to evaluate any expressions-  | otherwise-  = maybe (Any False, PrimApp f x) (Any True,)-  $ case f of-      PrimAdd ty                -> evalAdd ty x env-      PrimSub ty                -> evalSub ty x env-      PrimMul ty                -> evalMul ty x env-      PrimNeg ty                -> evalNeg ty x env-      PrimAbs ty                -> evalAbs ty x env-      PrimSig ty                -> evalSig ty x env-      PrimQuot ty               -> evalQuot ty x env-      PrimRem ty                -> evalRem ty x env-      PrimQuotRem ty            -> evalQuotRem ty x env-      PrimIDiv ty               -> evalIDiv ty x env-      PrimMod ty                -> evalMod ty x env-      PrimDivMod ty             -> evalDivMod ty x env-      PrimBAnd ty               -> evalBAnd ty x env-      PrimBOr ty                -> evalBOr ty x env-      PrimBXor ty               -> evalBXor ty x env-      PrimBNot ty               -> evalBNot ty x env-      PrimBShiftL ty            -> evalBShiftL ty x env-      PrimBShiftR ty            -> evalBShiftR ty x env-      PrimBRotateL ty           -> evalBRotateL ty x env-      PrimBRotateR ty           -> evalBRotateR ty x env-      PrimPopCount ty           -> evalPopCount ty x env-      PrimCountLeadingZeros ty  -> evalCountLeadingZeros ty x env-      PrimCountTrailingZeros ty -> evalCountTrailingZeros ty x env-      PrimFDiv ty               -> evalFDiv ty x env-      PrimRecip ty              -> evalRecip ty x env-      PrimSin ty                -> evalSin ty x env-      PrimCos ty                -> evalCos ty x env-      PrimTan ty                -> evalTan ty x env-      PrimAsin ty               -> evalAsin ty x env-      PrimAcos ty               -> evalAcos ty x env-      PrimAtan ty               -> evalAtan ty x env-      PrimSinh ty               -> evalSinh ty x env-      PrimCosh ty               -> evalCosh ty x env-      PrimTanh ty               -> evalTanh ty x env-      PrimAsinh ty              -> evalAsinh ty x env-      PrimAcosh ty              -> evalAcosh ty x env-      PrimAtanh ty              -> evalAtanh ty x env-      PrimExpFloating ty        -> evalExpFloating ty x env-      PrimSqrt ty               -> evalSqrt ty x env-      PrimLog ty                -> evalLog ty x env-      PrimFPow ty               -> evalFPow ty x env-      PrimLogBase ty            -> evalLogBase ty x env-      PrimAtan2 ty              -> evalAtan2 ty x env-      PrimTruncate ta tb        -> evalTruncate ta tb x env-      PrimRound ta tb           -> evalRound ta tb x env-      PrimFloor ta tb           -> evalFloor ta tb x env-      PrimCeiling ta tb         -> evalCeiling ta tb x env-      PrimIsNaN ty              -> evalIsNaN ty x env-      PrimIsInfinite ty         -> evalIsInfinite ty x env-      PrimLt ty                 -> evalLt ty x env-      PrimGt ty                 -> evalGt ty x env-      PrimLtEq ty               -> evalLtEq ty x env-      PrimGtEq ty               -> evalGtEq ty x env-      PrimEq ty                 -> evalEq ty x env-      PrimNEq ty                -> evalNEq ty x env-      PrimMax ty                -> evalMax ty x env-      PrimMin ty                -> evalMin ty x env-      PrimLAnd                  -> evalLAnd x env-      PrimLOr                   -> evalLOr x env-      PrimLNot                  -> evalLNot x env-      PrimOrd                   -> evalOrd x env-      PrimChr                   -> evalChr x env-      PrimBoolToInt             -> evalBoolToInt x env-      PrimFromIntegral ta tb    -> evalFromIntegral ta tb x env-      PrimToFloating ta tb      -> evalToFloating ta tb x env-      PrimCoerce ta tb          -> evalCoerce ta tb x env----- Discriminate binary functions that commute, and if so return the operands in--- a stable ordering. If only one of the arguments is a constant, this is placed--- to the left of the operator. Returning Nothing indicates no change is made.----commutes-    :: forall acc env aenv a r. Kit acc-    => PrimFun (a -> r)-    -> PreOpenExp acc env aenv a-    -> Gamma acc env env aenv-    -> Maybe (PreOpenExp acc env aenv a)-commutes f x env = case f of-  PrimAdd _     -> swizzle x-  PrimMul _     -> swizzle x-  PrimBAnd _    -> swizzle x-  PrimBOr _     -> swizzle x-  PrimBXor _    -> swizzle x-  PrimEq _      -> swizzle x-  PrimNEq _     -> swizzle x-  PrimMax _     -> swizzle x-  PrimMin _     -> swizzle x-  _             -> Nothing-  where-    swizzle :: PreOpenExp acc env aenv (b,b) -> Maybe (PreOpenExp acc env aenv (b,b))-    swizzle (Tuple (NilTup `SnocTup` a `SnocTup` b))-      | Nothing         <- propagate env a-      , Just _          <- propagate env b-      = Stats.ruleFired (pprFun "commutes" f)-      $ Just $ Tuple (NilTup `SnocTup` b `SnocTup` a)----    TLM: changing the ordering here when neither term can be reduced can be---         disadvantageous: for example in (x &&* y), the user might have put a---         simpler condition first that is designed to fail fast.------      | Nothing         <- propagate env a---      , Nothing         <- propagate env b---      , hashOpenExp a > hashOpenExp b---      = Just $ Tuple (NilTup `SnocTup` b `SnocTup` a)--    swizzle _-      = Nothing---{----- Determine if successive applications of a binary operator will associate, and--- if so move them to the left. That is:------   a + (b + c)  -->  (a + b) + c------ Returning Nothing indicates no change is made.------ TLM: we might get into trouble here, as we've lost track of where the user---      has explicitly put parenthesis.------ TLM: BROKEN!! does not correctly change the sign of expressions when flipping---      (-x+y) or (-y+x).----associates-    :: (Elt a, Elt r)-    => PrimFun (a -> r)-    -> PreOpenExp acc env aenv a-    -> Maybe (PreOpenExp acc env aenv r)-associates fun exp = case fun of-  PrimAdd _     -> swizzle fun exp [PrimAdd ty, PrimSub ty]-  PrimSub _     -> swizzle fun exp [PrimAdd ty, PrimSub ty]-  PrimLAnd      -> swizzle fun exp [fun]-  PrimLOr       -> swizzle fun exp [fun]-  _             -> swizzle fun exp [fun]-  where-    -- TODO: check the list of ops is complete (and correct)-    ty  = undefined-    ops = [ PrimMul ty, PrimFDiv ty, PrimAdd ty, PrimSub ty, PrimBAnd ty, PrimBOr ty, PrimBXor ty ]--    swizzle :: (Elt a, Elt r) => PrimFun (a -> r) -> PreOpenExp acc env aenv a -> [PrimFun (a -> r)] -> Maybe (PreOpenExp acc env aenv r)-    swizzle f x lvl-      | Just Refl       <- matches f ops-      , Just (a,bc)     <- untup2 x-      , PrimApp g y     <- bc-      , Just Refl       <- matches g lvl-      , Just (b,c)      <- untup2 y-      = Stats.ruleFired (pprFun "associates" f)-      $ Just $ PrimApp g (tup2 (PrimApp f (tup2 (a,b)), c))--    swizzle _ _ _-      = Nothing--    matches :: (Elt s, Elt t) => PrimFun (s -> a) -> [PrimFun (t -> a)] -> Maybe (s :=: t)-    matches _ []        = Nothing-    matches f (x:xs)-      | Just Refl       <- matchPrimFun' f x-      = Just Refl--      | otherwise-      = matches f xs---}----- Helper functions--- ------------------type a :-> b = forall acc env aenv. Kit acc => PreOpenExp acc env aenv a -> Gamma acc env env aenv -> Maybe (PreOpenExp acc env aenv b)--eval1 :: Elt b => (a -> b) -> a :-> b-eval1 f x env-  | Just a <- propagate env x   = Stats.substitution "constant fold" . Just $ Const (fromElt (f a))-  | otherwise                   = Nothing--eval2 :: Elt c => (a -> b -> c) -> (a,b) :-> c-eval2 f (untup2 -> Just (x,y)) env-  | Just a <- propagate env x-  , Just b <- propagate env y-  = Stats.substitution "constant fold"-  $ Just $ Const (fromElt (f a b))--eval2 _ _ _-  = Nothing--tup2 :: (Elt a, Elt b) => (PreOpenExp acc env aenv a, PreOpenExp acc env aenv b) -> PreOpenExp acc env aenv (a, b)-tup2 (a,b) = Tuple (NilTup `SnocTup` a `SnocTup` b)--untup2 :: PreOpenExp acc env aenv (a, b) -> Maybe (PreOpenExp acc env aenv a, PreOpenExp acc env aenv b)-untup2 exp-  | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp = Just (a, b)-  | otherwise                                     = Nothing---pprFun :: String -> PrimFun f -> String-pprFun rule f = show $ text rule <+> snd (prettyPrim f)----- Methods of Num--- ----------------evalAdd :: Elt a => NumType a -> (a,a) :-> a-evalAdd (IntegralNumType ty) | IntegralDict <- integralDict ty = evalAdd'-evalAdd (FloatingNumType ty) | FloatingDict <- floatingDict ty = evalAdd'--evalAdd' :: (Elt a, Eq a, Num a) => (a,a) :-> a-evalAdd' (untup2 -> Just (x,y)) env-  | Just a      <- propagate env x-  , a == 0-  = Stats.ruleFired "x+0" $ Just y--evalAdd' arg env-  = eval2 (+) arg env---evalSub :: Elt a => NumType a -> (a,a) :-> a-evalSub ty@(IntegralNumType ty') | IntegralDict <- integralDict ty' = evalSub' ty-evalSub ty@(FloatingNumType ty') | FloatingDict <- floatingDict ty' = evalSub' ty--evalSub' :: forall a. (Elt a, Eq a, Num a) => NumType a -> (a,a) :-> a-evalSub' ty (untup2 -> Just (x,y)) env-  | Just b      <- propagate env y-  , b == 0-  = Stats.ruleFired "x-0" $ Just x--  | Nothing     <- propagate env x-  , Just b      <- propagate env y-  = Stats.ruleFired "-y+x"-  $ Just . snd $ evalPrimApp env (PrimAdd ty) (Tuple $ NilTup `SnocTup` Const (fromElt (-b)) `SnocTup` x)--  | Just Refl   <- match x y-  = Stats.ruleFired "x-x"-  $ Just $ Const (fromElt (0::a))--evalSub' _ arg env-  = eval2 (-) arg env---evalMul :: Elt a => NumType a -> (a,a) :-> a-evalMul (IntegralNumType ty) | IntegralDict <- integralDict ty = evalMul'-evalMul (FloatingNumType ty) | FloatingDict <- floatingDict ty = evalMul'--evalMul' :: (Elt a, Eq a, Num a) => (a,a) :-> a-evalMul' (untup2 -> Just (x,y)) env-  | Just a      <- propagate env x-  , Nothing     <- propagate env y-  = case a of-      0         -> Stats.ruleFired "x*0" $ Just x-      1         -> Stats.ruleFired "x*1" $ Just y-      _         -> Nothing--evalMul' arg env-  = eval2 (*) arg env--evalNeg :: Elt a => NumType a -> a :-> a-evalNeg _                    x _   | PrimApp PrimNeg{} x' <- x       = Stats.ruleFired "negate/negate" $ Just x'-evalNeg (IntegralNumType ty) x env | IntegralDict <- integralDict ty = eval1 negate x env-evalNeg (FloatingNumType ty) x env | FloatingDict <- floatingDict ty = eval1 negate x env--evalAbs :: Elt a => NumType a -> a :-> a-evalAbs (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 abs-evalAbs (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 abs--evalSig :: Elt a => NumType a -> a :-> a-evalSig (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 signum-evalSig (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 signum----- Methods of Integral & Bits--- ----------------------------evalQuot :: IntegralType a -> (a,a) :-> a-evalQuot ty exp env-  | Just qr    <- evalQuotRem ty exp env-  , Just (q,_) <- untup2 qr-  = Just q-evalQuot _ _ _-  = Nothing--evalRem :: IntegralType a -> (a,a) :-> a-evalRem ty exp env-  | Just qr    <- evalQuotRem ty exp env-  , Just (_,r) <- untup2 qr-  = Just r-evalRem _ _ _-  = Nothing--evalQuotRem :: forall a. IntegralType a -> (a,a) :-> (a,a)-evalQuotRem ty exp env-  | IntegralDict                           <- integralDict ty-  , Tuple (NilTup `SnocTup` x `SnocTup` y) <- exp       -- TLM: untup2, but inlined to expose the Elt dictionary-  , Just b                                 <- propagate env y-  = case b of-      0 -> Nothing-      1 -> Stats.ruleFired "quotRem x 1" $ Just (tup2 (x, Const (fromElt (0::a))))-      _ -> case propagate env x of-             Nothing -> Nothing-             Just a  -> Stats.substitution "constant fold"-                      $ Just $ let (u,v) = quotRem a b-                               in  tup2 (Const (fromElt u), Const (fromElt v))-evalQuotRem _ _ _-  = Nothing---evalIDiv :: IntegralType a -> (a,a) :-> a-evalIDiv ty exp env-  | Just dm    <- evalDivMod ty exp env-  , Just (d,_) <- untup2 dm-  = Just d-evalIDiv _ _ _-  = Nothing--evalMod :: IntegralType a -> (a,a) :-> a-evalMod ty exp env-  | Just dm    <- evalDivMod ty exp env-  , Just (_,m) <- untup2 dm-  = Just m-evalMod _ _ _-  = Nothing--evalDivMod :: forall a. IntegralType a -> (a,a) :-> (a,a)-evalDivMod ty exp env-  | IntegralDict                           <- integralDict ty-  , Tuple (NilTup `SnocTup` x `SnocTup` y) <- exp       -- TLM: untup2, but inlined to expose the Elt dictionary-  , Just b                                 <- propagate env y-  = case b of-      0 -> Nothing-      1 -> Stats.ruleFired "divMod x 1" $ Just (tup2 (x, Const (fromElt (0::a))))-      _ -> case propagate env x of-             Nothing -> Nothing-             Just a  -> Stats.substitution "constant fold"-                      $ Just $ let (u,v) = divMod a b-                               in  tup2 (Const (fromElt u), Const (fromElt v))-evalDivMod _ _ _-  = Nothing--evalBAnd :: Elt a => IntegralType a -> (a,a) :-> a-evalBAnd ty | IntegralDict <- integralDict ty = eval2 (.&.)--evalBOr :: Elt a => IntegralType a -> (a,a) :-> a-evalBOr ty | IntegralDict <- integralDict ty = eval2 (.|.)--evalBXor :: Elt a => IntegralType a -> (a,a) :-> a-evalBXor ty | IntegralDict <- integralDict ty = eval2 xor--evalBNot :: Elt a => IntegralType a -> a :-> a-evalBNot ty | IntegralDict <- integralDict ty = eval1 complement--evalBShiftL :: Elt a => IntegralType a -> (a,Int) :-> a-evalBShiftL _ (untup2 -> Just (x,i)) env-  | Just 0 <- propagate env i-  = Stats.ruleFired "x `shiftL` 0" $ Just x--evalBShiftL ty arg env-  | IntegralDict <- integralDict ty = eval2 shiftL arg env--evalBShiftR :: Elt a => IntegralType a -> (a,Int) :-> a-evalBShiftR _ (untup2 -> Just (x,i)) env-  | Just 0 <- propagate env i-  = Stats.ruleFired "x `shiftR` 0" $ Just x--evalBShiftR ty arg env-  | IntegralDict <- integralDict ty = eval2 shiftR arg env--evalBRotateL :: Elt a => IntegralType a -> (a,Int) :-> a-evalBRotateL _ (untup2 -> Just (x,i)) env-  | Just 0 <- propagate env i-  = Stats.ruleFired "x `rotateL` 0" $ Just x-evalBRotateL ty arg env-  | IntegralDict <- integralDict ty = eval2 rotateL arg env--evalBRotateR :: Elt a => IntegralType a -> (a,Int) :-> a-evalBRotateR _ (untup2 -> Just (x,i)) env-  | Just 0 <- propagate env i-  = Stats.ruleFired "x `rotateR` 0" $ Just x-evalBRotateR ty arg env-  | IntegralDict <- integralDict ty = eval2 rotateR arg env--evalPopCount :: IntegralType a -> a :-> Int-evalPopCount ty | IntegralDict <- integralDict ty = eval1 popCount--evalCountLeadingZeros :: IntegralType a -> a :-> Int-#if __GLASGOW_HASKELL__ >= 710-evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 countLeadingZeros-#else-evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 clz-  where-    clz x = (w-1) - go (w-1)-      where-        go i | i < 0       = i  -- no bit set-             | testBit x i = i-             | otherwise   = go (i-1)-        w = finiteBitSize x-#endif--evalCountTrailingZeros :: IntegralType a -> a :-> Int-#if __GLASGOW_HASKELL__ >= 710-evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 countTrailingZeros-#else-evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 ctz-  where-    ctz x = go 0-      where-        go i | i >= w      = i-             | testBit x i = i-             | otherwise   = go (i+1)-        w = finiteBitSize x-#endif----- Methods of Fractional & Floating--- ----------------------------------evalFDiv :: Elt a => FloatingType a -> (a,a) :-> a-evalFDiv ty | FloatingDict <- floatingDict ty = evalFDiv'--evalFDiv' :: (Elt a, Fractional a, Eq a) => (a,a) :-> a-evalFDiv' (untup2 -> Just (x,y)) env-  | Just 1      <- propagate env y-  = Stats.ruleFired "x/1" $ Just x--evalFDiv' arg env-  = eval2 (/) arg env---evalRecip :: Elt a => FloatingType a -> a :-> a-evalRecip ty | FloatingDict <- floatingDict ty = eval1 recip--evalSin :: Elt a => FloatingType a -> a :-> a-evalSin ty | FloatingDict <- floatingDict ty = eval1 sin--evalCos :: Elt a => FloatingType a -> a :-> a-evalCos ty | FloatingDict <- floatingDict ty = eval1 cos--evalTan :: Elt a => FloatingType a -> a :-> a-evalTan ty | FloatingDict <- floatingDict ty = eval1 tan--evalAsin :: Elt a => FloatingType a -> a :-> a-evalAsin ty | FloatingDict <- floatingDict ty = eval1 asin--evalAcos :: Elt a => FloatingType a -> a :-> a-evalAcos ty | FloatingDict <- floatingDict ty = eval1 acos--evalAtan :: Elt a => FloatingType a -> a :-> a-evalAtan ty | FloatingDict <- floatingDict ty = eval1 atan--evalSinh :: Elt a => FloatingType a -> a :-> a-evalSinh ty | FloatingDict <- floatingDict ty = eval1 sinh--evalCosh :: Elt a => FloatingType a -> a :-> a-evalCosh ty | FloatingDict <- floatingDict ty = eval1 cosh--evalTanh :: Elt a => FloatingType a -> a :-> a-evalTanh ty | FloatingDict <- floatingDict ty = eval1 tanh--evalAsinh :: Elt a => FloatingType a -> a :-> a-evalAsinh ty | FloatingDict <- floatingDict ty = eval1 asinh--evalAcosh :: Elt a => FloatingType a -> a :-> a-evalAcosh ty | FloatingDict <- floatingDict ty = eval1 acosh--evalAtanh :: Elt a => FloatingType a -> a :-> a-evalAtanh ty | FloatingDict <- floatingDict ty = eval1 atanh--evalExpFloating :: Elt a => FloatingType a -> a :-> a-evalExpFloating ty | FloatingDict <- floatingDict ty = eval1 P.exp--evalSqrt :: Elt a => FloatingType a -> a :-> a-evalSqrt ty | FloatingDict <- floatingDict ty = eval1 sqrt--evalLog :: Elt a => FloatingType a -> a :-> a-evalLog ty | FloatingDict <- floatingDict ty = eval1 log--evalFPow :: Elt a => FloatingType a -> (a,a) :-> a-evalFPow ty | FloatingDict <- floatingDict ty = eval2 (**)--evalLogBase :: Elt a => FloatingType a -> (a,a) :-> a-evalLogBase ty | FloatingDict <- floatingDict ty = eval2 logBase--evalAtan2 :: Elt a => FloatingType a -> (a,a) :-> a-evalAtan2 ty | FloatingDict <- floatingDict ty = eval2 atan2--evalTruncate :: Elt b => FloatingType a -> IntegralType b -> a :-> b-evalTruncate ta tb-  | FloatingDict <- floatingDict ta-  , IntegralDict <- integralDict tb = eval1 truncate--evalRound :: Elt b => FloatingType a -> IntegralType b -> a :-> b-evalRound ta tb-  | FloatingDict <- floatingDict ta-  , IntegralDict <- integralDict tb = eval1 round--evalFloor :: Elt b => FloatingType a -> IntegralType b -> a :-> b-evalFloor ta tb-  | FloatingDict <- floatingDict ta-  , IntegralDict <- integralDict tb = eval1 floor--evalCeiling :: Elt b => FloatingType a -> IntegralType b -> a :-> b-evalCeiling ta tb-  | FloatingDict <- floatingDict ta-  , IntegralDict <- integralDict tb = eval1 ceiling--evalIsNaN :: FloatingType a -> a :-> Bool-evalIsNaN ty | FloatingDict <- floatingDict ty = eval1 isNaN--evalIsInfinite :: FloatingType a -> a :-> Bool-evalIsInfinite ty | FloatingDict <- floatingDict ty = eval1 isInfinite----- Relational & Equality--- -----------------------evalLt :: ScalarType a -> (a,a) :-> Bool-evalLt (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (<)-evalLt (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (<)-evalLt (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (<)--evalGt :: ScalarType a -> (a,a) :-> Bool-evalGt (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (>)-evalGt (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (>)-evalGt (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (>)--evalLtEq :: ScalarType a -> (a,a) :-> Bool-evalLtEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (<=)-evalLtEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (<=)-evalLtEq (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (<=)--evalGtEq :: ScalarType a -> (a,a) :-> Bool-evalGtEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (>=)-evalGtEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (>=)-evalGtEq (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (>=)--evalEq :: ScalarType a -> (a,a) :-> Bool-evalEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (==)-evalEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (==)-evalEq (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (==)--evalNEq :: ScalarType a -> (a,a) :-> Bool-evalNEq (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (/=)-evalNEq (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (/=)-evalNEq (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (/=)--evalMax :: Elt a => ScalarType a -> (a,a) :-> a-evalMax (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 max-evalMax (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 max-evalMax (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = eval2 max--evalMin :: Elt a => ScalarType a -> (a,a) :-> a-evalMin (NumScalarType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 min-evalMin (NumScalarType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 min-evalMin (NonNumScalarType ty)                | NonNumDict   <- nonNumDict ty   = eval2 min----- Logical operators--- -------------------evalLAnd :: (Bool,Bool) :-> Bool-evalLAnd (untup2 -> Just (x,y)) env-  | Just a      <- propagate env x-  = Just $ if a then Stats.ruleFired "True &&" y-                else Stats.ruleFired "False &&" $ Const (fromElt False)--evalLAnd _ _-  = Nothing--evalLOr  :: (Bool,Bool) :-> Bool-evalLOr (untup2 -> Just (x,y)) env-  | Just a      <- propagate env x-  = Just $ if a then Stats.ruleFired "True ||" $ Const (fromElt True)-                else Stats.ruleFired "False ||" y--evalLOr _ _-  = Nothing--evalLNot :: Bool :-> Bool-evalLNot x _   | PrimApp PrimLNot x' <- x = Stats.ruleFired "not/not" $ Just x'-evalLNot x env                            = eval1 not x env--evalOrd :: Char :-> Int-evalOrd = eval1 ord--evalChr :: Int :-> Char-evalChr = eval1 chr--evalBoolToInt :: Bool :-> Int-evalBoolToInt = eval1 fromEnum--evalFromIntegral :: Elt b => IntegralType a -> NumType b -> a :-> b-evalFromIntegral ta (IntegralNumType tb)-  | IntegralDict <- integralDict ta-  , IntegralDict <- integralDict tb = eval1 fromIntegral--evalFromIntegral ta (FloatingNumType tb)-  | IntegralDict <- integralDict ta-  , FloatingDict <- floatingDict tb = eval1 fromIntegral--evalToFloating :: Elt b => NumType a -> FloatingType b -> a :-> b-evalToFloating (IntegralNumType ta) tb x env-  | IntegralDict <- integralDict ta-  , FloatingDict <- floatingDict tb = eval1 realToFrac x env--evalToFloating (FloatingNumType ta) tb x env-  | TypeFloat  FloatingDict <- ta-  , TypeFloat  FloatingDict <- tb = Just x--  | TypeDouble FloatingDict <- ta-  , TypeDouble FloatingDict <- tb = Just x--  | TypeFloat  FloatingDict <- ta-  , TypeDouble FloatingDict <- tb = eval1 float2Double x env--  | TypeDouble FloatingDict <- ta-  , TypeFloat  FloatingDict <- tb = eval1 double2Float x env--  | FloatingDict <- floatingDict ta-  , FloatingDict <- floatingDict tb = eval1 realToFrac x env--evalCoerce :: Elt b => ScalarType a -> ScalarType b -> a :-> b-evalCoerce _ _ = eval1 unsafeCoerce----- Scalar primitives--- -------------------evalPrimConst :: PrimConst a -> a-evalPrimConst (PrimMinBound ty) = evalMinBound ty-evalPrimConst (PrimMaxBound ty) = evalMaxBound ty-evalPrimConst (PrimPi       ty) = evalPi ty--evalMinBound :: BoundedType a -> a-evalMinBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = minBound-evalMinBound (NonNumBoundedType   ty) | NonNumDict   <- nonNumDict ty   = minBound--evalMaxBound :: BoundedType a -> a-evalMaxBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = maxBound-evalMaxBound (NonNumBoundedType   ty) | NonNumDict   <- nonNumDict ty   = maxBound--evalPi :: FloatingType a -> a-evalPi ty | FloatingDict <- floatingDict ty = pi-
− Data/Array/Accelerate/Trafo/Base.hs 
@@ -1,405 +0,0 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE PatternGuards        #-}-{-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE IncoherentInstances  #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}-#endif--- |--- Module      : Data.Array.Accelerate.Trafo.Base--- 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.Trafo.Base (--  -- Toolkit-  Kit(..), Match(..), (:~:)(..),-  avarIn, kmap, fromOpenAfun,--  -- Delayed Arrays-  DelayedAcc,  DelayedOpenAcc(..),-  DelayedAfun, DelayedOpenAfun,-  DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun,-  -- DelayedSeq(..), DelayedOpenSeq,-  matchDelayedOpenAcc, hashDelayedOpenAcc,--  -- Environments-  Gamma(..), incExp, prjExp, lookupExp,-  Extend(..), append, bind, Sink(..), sink, sink1,-  weakenGamma1, sinkGamma,-  Supplement(..), bindExps,--  subApply, inlineA,--) where---- standard library-import Control.Applicative-import Control.DeepSeq-import Data.Hashable-import Data.Type.Equality-import Text.PrettyPrint.ANSI.Leijen                     hiding ( (<$>) )-import Prelude                                          hiding ( until )---- friends-import Data.Array.Accelerate.AST                        hiding ( Val(..) )-import Data.Array.Accelerate.Analysis.Hash-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar                ( Array, Arrays, Shape, Elt )-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Pretty.Print-import Data.Array.Accelerate.Trafo.Substitution--import Data.Array.Accelerate.Debug.Stats                as Stats----- Toolkit--- =======---- The bat utility belt of operations required to manipulate terms parameterised--- by the recursive closure.----class (RebuildableAcc acc, Sink acc) => Kit acc where-  inject        :: PreOpenAcc acc aenv a -> acc aenv a-  extract       :: acc aenv a -> PreOpenAcc acc aenv a-  fromOpenAcc   :: OpenAcc aenv a -> acc aenv a-  ---  matchAcc      :: MatchAcc acc-  hashAcc       :: HashAcc acc-  prettyAcc     :: PrettyAcc acc--instance Kit OpenAcc where-  inject                 = OpenAcc-  extract (OpenAcc pacc) = pacc-  fromOpenAcc            = id-  ---  {-# INLINEABLE hashAcc   #-}-  {-# INLINEABLE matchAcc  #-}-  {-# INLINEABLE prettyAcc #-}-  hashAcc                = hashOpenAcc-  matchAcc               = matchOpenAcc-  prettyAcc              = prettyOpenAcc--avarIn :: (Kit acc, Arrays arrs) => Idx aenv arrs -> acc aenv arrs-avarIn = inject  . Avar--kmap :: Kit acc => (PreOpenAcc acc aenv a -> PreOpenAcc acc aenv b) -> acc aenv a -> acc aenv b-kmap f = inject . f . extract--fromOpenAfun :: Kit acc => OpenAfun aenv f -> PreOpenAfun acc aenv f-fromOpenAfun (Abody a) = Abody $ fromOpenAcc a-fromOpenAfun (Alam f)  = Alam  $ fromOpenAfun f---- A class for testing the equality of terms homogeneously, returning a witness--- to the existentially quantified terms in the positive case.----class Match f where-  match :: f s -> f t -> Maybe (s :~: t)--instance Match (Idx env) where-  {-# INLINEABLE match #-}-  match = matchIdx--instance Kit acc => Match (PreOpenExp acc env aenv) where-  {-# INLINEABLE match #-}-  match = matchPreOpenExp matchAcc hashAcc--instance Kit acc => Match (PreOpenFun acc env aenv) where-  {-# INLINEABLE match #-}-  match = matchPreOpenFun matchAcc hashAcc--instance Kit acc => Match (PreOpenAcc acc aenv) where-  {-# INLINEABLE match #-}-  match = matchPreOpenAcc matchAcc hashAcc--instance {-# INCOHERENT #-} Kit acc => Match (acc aenv) where-  {-# INLINEABLE match #-}-  match = matchAcc----- Delayed Arrays--- ==============---- The type of delayed arrays. This representation is used to annotate the AST--- in the recursive knot to distinguish standard AST terms from operand arrays--- that should be embedded into their consumers.----type DelayedAcc         = DelayedOpenAcc ()-type DelayedAfun        = PreOpenAfun DelayedOpenAcc ()--type DelayedExp         = DelayedOpenExp ()-type DelayedFun         = DelayedOpenFun ()---- data DelayedSeq t where---   DelayedSeq :: Extend DelayedOpenAcc () aenv---              -> DelayedOpenSeq aenv () t---              -> DelayedSeq t--type DelayedOpenAfun    = PreOpenAfun DelayedOpenAcc-type DelayedOpenExp     = PreOpenExp DelayedOpenAcc-type DelayedOpenFun     = PreOpenFun DelayedOpenAcc--- type DelayedOpenSeq     = PreOpenSeq DelayedOpenAcc--data DelayedOpenAcc aenv a where-  Manifest              :: PreOpenAcc DelayedOpenAcc aenv a -> DelayedOpenAcc aenv a--  Delayed               :: (Shape sh, Elt e) =>-    { extentD           :: PreExp DelayedOpenAcc aenv sh-    , indexD            :: PreFun DelayedOpenAcc aenv (sh  -> e)-    , linearIndexD      :: PreFun DelayedOpenAcc aenv (Int -> e)-    }                   -> DelayedOpenAcc aenv (Array sh e)--instance Rebuildable DelayedOpenAcc where-  type AccClo DelayedOpenAcc = DelayedOpenAcc-  {-# INLINEABLE rebuildPartial #-}-  rebuildPartial v acc = case acc of-    Manifest pacc -> Manifest <$> rebuildPartial v pacc-    Delayed{..}   -> Delayed  <$> rebuildPartial v extentD-                              <*> rebuildPartial v indexD-                              <*> rebuildPartial v linearIndexD--instance Sink DelayedOpenAcc where-  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)--instance Kit DelayedOpenAcc where-  inject                  = Manifest-  extract (Manifest pacc) = pacc-  extract Delayed{}       = error "DelayedAcc.extract"-  fromOpenAcc             = error "DelayedAcc.fromOpenAcc"-  ---  {-# INLINEABLE hashAcc   #-}-  {-# INLINEABLE matchAcc  #-}-  {-# INLINEABLE prettyAcc #-}-  hashAcc                 = hashDelayedOpenAcc-  matchAcc                = matchDelayedOpenAcc-  prettyAcc               = prettyDelayedOpenAcc--instance NFData (DelayedOpenAfun aenv t) where-  rnf = rnfPreOpenAfun rnfDelayedOpenAcc--instance NFData (DelayedOpenAcc aenv t) where-  rnf = rnfDelayedOpenAcc---- instance NFData (DelayedSeq t) where---   rnf = rnfDelayedSeq--hashDelayedOpenAcc :: HashAcc DelayedOpenAcc-hashDelayedOpenAcc (Manifest pacc)     = $(hashQ "Manifest") `hashWithSalt` hashPreOpenAcc hashAcc pacc-hashDelayedOpenAcc Delayed{..}         = $(hashQ "Delayed")  `hashE` extentD `hashF` indexD `hashF` linearIndexD-  where-    hashE salt = hashWithSalt salt . hashPreOpenExp hashAcc-    hashF salt = hashWithSalt salt . hashPreOpenFun hashAcc--matchDelayedOpenAcc :: MatchAcc DelayedOpenAcc-matchDelayedOpenAcc (Manifest pacc1) (Manifest pacc2)-  = matchPreOpenAcc matchAcc hashAcc pacc1 pacc2--matchDelayedOpenAcc (Delayed sh1 ix1 lx1) (Delayed sh2 ix2 lx2)-  | Just Refl <- matchPreOpenExp matchAcc hashAcc sh1 sh2-  , Just Refl <- matchPreOpenFun matchAcc hashAcc ix1 ix2-  , Just Refl <- matchPreOpenFun matchAcc hashAcc lx1 lx2-  = Just Refl--matchDelayedOpenAcc _ _-  = Nothing--rnfDelayedOpenAcc :: DelayedOpenAcc aenv t -> ()-rnfDelayedOpenAcc (Manifest pacc)    = rnfPreOpenAcc rnfDelayedOpenAcc pacc-rnfDelayedOpenAcc (Delayed sh ix lx) = rnfPreOpenExp rnfDelayedOpenAcc sh-                                 `seq` rnfPreOpenFun rnfDelayedOpenAcc ix-                                 `seq` rnfPreOpenFun rnfDelayedOpenAcc lx--{---rnfDelayedSeq :: DelayedSeq t -> ()-rnfDelayedSeq (DelayedSeq env s) = rnfExtend rnfDelayedOpenAcc env-                             `seq` rnfPreOpenSeq rnfDelayedOpenAcc s--rnfExtend :: NFDataAcc acc -> Extend acc aenv aenv' -> ()-rnfExtend _    BaseEnv         = ()-rnfExtend rnfA (PushEnv env a) = rnfExtend rnfA env `seq` rnfA a---}----- Note: If we detect that the delayed array is simply accessing an array--- variable, then just print the variable name. That is:------ > let a0 = <...> in map f (Delayed (shape a0) (\x0 -> a0!x0))------ becomes------ > let a0 = <...> in map f a0----prettyDelayedOpenAcc :: PrettyAcc DelayedOpenAcc-prettyDelayedOpenAcc wrap aenv acc = case acc of-  Manifest pacc         -> prettyPreOpenAcc prettyDelayedOpenAcc wrap aenv pacc-  Delayed sh f _-    | Shape a           <- sh-    , Just Refl         <- match f (Lam (Body (Index a (Var ZeroIdx))))-    -> prettyDelayedOpenAcc wrap aenv a--    | otherwise-    -> wrap $ hang 2 (sep [ green (text "delayed")-                          , parens (align (prettyPreExp prettyDelayedOpenAcc (parens . align) aenv sh))-                          , parens (align (prettyPreFun prettyDelayedOpenAcc aenv f))-                          ])--{----- Pretty print delayed sequences------ TLM: What is going on with this sequence thing, why is it closed?----prettyDelayedSeq-    :: (Doc -> Doc)                             -- apply to compound expressions-    -> DelayedSeq arrs-    -> Doc-prettyDelayedSeq wrap (DelayedSeq aenv s)-  | (d, lvl) <- pp env 0-  =  wrap $   (hang (text "let") 2 $ sep $ punctuate semi d)-          <+> (hang (text "in")  2 $ sep $ punctuate semi-                                         $ prettyPreSeq wrap prettyAcc lvl 0 s)-  where-    pp :: Extend DelayedOpenAcc aenv aenv' -> Int -> ([Doc], Int)-    pp BaseEnv          lvl = ([],lvl)-    pp (PushEnv env' a) lvl | (d', _) <- pp env' (lvl + 1)-                            = (prettyAcc lvl wrap a : d', lvl)---}----- Environments--- ============---- An environment that holds let-bound scalar expressions. The second--- environment variable env' is used to project out the corresponding--- index when looking up in the environment congruent expressions.----data Gamma acc env env' aenv where-  EmptyExp :: Gamma      acc env env'      aenv--  PushExp  :: Gamma      acc env env'      aenv-           -> PreOpenExp acc env           aenv t-           -> Gamma      acc env (env', t) aenv--incExp :: RebuildableAcc acc => Gamma acc env env' aenv -> Gamma acc (env, s) env' aenv-incExp EmptyExp        = EmptyExp-incExp (PushExp env e) = incExp env `PushExp` weakenE SuccIdx e--prjExp :: Idx env' t -> Gamma acc env env' aenv -> PreOpenExp acc env aenv t-prjExp ZeroIdx      (PushExp _   v) = v-prjExp (SuccIdx ix) (PushExp env _) = prjExp ix env-prjExp _            _               = $internalError "prjExp" "inconsistent valuation"--weakenGamma1 :: Kit acc => Gamma acc env env' aenv -> Gamma acc env env' (aenv,t)-weakenGamma1 EmptyExp        = EmptyExp-weakenGamma1 (PushExp env e) = PushExp (weakenGamma1 env) (weaken SuccIdx e)--sinkGamma :: Kit acc => Extend acc aenv aenv' -> Gamma acc env env' aenv -> Gamma acc env env' aenv'-sinkGamma _   EmptyExp        = EmptyExp-sinkGamma ext (PushExp env e) = PushExp (sinkGamma ext env) (sink ext e)--lookupExp :: Kit acc => Gamma acc env env' aenv -> PreOpenExp acc env aenv t -> Maybe (Idx env' t)-lookupExp EmptyExp        _ = Nothing-lookupExp (PushExp env e) x-  | Just Refl <- match e x  = Just ZeroIdx-  | otherwise               = SuccIdx `fmap` lookupExp env x----- As part of various transformations we often need to lift out array valued--- inputs to be let-bound at a higher point.------ The Extend type is a heterogeneous snoc-list of array terms that witnesses--- how the array environment is extended by binding these additional terms.----data Extend acc aenv aenv' where-  BaseEnv :: Extend acc aenv aenv--  PushEnv :: Arrays a-          => Extend acc aenv aenv' -> acc aenv' a -> Extend acc aenv (aenv', a)---- Append two environment witnesses----append :: Extend acc env env' -> Extend acc env' env'' -> Extend acc env env''-append x BaseEnv        = x-append x (PushEnv as a) = x `append` as `PushEnv` a---- Bring into scope all of the array terms in the Extend environment list. This--- converts a term in the inner environment (aenv') into the outer (aenv).----bind :: (Kit acc, Arrays a)-     => Extend acc aenv aenv'-     -> PreOpenAcc acc aenv' a-     -> PreOpenAcc acc aenv  a-bind BaseEnv         = id-bind (PushEnv env a) = bind env . Alet a . inject---- Sink a term from one array environment into another, where additional--- bindings have come into scope according to the witness and no old things have--- vanished.----sink :: Sink f => Extend acc env env' -> f env t -> f env' t-sink env = weaken (k env)-  where-    k :: Extend acc env env' -> Idx env t -> Idx env' t-    k BaseEnv       = Stats.substitution "sink" id-    k (PushEnv e _) = SuccIdx . k e--sink1 :: Sink f => Extend acc env env' -> f (env,s) t -> f (env',s) t-sink1 env = weaken (k env)-  where-    k :: Extend acc env env' -> Idx (env,s) t -> Idx (env',s) t-    k BaseEnv       = Stats.substitution "sink1" id-    k (PushEnv e _) = split . k e-    ---    split :: Idx (env,s) t -> Idx ((env,u),s) t-    split ZeroIdx      = ZeroIdx-    split (SuccIdx ix) = SuccIdx (SuccIdx ix)---- This is the same as above, however for the scalar environment.------ RCE: This is much the same as `Gamma` above. The main difference being that the expressions--- stored in a `Gamma` can not depend on each other, whereas in `Supplement` they can. We should--- perhaps look at using `Supplement` wherever possible.----data Supplement acc env env' aenv where-  BaseSup :: Supplement acc env env aenv-  PushSup :: Elt e-          => Supplement acc env env' aenv-          -> PreOpenExp acc env' aenv e-          -> Supplement acc env (env', e) aenv--bindExps :: (Kit acc, Elt e)-         => Supplement acc env env' aenv-         -> PreOpenExp acc env' aenv e-         -> PreOpenExp acc env aenv e-bindExps BaseSup       = id-bindExps (PushSup g b) = bindExps g . Let b---- Application via let binding.----subApply :: (RebuildableAcc acc, Arrays a)-         => PreOpenAfun acc aenv (a -> b)-         -> acc             aenv a-         -> PreOpenAcc  acc aenv b-subApply (Alam (Abody f)) a = Alet a f-subApply _                _ = error "subApply: inconsistent evaluation"---- | Replace all occurrences of the first variable with the given array--- expression. The environment shrinks.----inlineA :: Rebuildable f => f (aenv,s) t -> PreOpenAcc (AccClo f) aenv s -> f aenv t-inlineA f g = Stats.substitution "inlineA" $ rebuildA (subAtop g) f-
− Data/Array/Accelerate/Trafo/Fusion.hs 
@@ -1,1559 +0,0 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE IncoherentInstances  #-}-{-# LANGUAGE InstanceSigs         #-}-{-# LANGUAGE PatternGuards        #-}-{-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns         #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing      #-}--- |--- Module      : Data.Array.Accelerate.Trafo.Fusion--- Copyright   : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell---               [2014..2014] Frederik M. Madsen--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ This module implements producer/producer and consumer/producer fusion as a--- term rewriting of the Accelerate AST.------ The function 'quench' perform the source-to-source fusion transformation,--- while 'anneal' additionally makes the representation of embedded producers--- explicit by representing the AST as a 'DelayedAcc' of manifest and delayed--- nodes.-----module Data.Array.Accelerate.Trafo.Fusion (--  -- ** Types-  DelayedAcc, DelayedOpenAcc(..),-  DelayedAfun, DelayedOpenAfun,-  DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun,--  -- ** Conversion-  convertAcc, convertAfun,--) where---- standard library-import Prelude                                          hiding ( exp, until )---- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Trafo.Base-import Data.Array.Accelerate.Trafo.Shrink-import Data.Array.Accelerate.Trafo.Simplify-import Data.Array.Accelerate.Trafo.Substitution-import Data.Array.Accelerate.Array.Representation       ( SliceIndex(..) )-import Data.Array.Accelerate.Array.Sugar                ( Array, Arrays(..), ArraysR(..), ArrRepr-                                                        , Elt, EltRepr, Shape, Tuple(..), Atuple(..)-                                                        , IsAtuple, TupleRepr )-import Data.Array.Accelerate.Product--import qualified Data.Array.Accelerate.Debug            as Stats-#ifdef ACCELERATE_DEBUG-import System.IO.Unsafe -- for debugging-#endif----- Delayed Array Fusion--- ====================---- | Apply the fusion transformation to a closed de Bruijn AST----convertAcc :: Arrays arrs => Bool -> Acc arrs -> DelayedAcc arrs-convertAcc fuseAcc = withSimplStats . convertOpenAcc fuseAcc---- | Apply the fusion transformation to a function of array arguments----convertAfun :: Bool -> Afun f -> DelayedAfun f-convertAfun fuseAcc = withSimplStats . convertOpenAfun fuseAcc---- -- | Apply the fusion transformation to the array computations embedded--- --   in a sequence computation.--- convertSeq :: Bool -> Seq a -> DelayedSeq a--- convertSeq fuseAcc (embedSeq (embedOpenAcc fuseAcc) -> ExtendSeq aenv s)---   = withSimplStats (DelayedSeq (cvtE aenv) (convertOpenSeq fuseAcc s))---   where---     cvtE :: Extend OpenAcc aenv aenv' -> Extend DelayedOpenAcc aenv aenv'---     cvtE BaseEnv                                          = BaseEnv---     cvtE (PushEnv env a) | a' <- convertOpenAcc fuseAcc a = PushEnv (cvtE env) a'--withSimplStats :: a -> a-#ifdef ACCELERATE_DEBUG-withSimplStats x = unsafePerformIO Stats.resetSimplCount `seq` x-#else-withSimplStats x = x-#endif----- | Apply the fusion transformation to an AST. This consists of two phases:------    1. A bottom-up traversal that converts nodes into the internal delayed---       representation, merging adjacent producer/producer pairs.------    2. A top-down traversal that makes the representation of fused---       consumer/producer pairs explicit as a 'DelayedAcc' of manifest and---       delayed nodes.------ TLM: Note that there really is no ambiguity as to which state an array will---      be in following this process: an array will be either delayed or---      manifest, and the two helper functions are even named as such! We should---      encode this property in the type somehow...----convertOpenAcc :: Arrays arrs => Bool -> OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs-convertOpenAcc fuseAcc = manifest fuseAcc . computeAcc . embedOpenAcc fuseAcc---- Convert array computations into an embeddable delayed representation.--- Reapply the embedding function from the first pass and unpack the--- representation. It is safe to match on BaseEnv because the first pass--- will put producers adjacent to the term consuming it.----delayed :: (Shape sh, Elt e) => Bool -> OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e)-delayed fuseAcc (embedOpenAcc fuseAcc -> Embed BaseEnv cc) =-  case cc of-    Done v                                -> Delayed (arrayShape v) (indexArray v) (linearIndex v)-    Yield (cvtE -> sh) (cvtF -> f)        -> Delayed sh f (f `compose` fromIndex sh)-    Step  (cvtE -> sh) (cvtF -> p) (cvtF -> f) v-      | Just Refl <- match sh (arrayShape v)-      , Just Refl <- isIdentity p-      -> Delayed sh (f `compose` indexArray v) (f `compose` linearIndex v)--      | f'        <- f `compose` indexArray v `compose` p-      -> Delayed sh f' (f' `compose` fromIndex sh)-  where-    cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t-    cvtE = convertOpenExp fuseAcc--    cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f-    cvtF (Lam f)  = Lam (cvtF f)-    cvtF (Body b) = Body (cvtE b)---- Convert array programs as manifest terms.----manifest :: Bool -> OpenAcc aenv a -> DelayedOpenAcc aenv a-manifest fuseAcc (OpenAcc pacc) =-  let fusionError = $internalError "manifest" "unexpected fusible materials"-  in-  Manifest $ case pacc of-    -- Non-fusible terms-    -- ------------------    Avar ix                 -> Avar ix-    Use arr                 -> Use arr-    Unit e                  -> Unit (cvtE e)-    Alet bnd body           -> alet (manifest fuseAcc bnd) (manifest fuseAcc body)-    Acond p t e             -> Acond (cvtE p) (manifest fuseAcc t) (manifest fuseAcc e)-    Awhile p f a            -> Awhile (cvtAF p) (cvtAF f) (manifest fuseAcc a)-    Atuple tup              -> Atuple (cvtAT tup)-    Aprj ix tup             -> Aprj ix (manifest fuseAcc tup)-    Apply f a               -> Apply (cvtAF f) (manifest fuseAcc a)-    Aforeign ff f a         -> Aforeign ff (cvtAF f) (manifest fuseAcc a)--    -- Producers-    -- ----------    ---    -- Some producers might still exist as a manifest array. Typically-    -- this is because they are the last stage of the computation, or the-    -- result of a let-binding to be used multiple times. The input array-    -- here should be an array variable, else something went wrong.-    ---    Map f a                 -> Map (cvtF f) (delayed fuseAcc a)-    Generate sh f           -> Generate (cvtE sh) (cvtF f)-    Transform sh p f a      -> Transform (cvtE sh) (cvtF p) (cvtF f) (delayed fuseAcc a)-    Backpermute sh p a      -> Backpermute (cvtE sh) (cvtF p) (delayed fuseAcc a)-    Reshape sl a            -> Reshape (cvtE sl) (manifest fuseAcc a)--    Replicate{}             -> fusionError-    Slice{}                 -> fusionError-    ZipWith{}               -> fusionError--    -- Consumers-    -- ----------    ---    -- Embed producers directly into the representation. For stencils we-    -- make an exception. Since these consumers access elements of the-    -- argument array multiple times, we are careful not to duplicate work-    -- and instead force the argument to be a manifest array.-    ---    Fold f z a              -> Fold     (cvtF f) (cvtE z) (delayed fuseAcc a)-    Fold1 f a               -> Fold1    (cvtF f) (delayed fuseAcc a)-    FoldSeg f z a s         -> FoldSeg  (cvtF f) (cvtE z) (delayed fuseAcc a) (delayed fuseAcc s)-    Fold1Seg f a s          -> Fold1Seg (cvtF f) (delayed fuseAcc a) (delayed fuseAcc s)-    Scanl f z a             -> Scanl    (cvtF f) (cvtE z) (delayed fuseAcc a)-    Scanl1 f a              -> Scanl1   (cvtF f) (delayed fuseAcc a)-    Scanl' f z a            -> Scanl'   (cvtF f) (cvtE z) (delayed fuseAcc a)-    Scanr f z a             -> Scanr    (cvtF f) (cvtE z) (delayed fuseAcc a)-    Scanr1 f a              -> Scanr1   (cvtF f) (delayed fuseAcc a)-    Scanr' f z a            -> Scanr'   (cvtF f) (cvtE z) (delayed fuseAcc a)-    Permute f d p a         -> Permute  (cvtF f) (manifest fuseAcc d) (cvtF p) (delayed fuseAcc a)-    Stencil f x a           -> Stencil  (cvtF f) (cvtB x) (manifest fuseAcc a)-    Stencil2 f x a y b      -> Stencil2 (cvtF f) (cvtB x) (manifest fuseAcc a) (cvtB y) (manifest fuseAcc b)-    -- Collect s               -> Collect  (cvtS s)--    where-      -- Flatten needless let-binds, which can be introduced by the conversion to-      -- the internal embeddable representation.-      ---      alet bnd body-        | Manifest (Avar ZeroIdx) <- body-        , Manifest x              <- bnd-        = x--        | otherwise-        = Alet bnd body--      cvtAT :: Atuple (OpenAcc aenv) a -> Atuple (DelayedOpenAcc aenv) a-      cvtAT NilAtup        = NilAtup-      cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` manifest fuseAcc a--      cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f-      cvtAF (Alam f)  = Alam  (cvtAF f)-      cvtAF (Abody b) = Abody (manifest fuseAcc b)--      -- cvtS :: PreOpenSeq OpenAcc aenv senv s -> PreOpenSeq DelayedOpenAcc aenv senv s-      -- cvtS = convertOpenSeq fuseAcc--      -- Conversions for closed scalar functions and expressions-      ---      cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f-      cvtF (Lam f)  = Lam (cvtF f)-      cvtF (Body b) = Body (cvtE b)--      cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t-      cvtE = convertOpenExp fuseAcc--      cvtB :: Boundary aenv t -> PreBoundary DelayedOpenAcc aenv t-      cvtB Clamp        = Clamp-      cvtB Mirror       = Mirror-      cvtB Wrap         = Wrap-      cvtB (Constant v) = Constant v-      cvtB (Function f) = Function (cvtF f)--convertOpenExp :: Bool -> OpenExp env aenv t -> DelayedOpenExp env aenv t-convertOpenExp fuseAcc exp =-  case exp of-    Let bnd body            -> Let (cvtE bnd) (cvtE body)-    Var ix                  -> Var ix-    Const c                 -> Const c-    Tuple tup               -> Tuple (cvtT tup)-    Prj ix t                -> Prj ix (cvtE t)-    IndexNil                -> IndexNil-    IndexCons sh sz         -> IndexCons (cvtE sh) (cvtE sz)-    IndexHead sh            -> IndexHead (cvtE sh)-    IndexTail sh            -> IndexTail (cvtE sh)-    IndexAny                -> IndexAny-    IndexSlice x ix sh      -> IndexSlice x (cvtE ix) (cvtE sh)-    IndexFull x ix sl       -> IndexFull x (cvtE ix) (cvtE sl)-    ToIndex sh ix           -> ToIndex (cvtE sh) (cvtE ix)-    FromIndex sh ix         -> FromIndex (cvtE sh) (cvtE ix)-    Cond p t e              -> Cond (cvtE p) (cvtE t) (cvtE e)-    While p f x             -> While (cvtF p) (cvtF f) (cvtE x)-    PrimConst c             -> PrimConst c-    PrimApp f x             -> PrimApp f (cvtE x)-    Index a sh              -> Index (manifest fuseAcc a) (cvtE sh)-    LinearIndex a i         -> LinearIndex (manifest fuseAcc a) (cvtE i)-    Shape a                 -> Shape (manifest fuseAcc a)-    ShapeSize sh            -> ShapeSize (cvtE sh)-    Intersect s t           -> Intersect (cvtE s) (cvtE t)-    Union s t               -> Union (cvtE s) (cvtE t)-    Foreign ff f e          -> Foreign ff (cvtF f) (cvtE e)-  where-    cvtT :: Tuple (OpenExp env aenv) t -> Tuple (DelayedOpenExp env aenv) t-    cvtT NilTup        = NilTup-    cvtT (SnocTup t e) = cvtT t `SnocTup` cvtE e--    -- Conversions for closed scalar functions and expressions-    ---    cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f-    cvtF (Lam f)  = Lam (cvtF f)-    cvtF (Body b) = Body (cvtE b)--    cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t-    cvtE = convertOpenExp fuseAcc---convertOpenAfun :: Bool -> OpenAfun aenv f -> DelayedOpenAfun aenv f-convertOpenAfun c (Alam  f) = Alam  (convertOpenAfun c f)-convertOpenAfun c (Abody b) = Abody (convertOpenAcc  c b)--{---convertOpenSeq :: Bool -> PreOpenSeq OpenAcc aenv senv a -> PreOpenSeq DelayedOpenAcc aenv senv a-convertOpenSeq fuseAcc s =-  case s of-    Consumer c          -> Consumer (cvtC c)-    Reify ix            -> Reify ix-    Producer p s'       -> Producer p' (convertOpenSeq fuseAcc s')-      where-        p' = case p of-               StreamIn arrs     -> StreamIn arrs-               ToSeq slix sh a   -> ToSeq slix sh (delayed fuseAcc a)-               MapSeq f x        -> MapSeq (cvtAF f) x-               ChunkedMapSeq f x -> ChunkedMapSeq (cvtAF f) x-               ZipWithSeq f x y  -> ZipWithSeq (cvtAF f) x y-               ScanSeq f e x     -> ScanSeq (cvtF f) (cvtE e) x-  where-    cvtC :: Consumer OpenAcc aenv senv a -> Consumer DelayedOpenAcc aenv senv a-    cvtC c =-      case c of-        FoldSeq f e x        -> FoldSeq (cvtF f) (cvtE e) x-        FoldSeqFlatten f a x -> FoldSeqFlatten (cvtAF f) (manifest fuseAcc a) x-        Stuple t             -> Stuple (cvtCT t)--    cvtCT :: Atuple (Consumer OpenAcc aenv senv) t -> Atuple (Consumer DelayedOpenAcc aenv senv) t-    cvtCT NilAtup        = NilAtup-    cvtCT (SnocAtup t c) = SnocAtup (cvtCT t) (cvtC c)--    cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f-    cvtAF (Alam f)  = Alam  (cvtAF f)-    cvtAF (Abody b) = Abody (manifest fuseAcc b)--    cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t-    cvtE = convertOpenExp fuseAcc--    cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f-    cvtF (Lam f)  = Lam (cvtF f)-    cvtF (Body b) = Body (cvtE b)---}----- | Apply the fusion transformation to the AST to combine and simplify terms.--- This converts terms into the internal delayed array representation and merges--- adjacent producer/producer terms. Using the reduced internal form limits the--- number of combinations that need to be considered.----type EmbedAcc acc = forall aenv arrs. Arrays arrs => acc aenv arrs -> Embed acc aenv arrs-type ElimAcc  acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Bool--embedOpenAcc :: Arrays arrs => Bool -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs-embedOpenAcc fuseAcc (OpenAcc pacc) =-  embedPreAcc fuseAcc (embedOpenAcc fuseAcc) elimOpenAcc pacc-  where-    -- When does the cost of re-computation outweigh that of memory access? For-    -- the moment only do the substitution on a single use of the bound array-    -- into the use site, but it is likely advantageous to be far more-    -- aggressive here.-    ---    -- SEE: [Sharing vs. Fusion]-    ---    elimOpenAcc :: ElimAcc OpenAcc-    elimOpenAcc _bnd body-      | count False ZeroIdx body <= lIMIT = True-      | otherwise                         = False-      where-        lIMIT = 1--        count :: UsesOfAcc OpenAcc-        count no ix (OpenAcc pacc) = usesOfPreAcc no count ix pacc---embedPreAcc-    :: forall acc aenv arrs. (Kit acc, Arrays arrs)-    => Bool-    -> EmbedAcc   acc-    -> ElimAcc    acc-    -> PreOpenAcc acc aenv arrs-    -> Embed      acc aenv arrs-embedPreAcc fuseAcc embedAcc elimAcc pacc-  = unembed-  $ case pacc of--    -- Non-fusible terms-    -- ------------------    ---    -- Solid and semi-solid terms that we generally do not wish to fuse, such-    -- as control flow (|?), array introduction (use, unit), array tupling and-    -- projection, and foreign function operations. Generally we also do not-    -- want to fuse past array let bindings, as this would imply work-    -- duplication. SEE: [Sharing vs. Fusion]-    ---    Apply f a           -> applyD (cvtAF f) (cvtA a)-    Alet bnd body       -> aletD embedAcc elimAcc bnd body-    Aprj ix tup         -> aprjD embedAcc ix tup-    Acond p at ae       -> acondD embedAcc (cvtE p) at ae-    Awhile p f a        -> done $ Awhile (cvtAF p) (cvtAF f) (cvtA a)-    Atuple tup          -> done $ Atuple (cvtAT tup)-    Aforeign ff f a     -> done $ Aforeign ff (cvtAF f) (cvtA a)-    -- Collect s           -> collectD s--    -- Array injection-    Avar v              -> done $ Avar v-    Use arrs            -> done $ Use arrs-    Unit e              -> done $ Unit (cvtE e)--    -- Producers-    -- ----------    ---    -- The class of operations that given a set of zero or more input arrays,-    -- produce a _single_ element for the output array by manipulating a-    -- _single_ element from each input array. These can be further classified-    -- as value (map, zipWith) or index space (backpermute, slice, replicate)-    -- transformations.-    ---    -- The critical feature is that each element of the output is produced-    -- independently of all others, and so we can aggressively fuse arbitrary-    -- sequences of these operations.-    ---    Generate sh f       -> generateD (cvtE sh) (cvtF f)--    Map f a             -> mapD (cvtF f) (embedAcc a)-    ZipWith f a b       -> fuse2 (into zipWithD (cvtF f)) a b-    Transform sh p f a  -> transformD (cvtE sh) (cvtF p) (cvtF f) (embedAcc a)--    Backpermute sl p a  -> fuse (into2 backpermuteD      (cvtE sl) (cvtF p)) a-    Slice slix a sl     -> fuse (into  (sliceD slix)     (cvtE sl)) a-    Replicate slix sh a -> fuse (into  (replicateD slix) (cvtE sh)) a-    Reshape sl a        -> reshapeD (embedAcc a) (cvtE sl)--    -- Consumers-    -- ----------    ---    -- Operations where each element of the output array depends on multiple-    -- elements of the input array. To implement these operations efficiently in-    -- parallel, we need to know how elements of the array depend on each other:-    -- a parallel scan is implemented very differently from a parallel fold, for-    -- example.-    ---    -- In order to avoid obfuscating this crucial information required for-    -- parallel implementation, fusion is separated into to phases:-    -- producer/producer, implemented above, and consumer/producer, which is-    -- implemented below. This will place producers adjacent to the consumer-    -- node, so that the producer can be directly embedded into the consumer-    -- during the code generation phase.-    ---    Fold f z a          -> embed  (into2 Fold          (cvtF f) (cvtE z)) a-    Fold1 f a           -> embed  (into  Fold1         (cvtF f)) a-    FoldSeg f z a s     -> embed2 (into2 FoldSeg       (cvtF f) (cvtE z)) a s-    Fold1Seg f a s      -> embed2 (into  Fold1Seg      (cvtF f)) a s-    Scanl f z a         -> embed  (into2 Scanl         (cvtF f) (cvtE z)) a-    Scanl1 f a          -> embed  (into  Scanl1        (cvtF f)) a-    Scanl' f z a        -> embed  (into2 Scanl'        (cvtF f) (cvtE z)) a-    Scanr f z a         -> embed  (into2 Scanr         (cvtF f) (cvtE z)) a-    Scanr1 f a          -> embed  (into  Scanr1        (cvtF f)) a-    Scanr' f z a        -> embed  (into2 Scanr'        (cvtF f) (cvtE z)) a-    Permute f d p a     -> embed2 (into2 permute       (cvtF f) (cvtF p)) d a-    Stencil f x a       -> lift   (into2 Stencil       (cvtF f) (cvtB x)) a-    Stencil2 f x a y b  -> lift2  (into3 stencil2      (cvtF f) (cvtB x) (cvtB y)) a b--  where-    -- If fusion is not enabled, force terms to the manifest representation-    ---    unembed :: Embed acc aenv arrs -> Embed acc aenv arrs-    unembed x-      | fuseAcc         = x-      | otherwise       = done (compute x)--    cvtA :: Arrays a => acc aenv' a -> acc aenv' a-    cvtA = computeAcc . embedAcc--    cvtAT :: Atuple (acc aenv') a -> Atuple (acc aenv') a-    cvtAT NilAtup          = NilAtup-    cvtAT (SnocAtup tup a) = cvtAT tup `SnocAtup` cvtA a--    cvtAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f-    cvtAF (Alam  f) = Alam  (cvtAF f)-    cvtAF (Abody a) = Abody (cvtA a)--    -- Helpers to shuffle the order of arguments to a constructor-    ---    permute f p d a     = Permute f d p a-    stencil2 f x y a b  = Stencil2 f x a y b--    -- Conversions for closed scalar functions and expressions. This just-    -- applies scalar simplifications.-    ---    cvtF :: PreFun acc aenv' t -> PreFun acc aenv' t-    cvtF = simplify--    cvtE :: Elt t => PreExp acc aenv' t -> PreExp acc aenv' t-    cvtE = simplify--    cvtB :: PreBoundary acc aenv' t -> PreBoundary acc aenv' t-    cvtB Clamp        = Clamp-    cvtB Mirror       = Mirror-    cvtB Wrap         = Wrap-    cvtB (Constant c) = Constant c-    cvtB (Function f) = Function (cvtF f)--    -- Helpers to embed and fuse delayed terms-    ---    into :: Sink f => (f env' a -> b) -> f env a -> Extend acc env env' -> b-    into op a env = op (sink env a)--    into2 :: (Sink f1, Sink f2)-          => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b -> Extend acc env env' -> c-    into2 op a b env = op (sink env a) (sink env b)--    into3 :: (Sink f1, Sink f2, Sink f3)-          => (f1 env' a -> f2 env' b -> f3 env' c -> d) -> f1 env a -> f2 env b -> f3 env c -> Extend acc env env' -> d-    into3 op a b c env = op (sink env a) (sink env b) (sink env c)--    fuse :: Arrays as-         => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs)-         ->       acc aenv as-         -> Embed acc aenv bs-    fuse op (embedAcc -> Embed env cc) = Embed env (op env cc)--    fuse2 :: (Arrays as, Arrays bs)-          => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs -> Cunctation acc aenv' cs)-          ->       acc aenv as-          ->       acc aenv bs-          -> Embed acc aenv cs-    fuse2 op a1 a0-      | Embed env1 cc1  <- embedAcc a1-      , Embed env0 cc0  <- embedAcc (sink env1 a0)-      , env             <- env1 `append` env0-      = Embed env (op env (sink env0 cc1) cc0)--    embed :: (Arrays as, Arrays bs)-          => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs)-          ->       acc aenv as-          -> Embed acc aenv bs-    embed = trav1 id--    embed2 :: forall aenv as bs cs. (Arrays as, Arrays bs, Arrays cs)-           => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs)-           ->       acc aenv as-           ->       acc aenv bs-           -> Embed acc aenv cs-    embed2 = trav2 id id--    lift :: (Arrays as, Arrays bs)-         => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs)-         ->       acc aenv as-         -> Embed acc aenv bs-    lift = trav1 bind--    lift2 :: forall aenv as bs cs. (Arrays as, Arrays bs, Arrays cs)-          => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs)-          ->       acc aenv as-          ->       acc aenv bs-          -> Embed acc aenv cs-    lift2 = trav2 bind bind--    trav1 :: (Arrays as, Arrays bs)-          => (forall aenv'. Embed acc aenv' as -> Embed acc aenv' as)-          -> (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs)-          ->       acc aenv as-          -> Embed acc aenv bs-    trav1 f op (f . embedAcc -> Embed env cc)-      = Embed (env `PushEnv` inject (op env (inject (compute' cc)))) (Done ZeroIdx)--    trav2 :: forall aenv as bs cs. (Arrays as, Arrays bs, Arrays cs)-          => (forall aenv'. Embed acc aenv' as -> Embed acc aenv' as)-          -> (forall aenv'. Embed acc aenv' bs -> Embed acc aenv' bs)-          -> (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs)-          ->       acc aenv as-          ->       acc aenv bs-          -> Embed acc aenv cs-    trav2 f1 f0 op (f1 . embedAcc -> Embed env1 cc1) (f0 . embedAcc . sink env1 -> Embed env0 cc0)-      | env     <- env1 `append` env0-      , acc1    <- inject . compute' $ sink env0 cc1-      , acc0    <- inject . compute' $ cc0-      = Embed (env `PushEnv` inject (op env acc1 acc0)) (Done ZeroIdx)--    -- Helper functions to lift out and let-bind a manifest array. That is,-    -- instead of the sequence-    ---    -- > stencil s (map f a)-    ---    -- we get:-    ---    -- > let a' = map f a-    -- > in  stencil s a'-    ---    -- This is required for the LLVM backend's default implementation of-    -- stencil operations.-    ---    bind :: Arrays as => Embed acc aenv' as -> Embed acc aenv' as-    bind (Embed env cc)-      | Done{} <- cc = Embed env                                  cc-      | otherwise    = Embed (env `PushEnv` inject (compute' cc)) (Done ZeroIdx)--    -- -- Move additional bindings for producers outside of the sequence, so that-    -- -- producers may fuse with their arguments resulting in actual sequencing-    -- collectD :: PreOpenSeq acc aenv () arrs-    --          -> Embed acc aenv arrs-    -- collectD (embedSeq embedAcc -> ExtendSeq env s')-    --   = Embed (env `PushEnv` inject (Collect s')) (Done ZeroIdx)---{----- Move additional bindings for producer outside of sequence, so--- that producers may fuse with their arguments, resulting in--- actual sequencing.-embedSeq :: forall acc aenv arrs. Kit acc-         => EmbedAcc acc-         -> PreOpenSeq acc aenv () arrs-         -> ExtendSeq       acc aenv () arrs-embedSeq embedAcc s-  = travS s BaseEnv-  where-    travS :: forall senv aenv' arrs'.-             PreOpenSeq acc aenv senv arrs'-          -> Extend acc aenv aenv'-          -> ExtendSeq acc aenv senv arrs'-    travS s env =-      case s of-        Producer p s-          | ExtendSeq env' s' <- travS s env-          , ExtendProducer env'' p' <- travP p env'-          -> ExtendSeq (env' `append` env'') (Producer p' (sinkSeq env'' s'))-        Consumer c-          | c' <- travC c env-          -> ExtendSeq env (Consumer c')-        Reify ix-          -> ExtendSeq env (Reify ix)--    travP :: forall arrs' aenv' senv.-             Producer acc aenv senv arrs'-          -> Extend acc aenv aenv'-          -> ExtendProducer acc aenv' senv arrs'-    travP (ToSeq slix sh a) env-      | Embed env' cc <- embedAcc (sink env a)-      = ExtendProducer env' (ToSeq slix sh (inject (compute' cc)))-    travP (StreamIn arrs) _          = ExtendProducer BaseEnv (StreamIn arrs)-    travP (MapSeq f x) env           = ExtendProducer BaseEnv (MapSeq (cvtAF (sink env f)) x)-    travP (ChunkedMapSeq f x) env    = ExtendProducer BaseEnv (ChunkedMapSeq (cvtAF (sink env f)) x)-    travP (ZipWithSeq f x y) env     = ExtendProducer BaseEnv (ZipWithSeq (cvtAF (sink env f)) x y)-    travP (ScanSeq f e x) env        = ExtendProducer BaseEnv (ScanSeq (cvtF (sink env f)) (cvtE (sink env e)) x)--    travC :: forall arrs' aenv' senv.-             Consumer acc aenv senv arrs'-          -> Extend acc aenv aenv'-          -> Consumer acc aenv' senv arrs'-    travC (FoldSeq f e x) env = FoldSeq (cvtF (sink env f)) (cvtE (sink env e)) x-    travC (FoldSeqFlatten f a x) env = FoldSeqFlatten (cvtAF (sink env f)) (cvtA (sink env a)) x-    travC (Stuple t) env = Stuple (cvtCT t)-      where-        cvtCT :: Atuple (Consumer acc aenv senv) t -> Atuple (Consumer acc aenv' senv) t-        cvtCT NilAtup        = NilAtup-        cvtCT (SnocAtup t c) = SnocAtup (cvtCT t) (travC c env)--    cvtE :: Elt t => PreExp acc aenv' t -> PreExp acc aenv' t-    cvtE = simplify--    cvtF :: PreFun acc aenv' t -> PreFun acc aenv' t-    cvtF = simplify--    cvtA :: Arrays a => acc aenv' a -> acc aenv' a-    cvtA = computeAcc . embedAcc--    cvtAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f-    cvtAF (Alam  f) = Alam  (cvtAF f)-    cvtAF (Abody a) = Abody (cvtA a)----- A sequence with additional bindings-data ExtendSeq acc aenv senv arrs where-  ExtendSeq :: forall acc aenv aenv' senv arrs.-                Extend acc aenv aenv'-             -> PreOpenSeq acc aenv' senv arrs-             -> ExtendSeq acc aenv senv arrs---- A producer with additional bindings-data ExtendProducer acc aenv senv arrs where-  ExtendProducer :: forall acc aenv aenv' senv arrs.-                    Extend acc aenv aenv'-                 -> Producer acc aenv' senv arrs-                 -> ExtendProducer acc aenv senv arrs---}----- Internal representation--- =======================---- Note: [Representing delayed array]------ During the fusion transformation we represent terms as a pair consisting of--- a collection of supplementary environment bindings and a description of how--- to construct the array.------ It is critical to separate these two. To create a real AST node we need both--- the environment and array term, but analysis of how to fuse terms requires--- only the array description. If the additional bindings are bundled as part of--- the representation, the existentially quantified extended environment type--- will be untouchable. This is problematic because the terms of the two arrays--- are defined with respect to this existentially quantified type, and there is--- no way to directly combine these two environments:------   append :: Extend env env1 -> Extend env env2 -> Extend env ???------ And hence, no way to combine the terms of the delayed representation.------ The only way to bring terms into the same scope is to operate via the--- manifest terms. This entails a great deal of conversion between delayed and--- AST terms, but is certainly possible.------ However, because of the limited scope into which this existential type is--- available, we ultimately perform this process many times. In fact, complexity--- of the fusion algorithm for an AST of N terms becomes O(r^n), where r is the--- number of different rules we have for combining terms.----data Embed acc aenv a where-  Embed :: Extend     acc aenv aenv'-        -> Cunctation acc      aenv' a-        -> Embed      acc aenv       a----- Cunctation (n): the action or an instance of delaying; a tardy action.------ This describes the ways in which the fusion transformation represents--- intermediate arrays. The fusion process operates by recasting producer array--- computations in terms of a set of scalar functions used to construct an--- element at each index, and fusing successive producers by combining these--- scalar functions.----data Cunctation acc aenv a where--  -- The base case is just a real (manifest) array term. No fusion happens here.-  -- Note that the array is referenced by an index into the extended-  -- environment, ensuring that the array is manifest and making the term-  -- non-recursive in 'acc'. Also note that the return type is a general-  -- instance of Arrays and not restricted to a single Array.-  ---  Done  :: Arrays a-        => Idx            aenv a-        -> Cunctation acc aenv a--  -- We can represent an array by its shape and a function to compute an element-  -- at each index.-  ---  Yield :: (Shape sh, Elt e)-        => PreExp     acc aenv sh-        -> PreFun     acc aenv (sh -> e)-        -> Cunctation acc aenv (Array sh e)--  -- A more restrictive form than 'Yield' may afford greater opportunities for-  -- optimisation by a backend. This more structured form applies an index and-  -- value transform to an input array. Note that the transform is applied to an-  -- array stored as an environment index, so that the term is non-recursive and-  -- it is always possible to embed into a collective operation.-  ---  Step  :: (Shape sh, Shape sh', Elt a, Elt b)-        => PreExp     acc aenv sh'-        -> PreFun     acc aenv (sh' -> sh)-        -> PreFun     acc aenv (a   -> b)-        -> Idx            aenv (Array sh  a)-        -> Cunctation acc aenv (Array sh' b)---instance Kit acc => Simplify (Cunctation acc aenv a) where-  simplify (Done v)        = Done v-  simplify (Yield sh f)    = Yield (simplify sh) (simplify f)-  simplify (Step sh p f v) = Step (simplify sh) (simplify p) (simplify f) v----- Convert a real AST node into the internal representation----done :: (Arrays a, Kit acc) => PreOpenAcc acc aenv a -> Embed acc aenv a-done pacc-  | Avar v <- pacc      = Embed BaseEnv                         (Done v)-  | otherwise           = Embed (BaseEnv `PushEnv` inject pacc) (Done ZeroIdx)----- Recast a cunctation into a mapping from indices to elements.----yield :: Kit acc-      => Cunctation acc aenv (Array sh e)-      -> Cunctation acc aenv (Array sh e)-yield cc =-  case cc of-    Yield{}                             -> cc-    Step sh p f v                       -> Yield sh (f `compose` indexArray v `compose` p)-    Done v-      | ArraysRarray <- accType cc      -> Yield (arrayShape v) (indexArray v)-      | otherwise                       -> error "yield: impossible case"----- Recast a cunctation into transformation step form. Not possible if the source--- was in the Yield formulation.----step :: Kit acc-     => Cunctation acc aenv (Array sh e)-     -> Maybe (Cunctation acc aenv (Array sh e))-step cc =-  case cc of-    Yield{}                             -> Nothing-    Step{}                              -> Just cc-    Done v-      | ArraysRarray <- accType cc      -> Just $ Step (arrayShape v) identity identity v-      | otherwise                       -> error "step: impossible case"----- Get the shape of a delayed array----shape :: Kit acc => Cunctation acc aenv (Array sh e) -> PreExp acc aenv sh-shape cc-  | Just (Step sh _ _ _) <- step cc     = sh-  | Yield sh _           <- yield cc    = sh----- Reified type of a delayed array representation.----accType :: forall acc aenv a. Arrays a => Cunctation acc aenv a -> ArraysR (ArrRepr a)-accType _ = arrays (undefined :: a)----- Environment manipulation--- ========================--instance Kit acc => Sink (Cunctation acc) where-  weaken k cc = case cc of-    Done v              -> Done (weaken k v)-    Step sh p f v       -> Step (weaken k sh) (weaken k p) (weaken k f) (weaken k v)-    Yield sh f          -> Yield (weaken k sh) (weaken k f)---- prjExtend :: Kit acc => Extend acc env env' -> Idx env' t -> PreOpenAcc acc env' t--- prjExtend (PushEnv _   v) ZeroIdx       = weakenA rebuildAcc SuccIdx v--- prjExtend (PushEnv env _) (SuccIdx idx) = weakenA rebuildAcc SuccIdx $ prjExtend env idx--- prjExtend _               _             = $internalError "prjExtend" "inconsistent valuation"--{----- Rearrange type arguments to fit with Sink type class.-newtype SinkSeq acc senv aenv a = SinkSeq { unSinkSeq :: PreOpenSeq acc aenv senv a }---- sink for sequences.-sinkSeq :: Kit acc => Extend acc aenv aenv' -> PreOpenSeq acc aenv senv a -> PreOpenSeq acc aenv' senv a-sinkSeq env s = unSinkSeq $ sink env (SinkSeq s)--instance Kit acc => Sink (SinkSeq acc senv) where-  weaken :: forall aenv aenv' arrs. aenv :> aenv' -> SinkSeq acc senv aenv arrs -> SinkSeq acc senv aenv' arrs-  weaken k (SinkSeq s) = SinkSeq $-    case s of-      Producer p s' -> Producer   (weakenP p) (weakenL s')-      Consumer c    -> Consumer   (weakenC c)-      Reify ix      -> Reify      ix--    where-      weakenL :: forall senv' arrs'. PreOpenSeq acc aenv senv' arrs' -> PreOpenSeq acc aenv' senv' arrs'-      weakenL s' = unSinkSeq (weaken k (SinkSeq s'))--      weakenP :: forall a. Producer acc aenv senv a -> Producer acc aenv' senv a-      weakenP p =-        case p of-          StreamIn arrs        -> StreamIn arrs-          ToSeq slix sh a      -> ToSeq slix sh (weaken k a)-          MapSeq f x           -> MapSeq (weaken k f) x-          ChunkedMapSeq f x    -> ChunkedMapSeq (weaken k f) x-          ZipWithSeq f x y     -> ZipWithSeq (weaken k f) x y-          ScanSeq f a x        -> ScanSeq (weaken k f) (weaken k a) x--      weakenC :: forall a. Consumer acc aenv senv a -> Consumer acc aenv' senv a-      weakenC c =-        case c of-          FoldSeq f a x        -> FoldSeq (weaken k f) (weaken k a) x-          FoldSeqFlatten f a x -> FoldSeqFlatten (weaken k f) (weaken k a) x-          Stuple t             ->-            let wk :: Atuple (Consumer acc aenv senv) t -> Atuple (Consumer acc aenv' senv) t-                wk NilAtup        = NilAtup-                wk (SnocAtup t c) = wk t `SnocAtup` weakenC c-            in-            Stuple (wk t)---}---- Array fusion of a de Bruijn computation AST--- ===========================================---- Array computations--- ---------------------- Recast the internal representation of delayed arrays into a real AST node.--- Use the most specific version of a combinator whenever possible.----compute :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> PreOpenAcc acc aenv arrs-compute (Embed env cc) = bind env (compute' cc)--compute' :: (Kit acc, Arrays arrs) => Cunctation acc aenv arrs -> PreOpenAcc acc aenv arrs-compute' cc = case simplify cc of-  Done v                                              -> Avar v-  Yield sh f                                          -> Generate sh f-  Step sh p f v-    | Just Refl <- match sh (simplify (arrayShape v))-    , Just Refl <- isIdentity p-    , Just Refl <- isIdentity f                       -> Avar v-    | Just Refl <- match sh (simplify (arrayShape v))-    , Just Refl <- isIdentity p                       -> Map f (avarIn v)-    | Just Refl <- isIdentity f                       -> Backpermute sh p (avarIn v)-    | otherwise                                       -> Transform sh p f (avarIn v)----- Evaluate a delayed computation and tie the recursive knot----computeAcc :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> acc aenv arrs-computeAcc = inject . compute----- Representation of a generator as a delayed array----generateD :: (Shape sh, Elt e)-          => PreExp acc aenv sh-          -> PreFun acc aenv (sh -> e)-          -> Embed  acc aenv (Array sh e)-generateD sh f-  = Stats.ruleFired "generateD"-  $ Embed BaseEnv (Yield sh f)----- Fuse a unary function into a delayed array. Also looks for unzips which can--- be executed in constant time; SEE [unzipD]----mapD :: (Kit acc, Shape sh, Elt b)-     => PreFun acc aenv (a -> b)-     -> Embed  acc aenv (Array sh a)-     -> Embed  acc aenv (Array sh b)-mapD f (unzipD f -> Just a) = a-mapD f (Embed env cc)-  = Stats.ruleFired "mapD"-  $ Embed env (go cc)-  where-    go (step  -> Just (Step sh ix g v)) = Step sh ix (sink env f `compose` g) v-    go (yield -> Yield sh g)            = Yield sh (sink env f `compose` g)----- If we are unzipping a manifest array then force the term to be computed;--- a backend will be able to execute this in constant time. This operations--- looks for the right terms recursively, splitting operations such as:------ > map (\x -> fst . fst ... x) arr------ into multiple stages so that they can all be executed in constant time:------ > map fst . map fst ... arr------ Note that this is a speculative operation, since we could dig under several--- levels of projection before discovering that the operation can not be--- unzipped. This should be fine though because digging through the terms is--- relatively cheap; no environment changing operations are required.----unzipD-    :: (Kit acc, Shape sh, Elt b)-    => PreFun acc aenv (a -> b)-    -> Embed  acc aenv (Array sh a)-    -> Maybe (Embed acc aenv (Array sh b))-unzipD f (Embed env (Done v))-  | Lam (Body (Prj tix (Var ZeroIdx))) <- f-  = Stats.ruleFired "unzipD"-  $ let f' = Lam (Body (Prj tix (Var ZeroIdx)))-        a' = avarIn v-    in-    Just $ Embed (env `PushEnv` inject (Map f' a')) (Done ZeroIdx)--  | Lam (Body (Prj tix p@Prj{}))       <- f-  , Just (Embed env' (Done v'))        <- unzipD (Lam (Body p)) (Embed env (Done v))-  = Stats.ruleFired "unzipD"-  $ let f' = Lam (Body (Prj tix (Var ZeroIdx)))-        a' = avarIn v'-    in-    Just $ Embed (env' `PushEnv` inject (Map f' a')) (Done ZeroIdx)--unzipD _ _-  = Nothing----- Fuse an index space transformation function that specifies where elements in--- the destination array read there data from in the source array.----backpermuteD-    :: (Kit acc, Shape sh')-    => PreExp     acc aenv sh'-    -> PreFun     acc aenv (sh' -> sh)-    -> Cunctation acc aenv (Array sh  e)-    -> Cunctation acc aenv (Array sh' e)-backpermuteD sh' p = Stats.ruleFired "backpermuteD" . go-  where-    go (step  -> Just (Step _ q f v)) = Step sh' (q `compose` p) f v-    go (yield -> Yield _ g)           = Yield sh' (g `compose` p)----- Transform as a combined map and backwards permutation----transformD-    :: (Kit acc, Shape sh, Shape sh', Elt b)-    => PreExp acc aenv sh'-    -> PreFun acc aenv (sh' -> sh)-    -> PreFun acc aenv (a   -> b)-    -> Embed  acc aenv (Array sh  a)-    -> Embed  acc aenv (Array sh' b)-transformD sh' p f-  = Stats.ruleFired "transformD"-  . fuse (into2 backpermuteD sh' p)-  . mapD f-  where-    fuse :: (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs)-         -> Embed acc aenv as-         -> Embed acc aenv bs-    fuse op (Embed env cc) = Embed env (op env cc)--    into2 :: (Sink f1, Sink f2)-          => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b -> Extend acc env env' -> c-    into2 op a b env = op (sink env a) (sink env b)----- Replicate as a backwards permutation------ TODO: If we have a pattern such as `replicate sh (map f xs)` then in some---       cases it might be beneficial to not fuse these terms, if `f` is---       expensive and/or `sh` is large.----replicateD-    :: (Kit acc, Shape sh, Shape sl, Elt slix)-    => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-    -> PreExp     acc aenv slix-    -> Cunctation acc aenv (Array sl e)-    -> Cunctation acc aenv (Array sh e)-replicateD sliceIndex slix cc-  = Stats.ruleFired "replicateD"-  $ backpermuteD (IndexFull sliceIndex slix (shape cc)) (extend sliceIndex slix) cc----- Dimensional slice as a backwards permutation----sliceD-    :: (Kit acc, Shape sh, Shape sl, Elt slix)-    => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-    -> PreExp     acc aenv slix-    -> Cunctation acc aenv (Array sh e)-    -> Cunctation acc aenv (Array sl e)-sliceD sliceIndex slix cc-  = Stats.ruleFired "sliceD"-  $ backpermuteD (IndexSlice sliceIndex slix (shape cc)) (restrict sliceIndex slix) cc----- Reshape an array------ For delayed arrays this is implemented as an index space transformation. For--- manifest arrays this can be done with the standard Reshape operation in--- constant time without executing any array operations. This does not affect--- the fusion process since the term is already manifest.------ TLM: there was a runtime check to ensure the old and new shapes contained the---      same number of elements: this has been lost for the delayed cases!----reshapeD-    :: (Kit acc, Shape sh, Shape sl, Elt e)-    => Embed  acc aenv (Array sh e)-    -> PreExp acc aenv sl-    -> Embed  acc aenv (Array sl e)-reshapeD (Embed env cc) (sink env -> sl)-  | Done v      <- cc-  = Embed (env `PushEnv` inject (Reshape sl (avarIn v))) (Done ZeroIdx)--  | otherwise-  = Stats.ruleFired "reshapeD"-  $ Embed env (backpermuteD sl (reindex (shape cc) sl) cc)----- Combine two arrays element-wise with a binary function to produce a delayed--- array.----zipWithD :: (Kit acc, Shape sh, Elt a, Elt b, Elt c)-         => PreFun     acc aenv (a -> b -> c)-         -> Cunctation acc aenv (Array sh a)-         -> Cunctation acc aenv (Array sh b)-         -> Cunctation acc aenv (Array sh c)-zipWithD f cc1 cc0-  -- Two stepper functions identically accessing the same array can be kept in-  -- stepping form. This might yield a simpler final term.-  ---  | Just (Step sh1 p1 f1 v1)    <- step cc1-  , Just (Step sh0 p0 f0 v0)    <- step cc0-  , Just Refl                   <- match v1 v0-  , Just Refl                   <- match p1 p0-  = Stats.ruleFired "zipWithD/step"-  $ Step (sh1 `Intersect` sh0) p0 (combine f f1 f0) v0--  -- Otherwise transform both delayed terms into (index -> value) mappings and-  -- combine the two indexing functions that way.-  ---  | Yield sh1 f1                <- yield cc1-  , Yield sh0 f0                <- yield cc0-  = Stats.ruleFired "zipWithD"-  $ Yield (sh1 `Intersect` sh0) (combine f f1 f0)--  where-    combine :: forall acc aenv a b c e. (Kit acc, Elt a, Elt b, Elt c)-            => PreFun acc aenv (a -> b -> c)-            -> PreFun acc aenv (e -> a)-            -> PreFun acc aenv (e -> b)-            -> PreFun acc aenv (e -> c)-    combine c ixa ixb-      | Lam (Lam (Body c'))     <- weakenE SuccIdx c   :: PreOpenFun acc ((),e) aenv (a -> b -> c)-      , Lam (Body ixa')         <- ixa                          -- else the skolem 'e' will escape-      , Lam (Body ixb')         <- ixb-      = Lam $ Body $ Let ixa' $ Let (weakenE SuccIdx ixb') c'----- NOTE: [Sharing vs. Fusion]------ The approach to array fusion is similar to that the first generation of Repa.--- It was discovered that the most immediately pressing problem with delayed--- arrays in Repa-1 was that it did not preserve sharing of collective--- operations, leading to excessive recomputation and severe repercussions on--- performance if the user did not explicitly intervene.------ However, as we have explicit sharing information in the term tree, so it is--- straightforward to respect sharing by not fusing let-bindings, as that--- introduces work duplication. However, sometimes we can be cleverer.------ let-floating:--- ------------------- If the binding is of manifest data, we can instead move the let-binding to a--- different point in the program and then continue to fuse into the body. This--- is done by adding the bound term to the Extend environment. In essence this--- is covering a different occurrence of the same problem Extend was introduced--- to handle: let bindings of manifest data unnecessarily get in the way of the--- fusion process. For example:------   map f (zipWith g xs (map h xs))------ after sharing recovery results in:------   map f (let a0 = xs in zipWith g a0 (map h a0))------ Without allowing the binding for a0 to float outwards, `map f` will not be--- fused into the rest of the program.------ let-elimination:--- ---------------------- Array binding points appear in the program because the array data _or_ shape--- was accessed multiple times in the source program. In general we want to fuse--- arbitrary sequences of array _data_, irrespective of how the shape component--- is used. For example, reverse is defined in the prelude as:------   reverse xs = let len   = unindex1 (shape xs)---                    pf i  = len - i - 1---                in---                backpermute (shape xs) (ilift1 pf) xs------ Sharing recovery introduces a let-binding for the input `xs` since it is used--- thrice in the definition, which impedes subsequent fusion. However the actual--- array data is only accessed once, with the remaining two uses querying the--- array shape. Since the delayed terms contain the shape of the array they--- represent as a scalar term, if the data component otherwise satisfies the--- rules for fusing terms, as it does in this example, we can eliminate the--- let-binding by pushing the scalar shape and value generation terms directly--- into the body.------ Let-elimination can also be used to _introduce_ work duplication, which may--- be beneficial if we can estimate that the cost of recomputation is less than--- the cost of completely evaluating the array and subsequently retrieving the--- data from memory.------ let-binding:--- ------------------ Ultimately, we might not want to eliminate the binding. If so, evaluate it--- and add it to a _clean_ Extend environment for the body. If not, the Extend--- list effectively _flattens_ all bindings, so any terms required for the bound--- term get lifted out to the same scope as the body. This increases their--- lifetime and hence raises the maximum memory used. If we don't do this, we--- get terms such as:------   let a0  = <terms for binding> in---   let bnd = <bound term> in---   <body term>------ rather than the following, where the scope of a0 is clearly only availably--- when evaluating the bound term, as it should be:------   let bnd =---     let a0 = <terms for binding>---     in <bound term>---   in <body term>----aletD :: (Kit acc, Arrays arrs, Arrays brrs)-      => EmbedAcc acc-      -> ElimAcc  acc-      ->          acc aenv        arrs-      ->          acc (aenv,arrs) brrs-      -> Embed    acc aenv        brrs-aletD embedAcc elimAcc (embedAcc -> Embed env1 cc1) acc0--  -- let-floating-  -- -------------  ---  -- Immediately inline the variable referring to the bound expression into the-  -- body, instead of adding to the environments and creating an indirection-  -- that must be later eliminated by shrinking.-  ---  | Done v1             <- cc1-  , Embed env0 cc0      <- embedAcc $ rebuildA (subAtop (Avar v1) . sink1 env1) acc0-  = Stats.ruleFired "aletD/float"-  $ Embed (env1 `append` env0) cc0--  -- Ensure we only call 'embedAcc' once on the body expression-  ---  | otherwise-  = aletD' embedAcc elimAcc (Embed env1 cc1) (embedAcc acc0)---aletD' :: forall acc aenv arrs brrs. (Kit acc, Arrays arrs, Arrays brrs)-       => EmbedAcc acc-       -> ElimAcc  acc-       -> Embed    acc aenv         arrs-       -> Embed    acc (aenv, arrs) brrs-       -> Embed    acc aenv         brrs-aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0)--  -- let-binding-  -- ------------  ---  -- Check whether we can eliminate the let-binding. Note that we must inspect-  -- the entire term, not just the Cunctation that would be produced by-  -- embedAcc. If we don't we can be left with dead terms that don't get-  -- eliminated. This problem occurred in the canny program.-  ---  | acc1                <- compute (Embed env1 cc1)-  , False               <- elimAcc (inject acc1) acc0-  = Stats.ruleFired "aletD/bind"-  $ Embed (BaseEnv `PushEnv` inject acc1 `append` env0) cc0--  -- let-elimination-  -- ----------------  ---  -- Handle the remaining cases in a separate function. It turns out that this-  -- is important so we aren't excessively sinking/delaying terms.-  ---  | acc0'               <- sink1 env1 acc0-  = Stats.ruleFired "aletD/eliminate"-  $ case cc1 of-      Step{}    -> eliminate env1 cc1 acc0'-      Yield{}   -> eliminate env1 cc1 acc0'--  where-    acc0 :: acc (aenv, arrs) brrs-    acc0 = computeAcc (Embed env0 cc0)--    -- The second part of let-elimination. Splitting into two steps exposes the-    -- extra type variables, and ensures we don't do extra work manipulating the-    -- body when not necessary (which can lead to a complexity blowup).-    ---    eliminate :: forall aenv aenv' sh e brrs. (Shape sh, Elt e, Arrays brrs)-              => Extend     acc aenv aenv'-              -> Cunctation acc      aenv' (Array sh e)-              ->            acc     (aenv', Array sh e) brrs-              -> Embed      acc aenv                    brrs-    eliminate env1 cc1 body-      | Done v1           <- cc1 = elim (arrayShape v1) (indexArray v1)-      | Step sh1 p1 f1 v1 <- cc1 = elim sh1 (f1 `compose` indexArray v1 `compose` p1)-      | Yield sh1 f1      <- cc1 = elim sh1 f1-      where-        bnd :: PreOpenAcc acc aenv' (Array sh e)-        bnd = compute' cc1--        elim :: PreExp acc aenv' sh -> PreFun acc aenv' (sh -> e) -> Embed acc aenv brrs-        elim sh1 f1-          | sh1'                <- weaken SuccIdx sh1-          , f1'                 <- weaken SuccIdx f1-          , Embed env0' cc0'    <- embedAcc $ rebuildA (subAtop bnd) $ kmap (replaceA sh1' f1' ZeroIdx) body-          = Embed (env1 `append` env0') cc0'--    -- As part of let-elimination, we need to replace uses of array variables in-    -- scalar expressions with an equivalent expression that generates the-    -- result directly-    ---    -- TODO: when we inline bindings we ought to let bind at the first-    --       occurrence and use a variable at all subsequent locations. At the-    --       moment we are just hoping CSE in the simplifier phase does good-    --       things, but that is limited in what it looks for.-    ---    replaceE :: forall env aenv sh e t. (Shape sh, Elt e)-             => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> Idx aenv (Array sh e)-             -> PreOpenExp acc env aenv t-             -> PreOpenExp acc env aenv t-    replaceE sh' f' avar exp =-      case exp of-        Let x y                         -> Let (cvtE x) (replaceE (weakenE SuccIdx sh') (weakenE SuccIdx f') avar y)-        Var i                           -> Var i-        Foreign ff f e                  -> Foreign ff f (cvtE e)-        Const c                         -> Const c-        Tuple t                         -> Tuple (cvtT t)-        Prj ix e                        -> Prj ix (cvtE e)-        IndexNil                        -> IndexNil-        IndexCons sl sz                 -> IndexCons (cvtE sl) (cvtE sz)-        IndexHead sh                    -> IndexHead (cvtE sh)-        IndexTail sz                    -> IndexTail (cvtE sz)-        IndexAny                        -> IndexAny-        IndexSlice x ix sh              -> IndexSlice x (cvtE ix) (cvtE sh)-        IndexFull x ix sl               -> IndexFull x (cvtE ix) (cvtE sl)-        ToIndex sh ix                   -> ToIndex (cvtE sh) (cvtE ix)-        FromIndex sh i                  -> FromIndex (cvtE sh) (cvtE i)-        Cond p t e                      -> Cond (cvtE p) (cvtE t) (cvtE e)-        PrimConst c                     -> PrimConst c-        PrimApp g x                     -> PrimApp g (cvtE x)-        ShapeSize sh                    -> ShapeSize (cvtE sh)-        Intersect sh sl                 -> Intersect (cvtE sh) (cvtE sl)-        Union s t                       -> Union (cvtE s) (cvtE t)-        While p f x                     -> While (replaceF sh' f' avar p) (replaceF sh' f' avar f) (cvtE x)--        Shape a-          | Just Refl <- match a a'     -> Stats.substitution "replaceE/shape" sh'-          | otherwise                   -> exp--        Index a sh-          | Just Refl    <- match a a'-          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!" . cvtE $ Let sh b-          | otherwise                   -> Index a (cvtE sh)--        LinearIndex a i-          | Just Refl    <- match a a'-          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!!" . cvtE $ Let (Let i (FromIndex (weakenE SuccIdx sh') (Var ZeroIdx))) b-          | otherwise                   -> LinearIndex a (cvtE i)--      where-        a' :: acc aenv (Array sh e)-        a' = avarIn avar--        cvtE :: PreOpenExp acc env aenv s -> PreOpenExp acc env aenv s-        cvtE = replaceE sh' f' avar--        cvtT :: Tuple (PreOpenExp acc env aenv) s -> Tuple (PreOpenExp acc env aenv) s-        cvtT NilTup        = NilTup-        cvtT (SnocTup t e) = cvtT t `SnocTup` cvtE e--    replaceF :: forall env aenv sh e t. (Shape sh, Elt e)-             => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> Idx aenv (Array sh e)-             -> PreOpenFun acc env aenv t-             -> PreOpenFun acc env aenv t-    replaceF sh' f' avar fun =-      case fun of-        Body e          -> Body (replaceE sh' f' avar e)-        Lam f           -> Lam  (replaceF (weakenE SuccIdx sh') (weakenE SuccIdx f') avar f)--    replaceA :: forall aenv sh e a. (Shape sh, Elt e)-             => PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> Idx aenv (Array sh e)-             -> PreOpenAcc acc aenv a-             -> PreOpenAcc acc aenv a-    replaceA sh' f' avar pacc =-      case pacc of-        Avar v-          | Just Refl <- match v avar   -> Avar avar-          | otherwise                   -> Avar v--        Alet bnd body                   ->-          let sh'' = weaken SuccIdx sh'-              f''  = weaken SuccIdx f'-          in-          Alet (cvtA bnd) (kmap (replaceA sh'' f'' (SuccIdx avar)) body)--        Use arrs                -> Use arrs-        Unit e                  -> Unit (cvtE e)-        Acond p at ae           -> Acond (cvtE p) (cvtA at) (cvtA ae)-        Aprj ix tup             -> Aprj ix (cvtA tup)-        Atuple tup              -> Atuple (cvtAT tup)-        Awhile p f a            -> Awhile (cvtAF p) (cvtAF f) (cvtA a)-        Apply f a               -> Apply (cvtAF f) (cvtA a)-        Aforeign ff f a         -> Aforeign ff f (cvtA a)       -- no sharing between f and a-        Generate sh f           -> Generate (cvtE sh) (cvtF f)-        Map f a                 -> Map (cvtF f) (cvtA a)-        ZipWith f a b           -> ZipWith (cvtF f) (cvtA a) (cvtA b)-        Backpermute sh p a      -> Backpermute (cvtE sh) (cvtF p) (cvtA a)-        Transform sh p f a      -> Transform (cvtE sh) (cvtF p) (cvtF f) (cvtA a)-        Slice slix a sl         -> Slice slix (cvtA a) (cvtE sl)-        Replicate slix sh a     -> Replicate slix (cvtE sh) (cvtA a)-        Reshape sl a            -> Reshape (cvtE sl) (cvtA a)-        Fold f z a              -> Fold (cvtF f) (cvtE z) (cvtA a)-        Fold1 f a               -> Fold1 (cvtF f) (cvtA a)-        FoldSeg f z a s         -> FoldSeg (cvtF f) (cvtE z) (cvtA a) (cvtA s)-        Fold1Seg f a s          -> Fold1Seg (cvtF f) (cvtA a) (cvtA s)-        Scanl f z a             -> Scanl (cvtF f) (cvtE z) (cvtA a)-        Scanl1 f a              -> Scanl1 (cvtF f) (cvtA a)-        Scanl' f z a            -> Scanl' (cvtF f) (cvtE z) (cvtA a)-        Scanr f z a             -> Scanr (cvtF f) (cvtE z) (cvtA a)-        Scanr1 f a              -> Scanr1 (cvtF f) (cvtA a)-        Scanr' f z a            -> Scanr' (cvtF f) (cvtE z) (cvtA a)-        Permute f d p a         -> Permute (cvtF f) (cvtA d) (cvtF p) (cvtA a)-        Stencil f x a           -> Stencil (cvtF f) (cvtB x) (cvtA a)-        Stencil2 f x a y b      -> Stencil2 (cvtF f) (cvtB x) (cvtA a) (cvtB y) (cvtA b)-        -- Collect seq             -> Collect (cvtSeq seq)--      where-        cvtA :: acc aenv s -> acc aenv s-        cvtA = kmap (replaceA sh' f' avar)--        cvtE :: PreExp acc aenv s -> PreExp acc aenv s-        cvtE = replaceE sh' f' avar--        cvtF :: PreFun acc aenv s -> PreFun acc aenv s-        cvtF = replaceF sh' f' avar--        cvtB :: PreBoundary acc aenv s -> PreBoundary acc aenv s-        cvtB Clamp        = Clamp-        cvtB Mirror       = Mirror-        cvtB Wrap         = Wrap-        cvtB (Constant c) = Constant c-        cvtB (Function f) = Function (cvtF f)--        cvtAT :: Atuple (acc aenv) s -> Atuple (acc aenv) s-        cvtAT NilAtup          = NilAtup-        cvtAT (SnocAtup tup a) = cvtAT tup `SnocAtup` cvtA a--        cvtAF :: PreOpenAfun acc aenv s -> PreOpenAfun acc aenv s-        cvtAF = cvt sh' f' avar-          where-            cvt :: forall aenv a.-                   PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> Idx aenv (Array sh e)-                -> PreOpenAfun acc aenv a-                -> PreOpenAfun acc aenv a-            cvt sh'' f'' avar' (Abody a) = Abody $ kmap (replaceA sh'' f'' avar') a-            cvt sh'' f'' avar' (Alam af) = Alam  $ cvt (weaken SuccIdx sh'')-                                                       (weaken SuccIdx f'')-                                                       (SuccIdx avar')-                                                       af--{---        cvtSeq :: PreOpenSeq acc aenv senv s -> PreOpenSeq acc aenv senv s-        cvtSeq s =-          case s of-            Producer p s' ->-              Producer-                (case p of-                   StreamIn arrs        -> StreamIn arrs-                   ToSeq slix sh a      -> ToSeq slix sh (cvtA a)-                   MapSeq f x           -> MapSeq (cvtAF f) x-                   ChunkedMapSeq f x    -> ChunkedMapSeq (cvtAF f) x-                   ZipWithSeq f x y     -> ZipWithSeq (cvtAF f) x y-                   ScanSeq f e x        -> ScanSeq (cvtF f) (cvtE e) x)-                (cvtSeq s')-            Consumer c ->-              Consumer (cvtC c)-            Reify ix -> Reify ix--        cvtC :: Consumer acc aenv senv s -> Consumer acc aenv senv s-        cvtC c =-          case c of-            FoldSeq f e x        -> FoldSeq (cvtF f) (cvtE e) x-            FoldSeqFlatten f a x -> FoldSeqFlatten (cvtAF f) (cvtA a) x-            Stuple t             -> Stuple (cvtCT t)--        cvtCT :: Atuple (Consumer acc aenv senv) t -> Atuple (Consumer acc aenv senv) t-        cvtCT NilAtup        = NilAtup-        cvtCT (SnocAtup t c) = cvtCT t `SnocAtup` cvtC c---}----- The apply operator, or (>->) in the surface language. This eliminates--- redundant application to an identity function, instead lifting the argument--- to a let-binding. This case arises in the use of pipe to avoid fusion and--- force its argument to be evaluated, e.g.:------ > compute :: Acc a -> Acc a--- > compute = id >-> id----applyD :: (Kit acc, Arrays as, Arrays bs)-       => PreOpenAfun acc aenv (as -> bs)-       ->             acc aenv as-       -> Embed       acc aenv bs-applyD afun x-  | Alam (Abody body)   <- afun-  , Avar ZeroIdx        <- extract body-  = Stats.ruleFired "applyD/identity"-  $ done $ extract x--  | otherwise-  = done $ Apply afun x----- Array conditionals, in particular eliminate branches when the predicate--- reduces to a known constant.------ Note that we take the raw unprocessed terms as input. If instead we had the--- terms for each branch in the delayed representation, this would require that--- each term has been sunk into a common environment, which implies the--- conditional has been pushed underneath the intersection of bound terms for--- both branches. This would result in redundant work processing the bindings--- for the branch not taken.----acondD :: (Kit acc, Arrays arrs)-       => EmbedAcc acc-       -> PreExp   acc aenv Bool-       ->          acc aenv arrs-       ->          acc aenv arrs-       -> Embed    acc aenv arrs-acondD embedAcc p t e-  | Const True  <- p        = Stats.knownBranch "True"      $ embedAcc t-  | Const False <- p        = Stats.knownBranch "False"     $ embedAcc e-  | Just Refl <- match t e  = Stats.knownBranch "redundant" $ embedAcc e-  | otherwise               = done $ Acond p (computeAcc (embedAcc t))-                                             (computeAcc (embedAcc e))----- Array tuple projection. Whenever possible we want to peek underneath the--- tuple structure and continue the fusion process.----aprjD :: forall acc aenv arrs a. (Kit acc, IsAtuple arrs, Arrays arrs, Arrays a)-      => EmbedAcc acc-      -> TupleIdx (TupleRepr arrs) a-      ->       acc aenv arrs-      -> Embed acc aenv a-aprjD embedAcc ix a-  | Atuple tup <- extract a = Stats.ruleFired "aprj/Atuple" . embedAcc $ aprjAT ix tup-  | otherwise               = done $ Aprj ix (cvtA a)-  where-    cvtA :: acc aenv arrs -> acc aenv arrs-    cvtA = computeAcc . embedAcc--    aprjAT :: TupleIdx atup a -> Atuple (acc aenv) atup -> acc aenv a-    aprjAT ZeroTupIdx      (SnocAtup _ a) = a-    aprjAT (SuccTupIdx ix) (SnocAtup t _) = aprjAT ix t----- Scalar expressions--- --------------------isIdentity :: PreFun acc aenv (a -> b) -> Maybe (a :~: b)-isIdentity f-  | Lam (Body (Var ZeroIdx)) <- f       = Just Refl-  | otherwise                           = Nothing--identity :: Elt a => PreOpenFun acc env aenv (a -> a)-identity = Lam (Body (Var ZeroIdx))--toIndex :: (Kit acc, Shape sh) => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> Int)-toIndex sh = Lam (Body (ToIndex (weakenE SuccIdx sh) (Var ZeroIdx)))--fromIndex :: (Kit acc, Shape sh) => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (Int -> sh)-fromIndex sh = Lam (Body (FromIndex (weakenE SuccIdx sh) (Var ZeroIdx)))--reindex :: (Kit acc, Shape sh, Shape sh')-        => PreOpenExp acc env aenv sh'-        -> PreOpenExp acc env aenv sh-        -> PreOpenFun acc env aenv (sh -> sh')-reindex sh' sh-  | Just Refl <- match sh sh'   = identity-  | otherwise                   = fromIndex sh' `compose` toIndex sh--extend :: (Kit acc, Shape sh, Shape sl, Elt slix)-       => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-       -> PreExp acc aenv slix-       -> PreFun acc aenv (sh -> sl)-extend sliceIndex slix = Lam (Body (IndexSlice sliceIndex (weakenE SuccIdx slix) (Var ZeroIdx)))--restrict :: (Kit acc, Shape sh, Shape sl, Elt slix)-         => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)-         -> PreExp acc aenv slix-         -> PreFun acc aenv (sl -> sh)-restrict sliceIndex slix = Lam (Body (IndexFull sliceIndex (weakenE SuccIdx slix) (Var ZeroIdx)))--arrayShape :: (Kit acc, Shape sh, Elt e) => Idx aenv (Array sh e) -> PreExp acc aenv sh-arrayShape = Shape . avarIn--indexArray :: (Kit acc, Shape sh, Elt e) => Idx aenv (Array sh e) -> PreFun acc aenv (sh -> e)-indexArray v = Lam (Body (Index (avarIn v) (Var ZeroIdx)))--linearIndex :: (Kit acc, Shape sh, Elt e) => Idx aenv (Array sh e) -> PreFun acc aenv (Int -> e)-linearIndex v = Lam (Body (LinearIndex (avarIn v) (Var ZeroIdx)))-
− Data/Array/Accelerate/Trafo/Rewrite.hs 
@@ -1,152 +0,0 @@-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}--- |--- Module      : Data.Array.Accelerate.Trafo.Rewrite--- 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.Trafo.Rewrite-  where--import Prelude                                          hiding ( seq )---- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Trafo.Substitution-import Data.Array.Accelerate.Array.Sugar                ( Arrays, Segments, Elt, fromElt, Tuple(..), Atuple(..) )----- Convert segment length arrays passed to segmented operations into offset--- index style. This is achieved by wrapping the segmented array argument in a--- left prefix-sum, so you must only ever apply this once.----convertSegments :: OpenAcc aenv a -> OpenAcc aenv a-convertSegments = cvtA-  where-    cvtT :: Atuple (OpenAcc aenv) t -> Atuple (OpenAcc aenv) t-    cvtT atup = case atup of-      NilAtup      -> NilAtup-      SnocAtup t a -> cvtT t `SnocAtup` cvtA a--    cvtAfun :: OpenAfun aenv t -> OpenAfun aenv t-    cvtAfun = convertSegmentsAfun--    cvtE :: Exp aenv t -> Exp aenv t-    cvtE = id--    cvtF :: Fun aenv t -> Fun aenv t-    cvtF = id--    a0 :: Arrays a => OpenAcc (aenv, a) a-    a0 = OpenAcc (Avar ZeroIdx)--    segments :: (Elt i, IsIntegral i) => OpenAcc aenv (Segments i) -> OpenAcc aenv (Segments i)-    segments s = OpenAcc $ Scanl plus zero (cvtA s)--    zero :: forall aenv i. (Elt i, IsIntegral i) => PreOpenExp OpenAcc () aenv i-    zero = Const (fromElt (0::i))--    plus :: (Elt i, IsIntegral i) => PreOpenFun OpenAcc () aenv (i -> i -> i)-    plus = Lam (Lam (Body (PrimAdd numType-                          `PrimApp`-                          Tuple (NilTup `SnocTup` Var (SuccIdx ZeroIdx)-                                        `SnocTup` Var ZeroIdx))))--    cvtA :: OpenAcc aenv a -> OpenAcc aenv a-    cvtA (OpenAcc pacc) = OpenAcc $ case pacc of-      Alet bnd body             -> Alet (cvtA bnd) (cvtA body)-      Avar ix                   -> Avar ix-      Atuple tup                -> Atuple (cvtT tup)-      Aprj tup a                -> Aprj tup (cvtA a)-      Apply f a                 -> Apply (cvtAfun f) (cvtA a)-      Aforeign ff afun acc      -> Aforeign ff (cvtAfun afun) (cvtA acc)-      Acond p t e               -> Acond (cvtE p) (cvtA t) (cvtA e)-      Awhile p f a              -> Awhile (cvtAfun p) (cvtAfun f) (cvtA a)-      Use a                     -> Use a-      Unit e                    -> Unit (cvtE e)-      Reshape e a               -> Reshape (cvtE e) (cvtA a)-      Generate e f              -> Generate (cvtE e) (cvtF f)-      Transform sh ix f a       -> Transform (cvtE sh) (cvtF ix) (cvtF f) (cvtA a)-      Replicate sl slix a       -> Replicate sl (cvtE slix) (cvtA a)-      Slice sl a slix           -> Slice sl (cvtA a) (cvtE slix)-      Map f a                   -> Map (cvtF f) (cvtA a)-      ZipWith f a1 a2           -> ZipWith (cvtF f) (cvtA a1) (cvtA a2)-      Fold f z a                -> Fold (cvtF f) (cvtE z) (cvtA a)-      Fold1 f a                 -> Fold1 (cvtF f) (cvtA a)-      Scanl f z a               -> Scanl (cvtF f) (cvtE z) (cvtA a)-      Scanl' f z a              -> Scanl' (cvtF f) (cvtE z) (cvtA a)-      Scanl1 f a                -> Scanl1 (cvtF f) (cvtA a)-      Scanr f z a               -> Scanr (cvtF f) (cvtE z) (cvtA a)-      Scanr' f z a              -> Scanr' (cvtF f) (cvtE z) (cvtA a)-      Scanr1 f a                -> Scanr1 (cvtF f) (cvtA a)-      Permute f1 a1 f2 a2       -> Permute (cvtF f1) (cvtA a1) (cvtF f2) (cvtA a2)-      Backpermute sh f a        -> Backpermute (cvtE sh) (cvtF f) (cvtA a)-      Stencil f b a             -> Stencil (cvtF f) b (cvtA a)-      Stencil2 f b1 a1 b2 a2    -> Stencil2 (cvtF f) b1 (cvtA a1) b2 (cvtA a2)-      -- Collect s                 -> Collect (convertSegmentsSeq s)--      -- Things we are interested in, whoo!-      FoldSeg f z a s           -> Alet (segments s) (OpenAcc (FoldSeg (cvtF f') (cvtE z') (cvtA a') a0))-        where f' = weaken SuccIdx f-              z' = weaken SuccIdx z-              a' = weaken SuccIdx a--      Fold1Seg f a s            -> Alet (segments s) (OpenAcc (Fold1Seg (cvtF f') (cvtA a') a0))-        where f' = weaken SuccIdx f-              a' = weaken SuccIdx a---convertSegmentsAfun :: OpenAfun aenv t -> OpenAfun aenv t-convertSegmentsAfun afun =-  case afun of-    Abody b     -> Abody (convertSegments b)-    Alam f      -> Alam  (convertSegmentsAfun f)--{---convertSegmentsSeq :: PreOpenSeq OpenAcc aenv senv a -> PreOpenSeq OpenAcc aenv senv a-convertSegmentsSeq seq =-  case seq of-    Producer p s -> Producer (cvtP p) (convertSegmentsSeq s)-    Consumer c   -> Consumer (cvtC c)-    Reify ix     -> Reify ix-  where-    cvtP :: Producer OpenAcc aenv senv a -> Producer OpenAcc aenv senv a-    cvtP p =-      case p of-        StreamIn arrs        -> StreamIn arrs-        ToSeq sl slix a      -> ToSeq sl slix (cvtA a)-        MapSeq f x           -> MapSeq (cvtAfun f) x-        ChunkedMapSeq f x    -> ChunkedMapSeq (cvtAfun f) x-        ZipWithSeq f x y     -> ZipWithSeq (cvtAfun f) x y-        ScanSeq f e x        -> ScanSeq (cvtF f) (cvtE e) x--    cvtC :: Consumer OpenAcc aenv senv a -> Consumer OpenAcc aenv senv a-    cvtC c =-      case c of-        FoldSeq f e x        -> FoldSeq (cvtF f) (cvtE e) x-        FoldSeqFlatten f a x -> FoldSeqFlatten (cvtAfun f) (cvtA a) x-        Stuple t             -> Stuple (cvtCT t)--    cvtCT :: Atuple (Consumer OpenAcc senv aenv) t -> Atuple (Consumer OpenAcc senv aenv) t-    cvtCT NilAtup        = NilAtup-    cvtCT (SnocAtup t c) = SnocAtup (cvtCT t) (cvtC c)--    cvtE :: Exp aenv t -> Exp aenv t-    cvtE = id--    cvtF :: Fun aenv t -> Fun aenv t-    cvtF = id--    cvtA :: OpenAcc aenv t -> OpenAcc aenv t-    cvtA = convertSegments--    cvtAfun :: OpenAfun aenv t -> OpenAfun aenv t-    cvtAfun = convertSegmentsAfun---}-
− Data/Array/Accelerate/Trafo/Sharing.hs 
@@ -1,2919 +0,0 @@-{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE PatternGuards        #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE StandaloneDeriving   #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# OPTIONS_GHC -fno-warn-orphans        #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Trafo.Sharing--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell---               [2013..2017] Robert Clifton-Everest--- License     : BSD3------ Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ This module implements HOAS to de Bruijn conversion of array expressions--- while incorporating sharing information.-----module Data.Array.Accelerate.Trafo.Sharing (--  -- * HOAS -> de Bruijn conversion-  convertAcc, convertAfun, Afunction, AfunctionR,-  convertExp, convertFun,  Function,  FunctionR,-  -- convertSeq--) where---- standard library-import Control.Applicative                              hiding ( Const )-import Control.Monad.Fix-import Data.List-import Data.Maybe-import Data.Hashable-import Data.Typeable-import System.Mem.StableName-import System.IO.Unsafe                                 ( unsafePerformIO )-import qualified Data.HashTable.IO                      as Hash-import qualified Data.IntMap                            as IntMap-import qualified Data.HashMap.Strict                    as Map-import qualified Data.HashSet                           as Set-import Prelude---- friends-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Smart-import Data.Array.Accelerate.Array.Sugar                as Sugar-import Data.Array.Accelerate.AST                        hiding ( PreOpenAcc(..), OpenAcc(..), Acc-                                                               , PreOpenExp(..), OpenExp, PreExp, Exp-                                                               , PreBoundary(..), Boundary, Stencil(..)-                                                               , showPreAccOp, showPreExpOp )-import qualified Data.Array.Accelerate.AST              as AST-import qualified Data.Array.Accelerate.Debug            as Debug----- Configuration--- ----------------- Perhaps the configuration should be passed as a reader monad or some such,--- but that's a little inconvenient.----data Config = Config-  {-    recoverAccSharing   :: Bool         -- ^ Recover sharing of array computations ?-  , recoverExpSharing   :: Bool         -- ^ Recover sharing of scalar expressions ?-  , recoverSeqSharing   :: Bool         -- ^ Recover sharing of sequence computations ?-  , floatOutAcc         :: Bool         -- ^ Always float array computations out of expressions ?-  }---- Layouts--- ----------- A layout of an environment has an entry for each entry of the environment.--- Each entry in the layout holds the de Bruijn index that refers to the--- corresponding entry in the environment.----data Layout env env' where-  EmptyLayout :: Layout env ()-  PushLayout  :: Typeable t-              => Layout env env' -> Idx env t -> Layout env (env', t)---- Project the nth index out of an environment layout.------ The first argument provides context information for error messages in the case of failure.----prjIdx :: forall t env env'. Typeable t => String -> Int -> Layout env env' -> Idx env t-prjIdx ctxt 0 (PushLayout _ (ix :: Idx env0 t0))-  = flip fromMaybe (gcast ix)-  $ possiblyNestedErr ctxt $-      "Couldn't match expected type `" ++ show (typeOf (undefined::t)) ++-      "' with actual type `" ++ show (typeOf (undefined::t0)) ++ "'" ++-      "\n  Type mismatch"-prjIdx ctxt n (PushLayout l _)  = prjIdx ctxt (n - 1) l-prjIdx ctxt _ EmptyLayout       = possiblyNestedErr ctxt "Environment doesn't contain index"--possiblyNestedErr :: String -> String -> a-possiblyNestedErr ctxt failreason-  = error $ "Fatal error in Sharing.prjIdx:"-      ++ "\n  " ++ failreason ++ " at " ++ ctxt-      ++ "\n  Possible reason: nested data parallelism — array computation that depends on a"-      ++ "\n    scalar variable of type 'Exp a'"---- Add an entry to a layout, incrementing all indices----incLayout :: Layout env env' -> Layout (env, t) env'-incLayout EmptyLayout         = EmptyLayout-incLayout (PushLayout lyt ix) = PushLayout (incLayout lyt) (SuccIdx ix)--sizeLayout :: Layout env env' -> Int-sizeLayout EmptyLayout        = 0-sizeLayout (PushLayout lyt _) = 1 + sizeLayout lyt----- Conversion from HOAS to de Bruijn computation AST--- =================================================---- Array computations--- ---------------------- | Convert a closed array expression to de Bruijn form while also incorporating sharing--- information.----convertAcc-    :: Arrays arrs-    => Bool             -- ^ recover sharing of array computations ?-    -> Bool             -- ^ recover sharing of scalar expressions ?-    -> Bool             -- ^ recover sharing of sequence computations ?-    -> Bool             -- ^ always float array computations out of expressions?-    -> Acc arrs-    -> AST.Acc arrs-convertAcc shareAcc shareExp shareSeq floatAcc acc-  = let config  = Config shareAcc shareExp shareSeq (shareAcc && floatAcc)-    in-    convertOpenAcc config 0 [] EmptyLayout acc----- | Convert a closed function over array computations, while incorporating--- sharing information.----convertAfun :: Afunction f => Bool -> Bool -> Bool -> Bool -> f -> AST.Afun (AfunctionR f)-convertAfun shareAcc shareExp shareSeq floatAcc =-  let config = Config shareAcc shareExp shareSeq (shareAcc && floatAcc)-  in  aconvert config EmptyLayout----- Convert a HOAS fragment into de Bruijn form, binding variables into the typed--- environment layout one binder at a time.------ NOTE: Because we convert one binder at a time left-to-right, the bound---       variables ('vars') will have de Bruijn index _zero_ as the outermost---       binding, and thus go to the end of the list.----class Afunction f where-  type AfunctionR f-  aconvert :: Config -> Layout aenv aenv -> f -> AST.OpenAfun aenv (AfunctionR f)--instance (Arrays a, Afunction r) => Afunction (Acc a -> r) where-  type AfunctionR (Acc a -> r) = a -> AfunctionR r-  ---  aconvert config alyt f-    = let a     = Acc $ Atag (sizeLayout alyt)-          alyt' = incLayout alyt `PushLayout` ZeroIdx-      in-      Alam $ aconvert config alyt' (f a)--instance Arrays b => Afunction (Acc b) where-  type AfunctionR (Acc b) = b-  ---  aconvert config alyt body-    = let lvl    = sizeLayout alyt-          vars   = [lvl-1, lvl-2 .. 0]-      in-      Abody $ convertOpenAcc config lvl vars alyt body----- | Convert an open array expression to de Bruijn form while also incorporating sharing--- information.----convertOpenAcc-    :: Arrays arrs-    => Config-    -> Level-    -> [Level]-    -> Layout aenv aenv-    -> Acc arrs-    -> AST.OpenAcc aenv arrs-convertOpenAcc config lvl fvs alyt acc-  = let (sharingAcc, initialEnv) = recoverSharingAcc config lvl fvs acc-    in-    convertSharingAcc config alyt initialEnv sharingAcc---- | Convert an array expression with given array environment layout and sharing information into--- de Bruijn form while recovering sharing at the same time (by introducing appropriate let--- bindings).  The latter implements the third phase of sharing recovery.------ The sharing environment 'env' keeps track of all currently bound sharing variables, keeping them--- in reverse chronological order (outermost variable is at the end of the list).----convertSharingAcc-    :: forall aenv arrs. Arrays arrs-    => Config-    -> Layout aenv aenv-    -> [StableSharingAcc]-    -> ScopedAcc arrs-    -> AST.OpenAcc aenv arrs-convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa))-  | Just i <- findIndex (matchStableAcc sa) aenv'-  = AST.OpenAcc $ AST.Avar (prjIdx (ctxt ++ "; i = " ++ show i) i alyt)-  | null aenv'-  = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++-            show (hashStableNameHeight sa) ++ ")"-  | otherwise-  = $internalError "convertSharingAcc" err-  where-    aenv' = lams ++ aenv-    ctxt = "shared 'Acc' tree with stable name " ++ show (hashStableNameHeight sa)-    err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  aenv = " ++ show aenv'--convertSharingAcc config alyt aenv (ScopedAcc lams (AletSharing sa@(StableSharingAcc _ boundAcc) bodyAcc))-  = AST.OpenAcc-  $ let alyt' = incLayout alyt `PushLayout` ZeroIdx-        aenv' = lams ++ aenv-    in-    AST.Alet (convertSharingAcc config alyt aenv' (ScopedAcc [] boundAcc))-             (convertSharingAcc config alyt' (sa:aenv') bodyAcc)--convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc))-  = AST.OpenAcc-  $ let aenv' = lams ++ aenv--        cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a-        cvtA = convertSharingAcc config alyt aenv'--        cvtE :: Elt t => ScopedExp t -> AST.Exp aenv t-        cvtE = convertSharingExp config EmptyLayout alyt [] aenv'--        cvtF1 :: (Elt a, Elt b) => (Exp a -> ScopedExp b) -> AST.Fun aenv (a -> b)-        cvtF1 = convertSharingFun1 config alyt aenv'--        cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c)-        cvtF2 = convertSharingFun2 config alyt aenv'--        cvtAfun1 :: (Arrays a, Arrays b) => (Acc a -> ScopedAcc b) -> AST.OpenAfun aenv (a -> b)-        cvtAfun1 = convertSharingAfun1 config alyt aenv'-    in-    case preAcc of--      Atag i-        -> AST.Avar (prjIdx ("de Bruijn conversion tag " ++ show i) i alyt)--      Pipe afun1 afun2 acc-        -> let noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ())-               alyt'    = incLayout alyt `PushLayout` ZeroIdx-               boundAcc = cvtAfun1 afun1 `AST.Apply` cvtA acc-               bodyAcc  = convertSharingAfun1 config alyt' (noStableSharing : aenv') afun2-                          `AST.Apply`-                          AST.OpenAcc (AST.Avar AST.ZeroIdx)-           in-           AST.Alet (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc)--      Aforeign ff afun acc-        -> let a = recoverAccSharing config-               e = recoverExpSharing config-               s = recoverSeqSharing config-               f = floatOutAcc config-           in-           AST.Aforeign ff (convertAfun a e s f afun) (cvtA acc)--      Acond b acc1 acc2           -> AST.Acond (cvtE b) (cvtA acc1) (cvtA acc2)-      Awhile pred iter init       -> AST.Awhile (cvtAfun1 pred) (cvtAfun1 iter) (cvtA init)-      Atuple arrs                 -> AST.Atuple (convertSharingAtuple config alyt aenv' arrs)-      Aprj ix a                   -> AST.Aprj ix (cvtA a)-      Use array                   -> AST.Use (fromArr array)-      Unit e                      -> AST.Unit (cvtE e)-      Generate sh f               -> AST.Generate (cvtE sh) (cvtF1 f)-      Reshape e acc               -> AST.Reshape (cvtE e) (cvtA acc)-      Replicate ix acc            -> mkReplicate (cvtE ix) (cvtA acc)-      Slice acc ix                -> mkIndex (cvtA acc) (cvtE ix)-      Map f acc                   -> AST.Map (cvtF1 f) (cvtA acc)-      ZipWith f acc1 acc2         -> AST.ZipWith (cvtF2 f) (cvtA acc1) (cvtA acc2)-      Fold f e acc                -> AST.Fold (cvtF2 f) (cvtE e) (cvtA acc)-      Fold1 f acc                 -> AST.Fold1 (cvtF2 f) (cvtA acc)-      FoldSeg f e acc1 acc2       -> AST.FoldSeg (cvtF2 f) (cvtE e) (cvtA acc1) (cvtA acc2)-      Fold1Seg f acc1 acc2        -> AST.Fold1Seg (cvtF2 f) (cvtA acc1) (cvtA acc2)-      Scanl f e acc               -> AST.Scanl (cvtF2 f) (cvtE e) (cvtA acc)-      Scanl' f e acc              -> AST.Scanl' (cvtF2 f) (cvtE e) (cvtA acc)-      Scanl1 f acc                -> AST.Scanl1 (cvtF2 f) (cvtA acc)-      Scanr f e acc               -> AST.Scanr (cvtF2 f) (cvtE e) (cvtA acc)-      Scanr' f e acc              -> AST.Scanr' (cvtF2 f) (cvtE e) (cvtA acc)-      Scanr1 f acc                -> AST.Scanr1 (cvtF2 f) (cvtA acc)-      Permute f dftAcc perm acc   -> AST.Permute (cvtF2 f) (cvtA dftAcc) (cvtF1 perm) (cvtA acc)-      Backpermute newDim perm acc -> AST.Backpermute (cvtE newDim) (cvtF1 perm) (cvtA acc)-      Stencil stencil boundary acc-        -> AST.Stencil (convertSharingStencilFun1 config acc alyt aenv' stencil)-                       (convertSharingBoundary config alyt aenv' boundary)-                       (cvtA acc)-      Stencil2 stencil bndy1 acc1 bndy2 acc2-        -> AST.Stencil2 (convertSharingStencilFun2 config acc1 acc2 alyt aenv' stencil)-                        (convertSharingBoundary config alyt aenv' bndy1)-                        (cvtA acc1)-                        (convertSharingBoundary config alyt aenv' bndy2)-                        (cvtA acc2)-      -- Collect seq -> AST.Collect (convertSharingSeq config alyt EmptyLayout aenv' [] seq)---{----- Sequence expressions--- ---------------------- | Convert a closed sequence expression to de Bruijn form while incorporating--- sharing information.----convertSeq-    :: Typeable s-    => Bool             -- ^ recover sharing of array computations ?-    -> Bool             -- ^ recover sharing of scalar expressions ?-    -> Bool             -- ^ recover sharing of sequence computations ?-    -> Bool             -- ^ always float array computations out of expressions?-    -> Seq s            -- ^ computation to be converted-    -> AST.Seq s-convertSeq shareAcc shareExp shareSeq floatAcc seq-  = let config = Config shareAcc shareExp shareSeq floatAcc-        (sharingSeq, initialEnv) = recoverSharingSeq config seq-    in-    convertSharingSeq config EmptyLayout EmptyLayout [] initialEnv sharingSeq--convertSharingSeq-    :: forall aenv senv arrs.-       Config-    -> Layout aenv aenv-    -> Layout senv senv-    -> [StableSharingAcc]-    -> [StableSharingSeq]-    -> ScopedSeq arrs-    -> AST.PreOpenSeq AST.OpenAcc aenv senv arrs-convertSharingSeq _ _ slyt _ senv (ScopedSeq (SvarSharing sn))-  | Just i <- findIndex (matchStableSeq sn) senv-  = AST.Reify $ prjIdx (ctxt ++ "; i = " ++ show i) i slyt-  | null senv-  = error $ "Cyclic definition of a value of type 'Seq' (sa = " ++-            show (hashStableNameHeight sn) ++ ")"-  | otherwise-  = $internalError "convertSharingSeq" err-  where-    ctxt = "shared 'Seq' tree with stable name " ++ show (hashStableNameHeight sn)-    err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  senv = " ++ show senv-convertSharingSeq config alyt slyt aenv senv (ScopedSeq (SletSharing sa@(StableSharingSeq _ (SeqSharing _ boundSeq)) bodySeq))-  = convSeq boundSeq bodySeq-  where-    convSeq :: forall bnd body.-               PreSeq ScopedAcc ScopedSeq ScopedExp bnd-            -> ScopedSeq body-            -> AST.PreOpenSeq AST.OpenAcc aenv senv body-    convSeq bnd body =-      case bnd of-        StreamIn arrs               -> producer $ AST.StreamIn arrs-        ToSeq slix acc              -> producer $ mkToSeq slix (cvtA acc)-        MapSeq afun x               -> producer $ AST.MapSeq (cvtAF1 afun) (asIdx x)-        ZipWithSeq afun x y         -> producer $ AST.ZipWithSeq (cvtAF2 afun) (asIdx x) (asIdx y)-        ScanSeq fun e x             -> producer $ AST.ScanSeq (cvtF2 fun) (cvtE e) (asIdx x)-        _                           -> $internalError "convertSharingSeq:convSeq" "Consumer appears to have been let bound"-      where-        producer :: Arrays a-                 => AST.Producer AST.OpenAcc aenv senv a-                 -> AST.PreOpenSeq AST.OpenAcc aenv senv body-        producer p = AST.Producer p $ convertSharingSeq config alyt slyt' aenv (sa:senv) body-          where-            slyt' = incLayout slyt `PushLayout` ZeroIdx--        asIdx :: Arrays a-              => ScopedSeq [a]-              -> Idx senv a-        asIdx (ScopedSeq (SvarSharing sn))-          | Just i <- findIndex (matchStableSeq sn) senv-          = prjIdx (ctxt ++ "; i = " ++ show i) i slyt-          | null senv-          = error $ "Cyclic definition of a value of type 'Seq' (sa = " ++-                    show (hashStableNameHeight sn) ++ ")"-          | otherwise-          = $internalError "convertSharingSeq" err-          where-            ctxt = "shared 'Seq' tree with stable name " ++ show (hashStableNameHeight sn)-            err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  senv = " ++ show senv-        asIdx _-          = $internalError "convertSharingSeq:asIdx" "Sequence computation not in A-normal form"--        cvtA :: forall a. Arrays a => ScopedAcc a -> AST.OpenAcc aenv a-        cvtA acc = convertSharingAcc config alyt aenv acc--        cvtE :: forall t. Elt t => ScopedExp t -> AST.Exp aenv t-        cvtE = convertSharingExp config EmptyLayout alyt [] aenv--        cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c)-        cvtF2 = convertSharingFun2 config alyt aenv--        cvtAF1 :: forall a b. (Arrays a, Arrays b) => (Acc a -> ScopedAcc b) -> OpenAfun aenv (a -> b)-        cvtAF1 afun = convertSharingAfun1 config alyt aenv afun--        cvtAF2 :: forall a b c. (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b -> ScopedAcc c) -> OpenAfun aenv (a -> b -> c)-        cvtAF2 afun = convertSharingAfun2 config alyt aenv afun--convertSharingSeq _ _ _ _ _ (ScopedSeq (SletSharing _ _))- = $internalError "convertSharingSeq" "Sequence computation not in A-normal form"--convertSharingSeq config alyt slyt aenv senv s-  = cvtC s-  where-    cvtC :: ScopedSeq a -> AST.PreOpenSeq AST.OpenAcc aenv senv a-    cvtC (ScopedSeq (SeqSharing _ s)) =-      case s of-        FoldSeq fun e x                    -> AST.Consumer $ AST.FoldSeq (cvtF2 fun) (cvtE e) (asIdx x)-        FoldSeqFlatten afun acc x          -> AST.Consumer $ AST.FoldSeqFlatten (cvtAF3 afun) (cvtA acc) (asIdx x)-        Stuple t                           -> AST.Consumer $ AST.Stuple (cvtST t)-        _                                  -> $internalError "convertSharingSeq" "Producer has not been let bound"-    cvtC _ = $internalError "convertSharingSeq" "Unreachable"--    asIdx :: Arrays a-          => ScopedSeq [a]-          -> Idx senv a-    asIdx (ScopedSeq (SvarSharing sn))-      | Just i <- findIndex (matchStableSeq sn) senv-      = prjIdx (ctxt ++ "; i = " ++ show i) i slyt-      | null senv-      = error $ "Cyclic definition of a value of type 'Seq' (sa = " ++-                show (hashStableNameHeight sn) ++ ")"-      | otherwise-      = $internalError "convertSharingSeq" err-      where-        ctxt = "shared 'Seq' tree with stable name " ++ show (hashStableNameHeight sn)-        err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  senv = " ++ show senv-    asIdx _-      = $internalError "convertSharingSeq:asIdx" "Sequence computation not in A-normal form"--    cvtA :: forall a. Arrays a => ScopedAcc a -> AST.OpenAcc aenv a-    cvtA acc = convertSharingAcc config alyt aenv acc--    cvtE :: forall t. Elt t => ScopedExp t -> AST.Exp aenv t-    cvtE = convertSharingExp config EmptyLayout alyt [] aenv--    cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c)-    cvtF2 = convertSharingFun2 config alyt aenv--    cvtAF3 :: forall a b c d. (Arrays a, Arrays b, Arrays c, Arrays d) => (Acc a -> Acc b -> Acc c -> ScopedAcc d) -> OpenAfun aenv (a -> b -> c -> d)-    cvtAF3 afun = convertSharingAfun3 config alyt aenv afun--    cvtST :: Atuple ScopedSeq t -> Atuple (AST.Consumer AST.OpenAcc aenv senv) t-    cvtST NilAtup        = NilAtup-    cvtST (SnocAtup t c) | AST.Consumer c' <- cvtC c-                         = SnocAtup (cvtST t) c'-                         | otherwise-                         = $internalError "convertSharingSeq" "Unreachable"---}--convertSharingAfun1-    :: forall aenv a b. (Arrays a, Arrays b)-    => Config-    -> Layout aenv aenv-    -> [StableSharingAcc]-    -> (Acc a -> ScopedAcc b)-    -> OpenAfun aenv (a -> b)-convertSharingAfun1 config alyt aenv f-  = Alam (Abody (convertSharingAcc config alyt' aenv body))-      where-        alyt' = incLayout alyt `PushLayout` ZeroIdx-        body  = f undefined--{---convertSharingAfun2-    :: forall aenv a b c. (Arrays a, Arrays b, Arrays c)-    => Config-    -> Layout aenv aenv-    -> [StableSharingAcc]-    -> (Acc a -> Acc b -> ScopedAcc c)-    -> OpenAfun aenv (a -> b -> c)-convertSharingAfun2 config alyt aenv f-  = Alam (Alam (Abody (convertSharingAcc config alyt' aenv body)))-      where-        alyt' = incLayout (incLayout alyt `PushLayout` ZeroIdx) `PushLayout` ZeroIdx-        body  = f undefined undefined--convertSharingAfun3-    :: forall aenv a b c d. (Arrays a, Arrays b, Arrays c, Arrays d)-    => Config-    -> Layout aenv aenv-    -> [StableSharingAcc]-    -> (Acc a -> Acc b -> Acc c -> ScopedAcc d)-    -> OpenAfun aenv (a -> b -> c -> d)-convertSharingAfun3 config alyt aenv f-  = Alam (Alam (Alam (Abody (convertSharingAcc config alyt' aenv body))))-      where-        alyt' = incLayout (incLayout (incLayout alyt `PushLayout` ZeroIdx) `PushLayout` ZeroIdx) `PushLayout` ZeroIdx-        body  = f undefined undefined undefined---}--convertSharingAtuple-    :: forall aenv a.-       Config-    -> Layout aenv aenv-    -> [StableSharingAcc]-    -> Atuple ScopedAcc a-    -> Atuple (AST.OpenAcc aenv) a-convertSharingAtuple config alyt aenv = cvt-  where-    cvt :: Atuple ScopedAcc a' -> Atuple (AST.OpenAcc aenv) a'-    cvt NilAtup         = NilAtup-    cvt (SnocAtup t a)  = cvt t `SnocAtup` convertSharingAcc config alyt aenv a----- | Convert a boundary condition----convertSharingBoundary-    :: forall aenv t.-       Config-    -> Layout aenv aenv-    -> [StableSharingAcc]-    -> PreBoundary ScopedAcc ScopedExp t-    -> AST.PreBoundary AST.OpenAcc aenv t-convertSharingBoundary config alyt aenv = cvt-  where-    cvt :: PreBoundary ScopedAcc ScopedExp t -> AST.Boundary aenv t-    cvt bndy =-      case bndy of-        Clamp       -> AST.Clamp-        Mirror      -> AST.Mirror-        Wrap        -> AST.Wrap-        Constant v  -> AST.Constant $ fromElt v-        Function f  -> AST.Function $ convertSharingFun1 config alyt aenv f----- Smart constructors to represent AST forms----mkIndex :: forall slix e aenv. (Slice slix, Elt e)-        => AST.OpenAcc                aenv (Array (FullShape  slix) e)-        -> AST.Exp                    aenv slix-        -> AST.PreOpenAcc AST.OpenAcc aenv (Array (SliceShape slix) e)-mkIndex = AST.Slice (sliceIndex slix)-  where-    slix = undefined :: slix--mkReplicate :: forall slix e aenv. (Slice slix, Elt e)-        => AST.Exp                    aenv slix-        -> AST.OpenAcc                aenv (Array (SliceShape slix) e)-        -> AST.PreOpenAcc AST.OpenAcc aenv (Array (FullShape  slix) e)-mkReplicate = AST.Replicate (sliceIndex slix)-  where-    slix = undefined :: slix---- mkToSeq :: forall slsix slix e aenv senv. (Division slsix, DivisionSlice slsix ~ slix, Elt e, Elt slix, Slice slix)---         => slsix---         -> AST.OpenAcc              aenv (Array (FullShape  slix) e)---         -> AST.Producer AST.OpenAcc aenv senv (Array (SliceShape slix) e)--- mkToSeq _ = AST.ToSeq (sliceIndex slix) (Proxy :: Proxy slix)---   where---     slix = undefined :: slix----- Scalar functions--- -------------------- | Convert a closed scalar function to de Bruijn form while incorporating--- sharing information.------ The current design requires all free variables to be bound at the outermost--- level --- we have no general apply term, and so lambdas are always outermost.--- In higher-order abstract syntax, this represents an n-ary, polyvariadic--- function.----convertFun :: Function f => Bool -> f -> AST.Fun () (FunctionR f)-convertFun shareExp =-  let config = Config False shareExp False False-  in  convert config EmptyLayout---class Function f where-  type FunctionR f-  convert :: Config -> Layout env env -> f -> AST.OpenFun env () (FunctionR f)--instance (Elt a, Function r) => Function (Exp a -> r) where-  type FunctionR (Exp a -> r) = a -> FunctionR r-  ---  convert config lyt f-    = let x     = Exp $ Tag (sizeLayout lyt)-          lyt'  = incLayout lyt `PushLayout` ZeroIdx-      in-      Lam $ convert config lyt' (f x)--instance Elt b => Function (Exp b) where-  type FunctionR (Exp b) = b-  ---  convert config lyt body-    = let lvl    = sizeLayout lyt-          vars   = [lvl-1, lvl-2 .. 0]-      in-      Body $ convertOpenExp config lvl vars lyt body----- Scalar expressions--- ---------------------- | Convert a closed scalar expression to de Bruijn form while incorporating--- sharing information.----convertExp-    :: Elt e-    => Bool             -- ^ recover sharing of scalar expressions ?-    -> Exp e            -- ^ expression to be converted-    -> AST.Exp () e-convertExp shareExp exp-  = let config = Config False shareExp False False-    in-    convertOpenExp config 0 [] EmptyLayout exp--convertOpenExp-    :: Elt e-    => Config-    -> Level            -- level of currently bound scalar variables-    -> [Level]          -- tags of bound scalar variables-    -> Layout env env-    -> Exp e-    -> AST.OpenExp env () e-convertOpenExp config lvl fvar lyt exp-  = let (sharingExp, initialEnv) = recoverSharingExp config lvl fvar exp-    in-    convertSharingExp config lyt EmptyLayout initialEnv [] sharingExp----- | Convert an open expression with given environment layouts and sharing information into--- de Bruijn form while recovering sharing at the same time (by introducing appropriate let--- bindings).  The latter implements the third phase of sharing recovery.------ The sharing environments 'env' and 'aenv' keep track of all currently bound sharing variables,--- keeping them in reverse chronological order (outermost variable is at the end of the list).----convertSharingExp-    :: forall t env aenv. Elt t-    => Config-    -> Layout env  env          -- scalar environment-    -> Layout aenv aenv         -- array environment-    -> [StableSharingExp]       -- currently bound sharing variables of expressions-    -> [StableSharingAcc]       -- currently bound sharing variables of array computations-    -> ScopedExp t              -- expression to be converted-    -> AST.OpenExp env aenv t-convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp-  where-    -- scalar environment with any lambda bound variables this expression is rooted in-    env' = lams ++ env--    cvt :: Elt t' => ScopedExp t' -> AST.OpenExp env aenv t'-    cvt (ScopedExp _ (VarSharing se))-      | Just i <- findIndex (matchStableExp se) env'-      = AST.Var (prjIdx (ctxt ++ "; i = " ++ show i) i lyt)-      | null env'-      = error $ "Cyclic definition of a value of type 'Exp' (sa = " ++ show (hashStableNameHeight se) ++ ")"-      | otherwise-      = $internalError "convertSharingExp" err-      where-        ctxt = "shared 'Exp' tree with stable name " ++ show (hashStableNameHeight se)-        err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  env' = " ++ show env'-    cvt (ScopedExp _ (LetSharing se@(StableSharingExp _ boundExp) bodyExp))-      = let lyt' = incLayout lyt `PushLayout` ZeroIdx-        in-        AST.Let (cvt (ScopedExp [] boundExp)) (convertSharingExp config lyt' alyt (se:env') aenv bodyExp)-    cvt (ScopedExp _ (ExpSharing _ pexp))-      = case pexp of-          Tag i                 -> AST.Var (prjIdx ("de Bruijn conversion tag " ++ show i) i lyt)-          Const v               -> AST.Const (fromElt v)-          Tuple tup             -> AST.Tuple (cvtT tup)-          Prj idx e             -> AST.Prj idx (cvt e)-          IndexNil              -> AST.IndexNil-          IndexCons ix i        -> AST.IndexCons (cvt ix) (cvt i)-          IndexHead i           -> AST.IndexHead (cvt i)-          IndexTail ix          -> AST.IndexTail (cvt ix)-          IndexAny              -> AST.IndexAny-          ToIndex sh ix         -> AST.ToIndex (cvt sh) (cvt ix)-          FromIndex sh e        -> AST.FromIndex (cvt sh) (cvt e)-          Cond e1 e2 e3         -> AST.Cond (cvt e1) (cvt e2) (cvt e3)-          While p it i          -> AST.While (cvtFun1 p) (cvtFun1 it) (cvt i)-          PrimConst c           -> AST.PrimConst c-          PrimApp f e           -> cvtPrimFun f (cvt e)-          Index a e             -> AST.Index (cvtA a) (cvt e)-          LinearIndex a i       -> AST.LinearIndex (cvtA a) (cvt i)-          Shape a               -> AST.Shape (cvtA a)-          ShapeSize e           -> AST.ShapeSize (cvt e)-          Intersect sh1 sh2     -> AST.Intersect (cvt sh1) (cvt sh2)-          Union sh1 sh2         -> AST.Union (cvt sh1) (cvt sh2)-          Foreign ff f e        -> AST.Foreign ff (convertFun (recoverExpSharing config) f) (cvt e)--    cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a-    cvtA = convertSharingAcc config alyt aenv--    cvtT :: Tuple ScopedExp tup -> Tuple (AST.OpenExp env aenv) tup-    cvtT = convertSharingTuple config lyt alyt env' aenv--    cvtFun1 :: (Elt a, Elt b) => (Exp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b)-    cvtFun1 f = Lam (Body (convertSharingExp config lyt' alyt env' aenv body))-      where-        lyt' = incLayout lyt `PushLayout` ZeroIdx-        body = f undefined--    -- Push primitive function applications down through let bindings so that-    -- they are adjacent to their arguments. It looks a bit nicer this way.-    ---    cvtPrimFun :: (Elt a, Elt r)-               => AST.PrimFun (a -> r) -> AST.OpenExp env' aenv' a -> AST.OpenExp env' aenv' r-    cvtPrimFun f e = case e of-      AST.Let bnd body    -> AST.Let bnd (cvtPrimFun f body)-      x                   -> AST.PrimApp f x---- | Convert a tuple expression----convertSharingTuple-    :: Config-    -> Layout env env-    -> Layout aenv aenv-    -> [StableSharingExp]                 -- currently bound scalar sharing-variables-    -> [StableSharingAcc]                 -- currently bound array sharing-variables-    -> Tuple ScopedExp t-    -> Tuple (AST.OpenExp env aenv) t-convertSharingTuple config lyt alyt env aenv tup =-  case tup of-    NilTup      -> NilTup-    SnocTup t e -> convertSharingTuple config lyt alyt env aenv t-         `SnocTup` convertSharingExp   config lyt alyt env aenv e---- | Convert a unary functions----convertSharingFun1-    :: forall a b aenv. (Elt a, Elt b)-    => Config-    -> Layout aenv aenv-    -> [StableSharingAcc]       -- currently bound array sharing-variables-    -> (Exp a -> ScopedExp b)-    -> AST.Fun aenv (a -> b)-convertSharingFun1 config alyt aenv f = Lam (Body openF)-  where-    a               = Exp undefined             -- the 'tag' was already embedded in Phase 1-    lyt             = EmptyLayout-                      `PushLayout`-                      (ZeroIdx :: Idx ((), a) a)-    openF           = convertSharingExp config lyt alyt [] aenv (f a)---- | Convert a binary functions----convertSharingFun2-    :: forall a b c aenv. (Elt a, Elt b, Elt c)-    => Config-    -> Layout aenv aenv-    -> [StableSharingAcc]       -- currently bound array sharing-variables-    -> (Exp a -> Exp b -> ScopedExp c)-    -> AST.Fun aenv (a -> b -> c)-convertSharingFun2 config alyt aenv f = Lam (Lam (Body openF))-  where-    a               = Exp undefined-    b               = Exp undefined-    lyt             = EmptyLayout-                      `PushLayout`-                      (SuccIdx ZeroIdx :: Idx (((), a), b) a)-                      `PushLayout`-                      (ZeroIdx         :: Idx (((), a), b) b)-    openF           = convertSharingExp config lyt alyt [] aenv (f a b)---- | Convert a unary stencil function----convertSharingStencilFun1-    :: forall sh a stencil b aenv. (Elt a, Stencil sh a stencil, Elt b)-    => Config-    -> ScopedAcc (Array sh a)          -- just passed to fix the type variables-    -> Layout aenv aenv-    -> [StableSharingAcc]               -- currently bound array sharing-variables-    -> (stencil -> ScopedExp b)-    -> AST.Fun aenv (StencilRepr sh stencil -> b)-convertSharingStencilFun1 config _ alyt aenv stencilFun = Lam (Body openStencilFun)-  where-    stencil = Exp undefined :: Exp (StencilRepr sh stencil)-    lyt     = EmptyLayout-              `PushLayout`-              (ZeroIdx :: Idx ((), StencilRepr sh stencil)-                              (StencilRepr sh stencil))--    body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil)-    openStencilFun  = convertSharingExp config lyt alyt [] aenv body---- | Convert a binary stencil function----convertSharingStencilFun2-    :: forall sh a b stencil1 stencil2 c aenv.-       (Elt a, Stencil sh a stencil1,-        Elt b, Stencil sh b stencil2,-        Elt c)-    => Config-    -> ScopedAcc (Array sh a)          -- just passed to fix the type variables-    -> ScopedAcc (Array sh b)          -- just passed to fix the type variables-    -> Layout aenv aenv-    -> [StableSharingAcc]               -- currently bound array sharing-variables-    -> (stencil1 -> stencil2 -> ScopedExp c)-    -> AST.Fun aenv (StencilRepr sh stencil1 -> StencilRepr sh stencil2 -> c)-convertSharingStencilFun2 config _ _ alyt aenv stencilFun = Lam (Lam (Body openStencilFun))-  where-    stencil1 = Exp undefined :: Exp (StencilRepr sh stencil1)-    stencil2 = Exp undefined :: Exp (StencilRepr sh stencil2)-    lyt     = EmptyLayout-              `PushLayout`-              (SuccIdx ZeroIdx :: Idx (((), StencilRepr sh stencil1),-                                            StencilRepr sh stencil2)-                                       (StencilRepr sh stencil1))-              `PushLayout`-              (ZeroIdx         :: Idx (((), StencilRepr sh stencil1),-                                            StencilRepr sh stencil2)-                                       (StencilRepr sh stencil2))--    body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1)-                      (stencilPrj (undefined::sh) (undefined::b) stencil2)-    openStencilFun  = convertSharingExp config lyt alyt [] aenv body----- Sharing recovery--- ================---- Sharing recovery proceeds in two phases:------ /Phase One: build the occurrence map/------ This is a top-down traversal of the AST that computes a map from AST nodes to the number of--- occurrences of that AST node in the overall Accelerate program.  An occurrences count of two or--- more indicates sharing.------ IMPORTANT: To avoid unfolding the sharing, we do not descent into subtrees that we have---   previously encountered.  Hence, the complexity is proportional to the number of nodes in the---   tree /with/ sharing.  Consequently, the occurrence count is that in the tree with sharing---   as well.------ During computation of the occurrences, the tree is annotated with stable names on every node--- using 'AccSharing' constructors and all but the first occurrence of shared subtrees are pruned--- using 'AvarSharing' constructors (see 'SharingAcc' below).  This phase is impure as it is based--- on stable names.------ We use a hash table (instead of 'Data.Map') as computing stable names forces us to live in IO--- anyway.  Once, the computation of occurrence counts is complete, we freeze the hash table into--- a 'Data.Map'.------ (Implemented by 'makeOccMap*'.)------ /Phase Two: determine scopes and inject sharing information/------ This is a bottom-up traversal that determines the scope for every binding to be introduced--- to share a subterm.  It uses the occurrence map to determine, for every shared subtree, the--- lowest AST node at which the binding for that shared subtree can be placed (using a--- 'AletSharing' constructor)— it's the meet of all the shared subtree occurrences.------ The second phase is also replacing the first occurrence of each shared subtree with a--- 'AvarSharing' node and floats the shared subtree up to its binding point.------  (Implemented by 'determineScopes*'.)------ /Sharing recovery for expressions/------ We recover sharing for each expression (including function bodies) independently of any other--- expression — i.e., we cannot share scalar expressions across array computations.  Hence, during--- Phase One, we mark all scalar expression nodes with a stable name and compute one occurrence map--- for every scalar expression (including functions) that occurs in an array computation.  These--- occurrence maps are added to the root of scalar expressions using 'RootExp'.------ NB: We do not need to worry sharing recovery will try to float a shared subexpression past a---     binder that occurs in that subexpression.  Why?  Otherwise, the binder would already occur---     out of scope in the original source program.------ /Lambda bound variables/------ During sharing recovery, lambda bound variables appear in the form of 'Atag' and 'Tag' data--- constructors.  The tag values are determined during Phase One of sharing recovery by computing--- the /level/ of each variable at its binding occurrence.  The level at the root of the AST is 0--- and increases by one with each lambda on each path through the AST.---- Stable names--- ---------------- Opaque stable name for AST nodes — used to key the occurrence map.----data StableASTName c where-  StableASTName :: (Typeable c, Typeable t) => StableName (c t) -> StableASTName c--instance Show (StableASTName c) where-  show (StableASTName sn) = show $ hashStableName sn--instance Eq (StableASTName c) where-  StableASTName sn1 == StableASTName sn2-    | Just sn1' <- gcast sn1 = sn1' == sn2-    | otherwise              = False--instance Hashable (StableASTName c) where-  hashWithSalt s (StableASTName sn) = hashWithSalt s sn--makeStableAST :: c t -> IO (StableName (c t))-makeStableAST e = e `seq` makeStableName e---- Stable name for an AST node including the height of the AST representing the array computation.----data StableNameHeight t = StableNameHeight (StableName t) Int--instance Eq (StableNameHeight t) where-  (StableNameHeight sn1 _) == (StableNameHeight sn2 _) = sn1 == sn2--higherSNH :: StableNameHeight t1 -> StableNameHeight t2 -> Bool-StableNameHeight _ h1 `higherSNH` StableNameHeight _ h2 = h1 > h2--hashStableNameHeight :: StableNameHeight t -> Int-hashStableNameHeight (StableNameHeight sn _) = hashStableName sn---- Mutable occurrence map--- -------------------------- Hash table keyed on the stable names of array computations.----type HashTable key val = Hash.BasicHashTable key val-type ASTHashTable c v  = HashTable (StableASTName c) v---- Mutable hashtable version of the occurrence map, which associates each AST node with an--- occurrence count and the height of the AST.----type OccMapHash c = ASTHashTable c (Int, Int)---- Create a new hash table keyed on AST nodes.----newASTHashTable :: IO (ASTHashTable c v)-newASTHashTable = Hash.new---- Enter one AST node occurrence into an occurrence map.  Returns 'Just h' if this is a repeated--- occurrence and the height of the repeatedly occurring AST is 'h'.------ If this is the first occurrence, the 'height' *argument* must provide the height of the AST;--- otherwise, the height will be *extracted* from the occurrence map.  In the latter case, this--- function yields the AST height.----enterOcc :: OccMapHash c -> StableASTName c -> Int -> IO (Maybe Int)-enterOcc occMap sa height-  = do-      entry <- Hash.lookup occMap sa-      case entry of-        Nothing           -> Hash.insert occMap sa (1    , height)  >> return Nothing-        Just (n, heightS) -> Hash.insert occMap sa (n + 1, heightS) >> return (Just heightS)---- Immutable occurrence map--- ---------------------------- Immutable version of the occurrence map (storing the occurrence count only, not the height).  We--- use the 'StableName' hash to index an 'IntMap' and disambiguate 'StableName's with identical--- hashes explicitly, storing them in a list in the 'IntMap'.----type OccMap c = IntMap.IntMap [(StableASTName c, Int)]---- Turn a mutable into an immutable occurrence map.----freezeOccMap :: OccMapHash c -> IO (OccMap c)-freezeOccMap oc-  = do-      ocl <- Hash.toList oc-      traceChunk "OccMap" (show ocl)--      return . IntMap.fromList-             . map (\kvs -> (key (head kvs), kvs))-             . groupBy sameKey-             . map dropHeight-             $ ocl-  where-    key (StableASTName sn, _) = hashStableName sn-    sameKey kv1 kv2           = key kv1 == key kv2-    dropHeight (k, (cnt, _))  = (k, cnt)---- Look up the occurrence map keyed by array computations using a stable name.  If the key does--- not exist in the map, return an occurrence count of '1'.----lookupWithASTName :: OccMap c -> StableASTName c -> Int-lookupWithASTName oc sa@(StableASTName sn)-  = fromMaybe 1 $ IntMap.lookup (hashStableName sn) oc >>= Prelude.lookup sa---- Look up the occurrence map keyed by array computations using a sharing array computation.  If an--- the key does not exist in the map, return an occurrence count of '1'.----lookupWithSharingAcc :: OccMap Acc -> StableSharingAcc -> Int-lookupWithSharingAcc oc (StableSharingAcc (StableNameHeight sn _) _)-  = lookupWithASTName oc (StableASTName sn)---- Look up the occurrence map keyed by scalar expressions using a sharing expression.  If an--- the key does not exist in the map, return an occurrence count of '1'.----lookupWithSharingExp :: OccMap Exp -> StableSharingExp -> Int-lookupWithSharingExp oc (StableSharingExp (StableNameHeight sn _) _)-  = lookupWithASTName oc (StableASTName sn)----- Stable 'Acc' nodes--- ---------------------- Stable name for 'Acc' nodes including the height of the AST.----type StableAccName arrs = StableNameHeight (Acc arrs)---- Interleave sharing annotations into an array computation AST.  Subtrees can be marked as being--- represented by variable (binding a shared subtree) using 'AvarSharing' and as being prefixed by--- a let binding (for a shared subtree) using 'AletSharing'.----data SharingAcc acc exp arrs where-  AvarSharing :: Arrays arrs-              => StableAccName arrs                        -> SharingAcc acc exp arrs-  AletSharing :: StableSharingAcc -> acc arrs              -> SharingAcc acc exp arrs-  AccSharing  :: Arrays arrs-              => StableAccName arrs -> PreAcc acc exp arrs -> SharingAcc acc exp arrs---- Array expression with sharing but shared values have not been scoped; i.e. no let bindings. If--- the expression is rooted in a function, the list contains the tags of the variables bound by the--- immediate surrounding lambdas.-data UnscopedAcc t = UnscopedAcc [Int] (SharingAcc UnscopedAcc RootExp t)---- Array expression with sharing. For expressions rooted in functions the list holds a sorted--- environment corresponding to the variables bound in the immediate surounding lambdas.-data ScopedAcc t = ScopedAcc [StableSharingAcc] (SharingAcc ScopedAcc ScopedExp t)---- Stable name for an array computation associated with its sharing-annotated version.----data StableSharingAcc where-  StableSharingAcc :: Arrays arrs-                   => StableAccName arrs-                   -> SharingAcc ScopedAcc ScopedExp arrs-                   -> StableSharingAcc--instance Show StableSharingAcc where-  show (StableSharingAcc sn _) = show $ hashStableNameHeight sn--instance Eq StableSharingAcc where-  StableSharingAcc sn1 _ == StableSharingAcc sn2 _-    | Just sn1' <- gcast sn1 = sn1' == sn2-    | otherwise              = False--higherSSA :: StableSharingAcc -> StableSharingAcc -> Bool-StableSharingAcc sn1 _ `higherSSA` StableSharingAcc sn2 _ = sn1 `higherSNH` sn2---- Test whether the given stable names matches an array computation with sharing.----matchStableAcc :: Typeable arrs => StableAccName arrs -> StableSharingAcc -> Bool-matchStableAcc sn1 (StableSharingAcc sn2 _)-  | Just sn1' <- gcast sn1 = sn1' == sn2-  | otherwise              = False---- Dummy entry for environments to be used for unused variables.----noStableAccName :: StableAccName arrs-noStableAccName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0---- Stable 'Exp' nodes--- ---------------------- Stable name for 'Exp' nodes including the height of the AST.----type StableExpName t = StableNameHeight (Exp t)---- Interleave sharing annotations into a scalar expressions AST in the same manner as 'SharingAcc'--- do for array computations.----data SharingExp (acc :: * -> *) exp t where-  VarSharing :: Elt t-             => StableExpName t                     -> SharingExp acc exp t-  LetSharing :: StableSharingExp -> exp t           -> SharingExp acc exp t-  ExpSharing :: Elt t-             => StableExpName t -> PreExp acc exp t -> SharingExp acc exp t---- Specifies a scalar expression AST with sharing annotations but no scoping; i.e. no LetSharing--- constructors. If the expression is rooted in a function, the list contains the tags of the--- variables bound by the immediate surrounding lambdas.-data UnscopedExp t = UnscopedExp [Int] (SharingExp UnscopedAcc UnscopedExp t)---- Specifies a scalar expression AST with sharing. For expressions rooted in functions the list--- holds a sorted environment corresponding to the variables bound in the immediate surounding--- lambdas.-data ScopedExp t = ScopedExp [StableSharingExp] (SharingExp ScopedAcc ScopedExp t)---- Expressions rooted in 'Acc' computations.------ * When counting occurrences, the root of every expression embedded in an 'Acc' is annotated by---   an occurrence map for that one expression (excluding any subterms that are rooted in embedded---   'Acc's.)----data RootExp t = RootExp (OccMap Exp) (UnscopedExp t)---- Stable name for an expression associated with its sharing-annotated version.----data StableSharingExp where-  StableSharingExp :: Elt t => StableExpName t -> SharingExp ScopedAcc ScopedExp t -> StableSharingExp--instance Show StableSharingExp where-  show (StableSharingExp sn _) = show $ hashStableNameHeight sn--instance Eq StableSharingExp where-  StableSharingExp sn1 _ == StableSharingExp sn2 _-    | Just sn1' <- gcast sn1 = sn1' == sn2-    | otherwise              = False--higherSSE :: StableSharingExp -> StableSharingExp -> Bool-StableSharingExp sn1 _ `higherSSE` StableSharingExp sn2 _ = sn1 `higherSNH` sn2---- Test whether the given stable names matches an expression with sharing.----matchStableExp :: Typeable t => StableExpName t -> StableSharingExp -> Bool-matchStableExp sn1 (StableSharingExp sn2 _)-  | Just sn1' <- gcast sn1 = sn1' == sn2-  | otherwise              = False---- Dummy entry for environments to be used for unused variables.----noStableExpName :: StableExpName t-noStableExpName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0---{----- Stable 'Seq' nodes--- ---------------------- Stable name for 'Seq' nodes including the height of the AST.----type StableSeqName arrs = StableNameHeight (Seq arrs)---- Interleave sharing annotations into an sequence computation AST in the same manner as SharingAcc--- and SharingExp----data SharingSeq acc seq exp arrs where-  SvarSharing :: (Typeable arrs, Arrays arrs)-              => StableSeqName [arrs]                       -> SharingSeq acc seq exp [arrs]-  SletSharing :: StableSharingSeq -> seq t                  -> SharingSeq acc seq exp t-  SeqSharing  :: Typeable arrs-              => StableSeqName arrs -> PreSeq acc seq exp arrs -> SharingSeq acc seq exp arrs---- Array expression with sharing but shared values have not been scoped; i.e. no let bindings. If--- the expression is rooted in a function, the list contains the tags of the variables bound by the--- immediate surrounding lambdas.-data UnscopedSeq t = UnscopedSeq (SharingSeq UnscopedAcc UnscopedSeq RootExp t)---- Array expression with sharing. For expressions rooted in functions the list holds a sorted--- environment corresponding to the variables bound in the immediate surounding lambdas.-data ScopedSeq t = ScopedSeq (SharingSeq ScopedAcc ScopedSeq ScopedExp t)---- Sequences rooted in 'Acc' computations.------ * When counting occurrences, the root of every sequence embedded in an 'Acc' is annotated by---   an occurrence map for that one expression (excluding any subterms that are rooted in embedded---   'Acc's.)----data RootSeq t = RootSeq (OccMap Seq) (UnscopedSeq t)---- Stable name for an array computation associated with its sharing-annotated version.----data StableSharingSeq where-  StableSharingSeq :: Typeable arrs-                   => StableSeqName arrs-                   -> SharingSeq ScopedAcc ScopedSeq ScopedExp arrs-                   -> StableSharingSeq--instance Show StableSharingSeq where-  show (StableSharingSeq sn _) = show $ hashStableNameHeight sn--instance Eq StableSharingSeq where-  StableSharingSeq sn1 _ == StableSharingSeq sn2 _-    | Just sn1' <- gcast sn1 = sn1' == sn2-    | otherwise              = False--higherSSS :: StableSharingSeq -> StableSharingSeq -> Bool-StableSharingSeq sn1 _ `higherSSS` StableSharingSeq sn2 _ = sn1 `higherSNH` sn2---- Test whether the given stable names matches an array computation with sharing.----matchStableSeq :: Typeable arrs => StableSeqName arrs -> StableSharingSeq -> Bool-matchStableSeq sn1 (StableSharingSeq sn2 _)-  | Just sn1' <- gcast sn1 = sn1' == sn2-  | otherwise              = False---}----- Occurrence counting--- ===================---- Compute the 'Acc' occurrence map, marks all nodes (both 'Seq' and 'Exp' nodes) with stable names,--- and drop repeated occurrences of shared 'Acc' and 'Exp' subtrees (Phase One).------ We compute a single 'Acc' occurrence map for the whole AST, but one 'Exp' occurrence map for each--- sub-expression rooted in an 'Acc' operation.  This is as we cannot float 'Exp' subtrees across--- 'Acc' operations, but we can float 'Acc' subtrees out of 'Exp' expressions.------ Note [Traversing functions and side effects]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- We need to descent into function bodies to build the 'OccMap' with all occurrences in the--- function bodies.  Due to the side effects in the construction of the occurrence map and, more--- importantly, the dependence of the second phase on /global/ occurrence information, we may not--- delay the body traversals by putting them under a lambda.  Hence, we apply each function, to--- traverse its body and use a /dummy abstraction/ of the result.------ For example, given a function 'f', we traverse 'f (Tag 0)', which yields a transformed body 'e'.--- As the result of the traversal of the overall function, we use 'const e'.  Hence, it is crucial--- that the 'Tag' supplied during the initial traversal is already the one required by the HOAS to--- de Bruijn conversion in 'convertSharingAcc' — any subsequent application of 'const e' will only--- yield 'e' with the embedded 'Tag 0' of the original application.  During sharing recovery, we--- float /all/ free variables ('Atag' and 'Tag') out to construct the initial environment for--- producing de Bruijn indices, which replaces them by 'AvarSharing' or 'VarSharing' nodes.  Hence,--- the tag values only serve the purpose of determining the ordering in that initial environment.--- They are /not/ directly used to compute the de Brujin indices.----makeOccMapAcc-    :: Typeable arrs-    => Config-    -> Level-    -> Acc arrs-    -> IO (UnscopedAcc arrs, OccMap Acc)-makeOccMapAcc config lvl acc = do-  traceLine "makeOccMapAcc" "Enter"-  accOccMap             <- newASTHashTable-  (acc', _)             <- makeOccMapSharingAcc config accOccMap lvl acc-  frozenAccOccMap       <- freezeOccMap accOccMap-  traceLine "makeOccMapAcc" "Exit"-  return (acc', frozenAccOccMap)---makeOccMapSharingAcc-    :: Typeable arrs-    => Config-    -> OccMapHash Acc-    -> Level-    -> Acc arrs-    -> IO (UnscopedAcc arrs, Int)-makeOccMapSharingAcc config accOccMap = traverseAcc-  where-    traverseFun1 :: (Elt a, Typeable b) => Level -> (Exp a -> Exp b) -> IO (Exp a -> RootExp b, Int)-    traverseFun1 = makeOccMapFun1 config accOccMap--    traverseFun2 :: (Elt a, Elt b, Typeable c)-                 => Level-                 -> (Exp a -> Exp b -> Exp c)-                 -> IO (Exp a -> Exp b -> RootExp c, Int)-    traverseFun2 = makeOccMapFun2 config accOccMap--    traverseAfun1 :: (Arrays a, Typeable b) => Level -> (Acc a -> Acc b) -> IO (Acc a -> UnscopedAcc b, Int)-    traverseAfun1 = makeOccMapAfun1 config accOccMap--    traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int)-    traverseExp = makeOccMapExp config accOccMap--    traverseBoundary-        :: Level-        -> PreBoundary Acc Exp t-        -> IO (PreBoundary UnscopedAcc RootExp t, Int)-    traverseBoundary lvl bndy =-      case bndy of-        Clamp      -> return (Clamp, 0)-        Mirror     -> return (Mirror, 0)-        Wrap       -> return (Wrap, 0)-        Constant v -> return (Constant v, 0)-        Function f -> do-          (f', h) <- traverseFun1 lvl f-          return (Function f', h)--    -- traverseSeq :: forall arrs. Typeable arrs-    --             => Level -> Seq arrs-    --             -> IO (RootSeq arrs, Int)-    -- traverseSeq = makeOccMapRootSeq config accOccMap--    traverseAcc :: forall arrs. Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)-    traverseAcc lvl acc@(Acc pacc)-      = mfix $ \ ~(_, height) -> do-          -- Compute stable name and enter it into the occurrence map-          ---          sn                         <- makeStableAST acc-          heightIfRepeatedOccurrence <- enterOcc accOccMap (StableASTName sn) height--          traceLine (showPreAccOp pacc) $ do-            let hash = show (hashStableName sn)-            case heightIfRepeatedOccurrence of-              Just height -> "REPEATED occurrence (sn = " ++ hash ++ "; height = " ++ show height ++ ")"-              Nothing     -> "first occurrence (sn = " ++ hash ++ ")"--          -- Reconstruct the computation in shared form.-          ---          -- In case of a repeated occurrence, the height comes from the occurrence map; otherwise-          -- it is computed by the traversal function passed in 'newAcc'. See also 'enterOcc'.-          ---          -- NB: This function can only be used in the case alternatives below; outside of the-          --     case we cannot discharge the 'Arrays arrs' constraint.-          ---          let reconstruct :: Arrays arrs-                          => IO (PreAcc UnscopedAcc RootExp arrs, Int)-                          -> IO (UnscopedAcc arrs, Int)-              reconstruct newAcc-                = case heightIfRepeatedOccurrence of-                    Just height | recoverAccSharing config-                      -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height)), height)-                    _ -> do (acc, height) <- newAcc-                            return (UnscopedAcc [] (AccSharing (StableNameHeight sn height) acc), height)--          case pacc of-            Atag i                      -> reconstruct $ return (Atag i, 0)           -- height is 0!-            Pipe afun1 afun2 acc        -> reconstruct $ do-                                             (afun1', h1) <- traverseAfun1 lvl afun1-                                             (afun2', h2) <- traverseAfun1 lvl afun2-                                             (acc', h3)   <- traverseAcc lvl acc-                                             return (Pipe afun1' afun2' acc'-                                                    , h1 `max` h2 `max` h3 + 1)-            Aforeign ff afun acc        -> reconstruct $ travA (Aforeign ff afun) acc-            Acond e acc1 acc2           -> reconstruct $ do-                                             (e'   , h1) <- traverseExp lvl e-                                             (acc1', h2) <- traverseAcc lvl acc1-                                             (acc2', h3) <- traverseAcc lvl acc2-                                             return (Acond e' acc1' acc2', h1 `max` h2 `max` h3 + 1)-            Awhile pred iter init       -> reconstruct $ do-                                             (pred', h1) <- traverseAfun1 lvl pred-                                             (iter', h2) <- traverseAfun1 lvl iter-                                             (init', h3) <- traverseAcc lvl init-                                             return (Awhile pred' iter' init'-                                                    , h1 `max` h2 `max` h3 + 1)--            Atuple tup                  -> reconstruct $ do-                                             (tup', h) <- travAtup tup-                                             return (Atuple tup', h)-            Aprj ix a                   -> reconstruct $ travA (Aprj ix) a--            Use arr                     -> reconstruct $ return (Use arr, 1)-            Unit e                      -> reconstruct $ do-                                             (e', h) <- traverseExp lvl e-                                             return (Unit e', h + 1)-            Generate e f                -> reconstruct $ do-                                             (e', h1) <- traverseExp lvl e-                                             (f', h2) <- traverseFun1 lvl f-                                             return (Generate e' f', h1 `max` h2 + 1)-            Reshape e acc               -> reconstruct $ travEA Reshape e acc-            Replicate e acc             -> reconstruct $ travEA Replicate e acc-            Slice acc e                 -> reconstruct $ travEA (flip Slice) e acc-            Map f acc                   -> reconstruct $ do-                                             (f'  , h1) <- traverseFun1 lvl f-                                             (acc', h2) <- traverseAcc lvl acc-                                             return (Map f' acc', h1 `max` h2 + 1)-            ZipWith f acc1 acc2         -> reconstruct $ travF2A2 ZipWith f acc1 acc2-            Fold f e acc                -> reconstruct $ travF2EA Fold f e acc-            Fold1 f acc                 -> reconstruct $ travF2A Fold1 f acc-            FoldSeg f e acc1 acc2       -> reconstruct $ do-                                             (f'   , h1) <- traverseFun2 lvl f-                                             (e'   , h2) <- traverseExp lvl e-                                             (acc1', h3) <- traverseAcc lvl acc1-                                             (acc2', h4) <- traverseAcc lvl acc2-                                             return (FoldSeg f' e' acc1' acc2',-                                                     h1 `max` h2 `max` h3 `max` h4 + 1)-            Fold1Seg f acc1 acc2        -> reconstruct $ travF2A2 Fold1Seg f acc1 acc2-            Scanl f e acc               -> reconstruct $ travF2EA Scanl f e acc-            Scanl' f e acc              -> reconstruct $ travF2EA Scanl' f e acc-            Scanl1 f acc                -> reconstruct $ travF2A Scanl1 f acc-            Scanr f e acc               -> reconstruct $ travF2EA Scanr f e acc-            Scanr' f e acc              -> reconstruct $ travF2EA Scanr' f e acc-            Scanr1 f acc                -> reconstruct $ travF2A Scanr1 f acc-            Permute c acc1 p acc2       -> reconstruct $ do-                                             (c'   , h1) <- traverseFun2 lvl c-                                             (p'   , h2) <- traverseFun1 lvl p-                                             (acc1', h3) <- traverseAcc lvl acc1-                                             (acc2', h4) <- traverseAcc lvl acc2-                                             return (Permute c' acc1' p' acc2',-                                                     h1 `max` h2 `max` h3 `max` h4 + 1)-            Backpermute e p acc         -> reconstruct $ do-                                             (e'  , h1) <- traverseExp lvl e-                                             (p'  , h2) <- traverseFun1 lvl p-                                             (acc', h3) <- traverseAcc lvl acc-                                             return (Backpermute e' p' acc', h1 `max` h2 `max` h3 + 1)-            Stencil s bnd acc           -> reconstruct $ do-                                             (s'  , h1) <- makeOccMapStencil1 config accOccMap acc lvl s-                                             (bnd', h2) <- traverseBoundary lvl bnd-                                             (acc', h3) <- traverseAcc lvl acc-                                             return (Stencil s' bnd' acc', h1 `max` h2 `max` h3 + 1)-            Stencil2 s bnd1 acc1-                       bnd2 acc2        -> reconstruct $ do-                                             (s'   , h1) <- makeOccMapStencil2 config accOccMap acc1 acc2 lvl s-                                             (bnd1', h2) <- traverseBoundary lvl bnd1-                                             (acc1', h3) <- traverseAcc lvl acc1-                                             (bnd2', h4) <- traverseBoundary lvl bnd2-                                             (acc2', h5) <- traverseAcc lvl acc2-                                             return (Stencil2 s' bnd1' acc1' bnd2' acc2',-                                                     h1 `max` h2 `max` h3 `max` h4 `max` h5 + 1)-            -- Collect s                   -> reconstruct $ do-            --                                  (s', h) <- traverseSeq lvl s-            --                                  return (Collect s', h + 1)---      where-        travA :: Arrays arrs'-              => (UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)-              -> Acc arrs' -> IO (PreAcc UnscopedAcc RootExp arrs, Int)-        travA c acc-          = do-              (acc', h) <- traverseAcc lvl acc-              return (c acc', h + 1)--        travEA :: (Typeable b, Arrays arrs')-               => (RootExp b -> UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)-               -> Exp b -> Acc arrs' -> IO (PreAcc UnscopedAcc RootExp arrs, Int)-        travEA c exp acc-          = do-              (exp', h1) <- traverseExp lvl exp-              (acc', h2) <- traverseAcc lvl acc-              return (c exp' acc', h1 `max` h2 + 1)--        travF2A :: (Elt b, Elt c, Typeable d, Arrays arrs')-                => ((Exp b -> Exp c -> RootExp d) -> UnscopedAcc arrs'-                    -> PreAcc UnscopedAcc RootExp arrs)-                -> (Exp b -> Exp c -> Exp d) -> Acc arrs'-                -> IO (PreAcc UnscopedAcc RootExp arrs, Int)-        travF2A c fun acc-          = do-              (fun', h1) <- traverseFun2 lvl fun-              (acc', h2) <- traverseAcc lvl acc-              return (c fun' acc', h1 `max` h2 + 1)--        travF2EA :: (Elt b, Elt c, Typeable d, Typeable e, Arrays arrs')-                 => ((Exp b -> Exp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)-                 -> (Exp b -> Exp c -> Exp d) -> Exp e -> Acc arrs'-                 -> IO (PreAcc UnscopedAcc RootExp arrs, Int)-        travF2EA c fun exp acc-          = do-              (fun', h1) <- traverseFun2 lvl fun-              (exp', h2) <- traverseExp lvl exp-              (acc', h3) <- traverseAcc lvl acc-              return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1)--        travF2A2 :: (Elt b, Elt c, Typeable d, Arrays arrs1, Arrays arrs2)-                 => ((Exp b -> Exp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreAcc UnscopedAcc RootExp arrs)-                 -> (Exp b -> Exp c -> Exp d) -> Acc arrs1 -> Acc arrs2-                 -> IO (PreAcc UnscopedAcc RootExp arrs, Int)-        travF2A2 c fun acc1 acc2-          = do-              (fun' , h1) <- traverseFun2 lvl fun-              (acc1', h2) <- traverseAcc lvl acc1-              (acc2', h3) <- traverseAcc lvl acc2-              return (c fun' acc1' acc2', h1 `max` h2 `max` h3 + 1)--        travAtup :: Atuple Acc a-                 -> IO (Atuple UnscopedAcc a, Int)-        travAtup NilAtup          = return (NilAtup, 1)-        travAtup (SnocAtup tup a) = do-          (tup', h1) <- travAtup tup-          (a',   h2) <- traverseAcc lvl a-          return (SnocAtup tup' a', h1 `max` h2 + 1)--makeOccMapAfun1 :: (Arrays a, Typeable b)-                => Config-                -> OccMapHash Acc-                -> Level-                -> (Acc a -> Acc b)-                -> IO (Acc a -> UnscopedAcc b, Int)-makeOccMapAfun1 config accOccMap lvl f = do-  let x = Acc (Atag lvl)-  ---  (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+1) (f x)-  return (const (UnscopedAcc [lvl] body), height)--{---makeOccMapAfun2 :: (Arrays a, Arrays b, Typeable c)-                => Config-                -> OccMapHash Acc-                -> Level-                -> (Acc a -> Acc b -> Acc c)-                -> IO (Acc a -> Acc b -> UnscopedAcc c, Int)-makeOccMapAfun2 config accOccMap lvl f = do-  let x = Acc (Atag (lvl + 1))-      y = Acc (Atag (lvl + 0))-  ---  (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+2) (f x y)-  return (\ _ _ -> (UnscopedAcc [lvl, lvl+1] body), height)--makeOccMapAfun3 :: (Arrays a, Arrays b, Arrays c, Typeable d)-                => Config-                -> OccMapHash Acc-                -> Level-                -> (Acc a -> Acc b -> Acc c -> Acc d)-                -> IO (Acc a -> Acc b -> Acc c -> UnscopedAcc d, Int)-makeOccMapAfun3 config accOccMap lvl f = do-  let x = Acc (Atag (lvl + 2))-      y = Acc (Atag (lvl + 1))-      z = Acc (Atag (lvl + 0))-  ---  (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+3) (f x y z)-  return (\ _ _ _ -> (UnscopedAcc [lvl, lvl+1, lvl+2] body), height)---}---- Generate occupancy information for scalar functions and expressions. Helper--- functions wrapping around 'makeOccMapRootExp' with more specific types.------ See Note [Traversing functions and side effects]----makeOccMapExp-    :: Typeable e-    => Config-    -> OccMapHash Acc-    -> Level-    -> Exp e-    -> IO (RootExp e, Int)-makeOccMapExp config accOccMap lvl = makeOccMapRootExp config accOccMap lvl []--makeOccMapFun1-    :: (Elt a, Typeable b)-    => Config-    -> OccMapHash Acc-    -> Level-    -> (Exp a -> Exp b)-    -> IO (Exp a -> RootExp b, Int)-makeOccMapFun1 config accOccMap lvl f = do-  let x = Exp (Tag lvl)-  ---  (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (f x)-  return (const body, height)--makeOccMapFun2-    :: (Elt a, Elt b, Typeable c)-    => Config-    -> OccMapHash Acc-    -> Level-    -> (Exp a -> Exp b -> Exp c)-    -> IO (Exp a -> Exp b -> RootExp c, Int)-makeOccMapFun2 config accOccMap lvl f = do-  let x = Exp (Tag (lvl+1))-      y = Exp (Tag lvl)-  ---  (body, height) <- makeOccMapRootExp config accOccMap (lvl+2) [lvl, lvl+1] (f x y)-  return (\_ _ -> body, height)--makeOccMapStencil1-    :: forall sh a b stencil. (Stencil sh a stencil, Typeable b)-    => Config-    -> OccMapHash Acc-    -> Acc (Array sh a)         {- dummy -}-    -> Level-    -> (stencil -> Exp b)-    -> IO (stencil -> RootExp b, Int)-makeOccMapStencil1 config accOccMap _ lvl stencil = do-  let x = Exp (Tag lvl)-      f = stencil . stencilPrj (undefined::sh) (undefined::a)-  ---  (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (f x)-  return (const body, height)--makeOccMapStencil2-    :: forall sh a b c stencil1 stencil2. (Stencil sh a stencil1, Stencil sh b stencil2, Typeable c)-    => Config-    -> OccMapHash Acc-    -> Acc (Array sh a)         {- dummy -}-    -> Acc (Array sh b)         {- dummy -}-    -> Level-    -> (stencil1 -> stencil2 -> Exp c)-    -> IO (stencil1 -> stencil2 -> RootExp c, Int)-makeOccMapStencil2 config accOccMap _ _ lvl stencil = do-  let x         = Exp (Tag (lvl+1))-      y         = Exp (Tag lvl)-      f a b     = stencil (stencilPrj (undefined::sh) (undefined::a) a)-                          (stencilPrj (undefined::sh) (undefined::b) b)-  ---  (body, height) <- makeOccMapRootExp config accOccMap (lvl+2) [lvl, lvl+1] (f x y)-  return (\_ _ -> body, height)----- Generate sharing information for expressions embedded in Acc computations.--- Expressions are annotated with:------  1) the tags of free scalar variables (for scalar functions)---  2) a local occurrence map for that expression.----makeOccMapRootExp-    :: Typeable e-    => Config-    -> OccMapHash Acc-    -> Level                            -- The level of currently bound scalar variables-    -> [Int]                            -- The tags of newly introduced free scalar variables in this expression-    -> Exp e-    -> IO (RootExp e, Int)-makeOccMapRootExp config accOccMap lvl fvs exp = do-  traceLine "makeOccMapRootExp" "Enter"-  expOccMap                     <- newASTHashTable-  (UnscopedExp [] exp', height) <- makeOccMapSharingExp config accOccMap expOccMap lvl exp-  frozenExpOccMap               <- freezeOccMap expOccMap-  traceLine "makeOccMapRootExp" "Exit"-  return (RootExp frozenExpOccMap (UnscopedExp fvs exp'), height)----- Generate sharing information for an open scalar expression.----makeOccMapSharingExp-    :: Typeable e-    => Config-    -> OccMapHash Acc-    -> OccMapHash Exp-    -> Level                            -- The level of currently bound variables-    -> Exp e-    -> IO (UnscopedExp e, Int)-makeOccMapSharingExp config accOccMap expOccMap = travE-  where-    travE :: forall a. Typeable a => Level -> Exp a -> IO (UnscopedExp a, Int)-    travE lvl exp@(Exp pexp)-      = mfix $ \ ~(_, height) -> do-          -- Compute stable name and enter it into the occurrence map-          ---          sn                         <- makeStableAST exp-          heightIfRepeatedOccurrence <- enterOcc expOccMap (StableASTName sn) height--          traceLine (showPreExpOp pexp) $ do-            let hash = show (hashStableName sn)-            case heightIfRepeatedOccurrence of-              Just height -> "REPEATED occurrence (sn = " ++ hash ++ "; height = " ++ show height ++ ")"-              Nothing     -> "first occurrence (sn = " ++ hash ++ ")"--          -- Reconstruct the computation in shared form.-          ---          -- In case of a repeated occurrence, the height comes from the occurrence map; otherwise-          -- it is computed by the traversal function passed in 'newExp'.  See also 'enterOcc'.-          ---          -- NB: This function can only be used in the case alternatives below; outside of the-          --     case we cannot discharge the 'Elt a' constraint.-          ---          let reconstruct :: Elt a-                          => IO (PreExp UnscopedAcc UnscopedExp a, Int)-                          -> IO (UnscopedExp a, Int)-              reconstruct newExp-                = case heightIfRepeatedOccurrence of-                    Just height | recoverExpSharing config-                      -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height)), height)-                    _ -> do (exp, height) <- newExp-                            return (UnscopedExp [] (ExpSharing (StableNameHeight sn height) exp), height)--          case pexp of-            Tag i               -> reconstruct $ return (Tag i, 0)      -- height is 0!-            Const c             -> reconstruct $ return (Const c, 1)-            Tuple tup           -> reconstruct $ do-                                     (tup', h) <- travTup tup-                                     return (Tuple tup', h)-            Prj i e             -> reconstruct $ travE1 (Prj i) e-            IndexNil            -> reconstruct $ return (IndexNil, 1)-            IndexCons ix i      -> reconstruct $ travE2 IndexCons ix i-            IndexHead i         -> reconstruct $ travE1 IndexHead i-            IndexTail ix        -> reconstruct $ travE1 IndexTail ix-            IndexAny            -> reconstruct $ return (IndexAny, 1)-            ToIndex sh ix       -> reconstruct $ travE2 ToIndex sh ix-            FromIndex sh e      -> reconstruct $ travE2 FromIndex sh e-            Cond e1 e2 e3       -> reconstruct $ travE3 Cond e1 e2 e3-            While p iter init   -> reconstruct $ do-                                     (p'   , h1) <- traverseFun1 lvl p-                                     (iter', h2) <- traverseFun1 lvl iter-                                     (init', h3) <- travE lvl init-                                     return (While p' iter' init', h1 `max` h2 `max` h3 + 1)-            PrimConst c         -> reconstruct $ return (PrimConst c, 1)-            PrimApp p e         -> reconstruct $ travE1 (PrimApp p) e-            Index a e           -> reconstruct $ travAE Index a e-            LinearIndex a i     -> reconstruct $ travAE LinearIndex a i-            Shape a             -> reconstruct $ travA Shape a-            ShapeSize e         -> reconstruct $ travE1 ShapeSize e-            Intersect sh1 sh2   -> reconstruct $ travE2 Intersect sh1 sh2-            Union sh1 sh2       -> reconstruct $ travE2 Union sh1 sh2-            Foreign ff f e      -> reconstruct $ do-                                      (e', h) <- travE lvl e-                                      return  (Foreign ff f e', h+1)--      where-        traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)-        traverseAcc = makeOccMapSharingAcc config accOccMap--        traverseFun1 :: (Elt a, Typeable b)-                     => Level-                     -> (Exp a -> Exp b)-                     -> IO (Exp a -> UnscopedExp b, Int)-        traverseFun1 lvl f-          = do-              let x = Exp (Tag lvl)-              (UnscopedExp [] body, height) <- travE (lvl+1) (f x)-              return (const (UnscopedExp [lvl] body), height + 1)---        travE1 :: Typeable b => (UnscopedExp b -> PreExp UnscopedAcc UnscopedExp a) -> Exp b-               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)-        travE1 c e-          = do-              (e', h) <- travE lvl e-              return (c e', h + 1)--        travE2 :: (Typeable b, Typeable c)-               => (UnscopedExp b -> UnscopedExp c -> PreExp UnscopedAcc UnscopedExp a)-               -> Exp b -> Exp c-               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)-        travE2 c e1 e2-          = do-              (e1', h1) <- travE lvl e1-              (e2', h2) <- travE lvl e2-              return (c e1' e2', h1 `max` h2 + 1)--        travE3 :: (Typeable b, Typeable c, Typeable d)-               => (UnscopedExp b -> UnscopedExp c -> UnscopedExp d -> PreExp UnscopedAcc UnscopedExp a)-               -> Exp b -> Exp c -> Exp d-               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)-        travE3 c e1 e2 e3-          = do-              (e1', h1) <- travE lvl e1-              (e2', h2) <- travE lvl e2-              (e3', h3) <- travE lvl e3-              return (c e1' e2' e3', h1 `max` h2 `max` h3 + 1)--        travA :: Typeable b => (UnscopedAcc b -> PreExp UnscopedAcc UnscopedExp a) -> Acc b-              -> IO (PreExp UnscopedAcc UnscopedExp a, Int)-        travA c acc-          = do-              (acc', h) <- traverseAcc lvl acc-              return (c acc', h + 1)--        travAE :: (Typeable b, Typeable c)-               => (UnscopedAcc b -> UnscopedExp c -> PreExp UnscopedAcc UnscopedExp a)-               -> Acc b -> Exp c-               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)-        travAE c acc e-          = do-              (acc', h1) <- traverseAcc lvl acc-              (e'  , h2) <- travE lvl e-              return (c acc' e', h1 `max` h2 + 1)--        travTup :: Tuple Exp tup -> IO (Tuple UnscopedExp tup, Int)-        travTup NilTup          = return (NilTup, 1)-        travTup (SnocTup tup e) = do-                                    (tup', h1) <- travTup tup-                                    (e'  , h2) <- travE lvl e-                                    return (SnocTup tup' e', h1 `max` h2 + 1)---{---makeOccMapRootSeq-    :: Typeable arrs-    => Config-    -> OccMapHash Acc-    -> Level-    -> Seq arrs-    -> IO (RootSeq arrs, Int)-makeOccMapRootSeq config accOccMap lvl seq = do-  traceLine "makeOccMapRootSeq" "Enter"-  seqOccMap       <- newASTHashTable-  (seq', height)  <- makeOccMapSharingSeq config accOccMap seqOccMap lvl seq-  frozenSeqOccMap <- freezeOccMap seqOccMap-  traceLine "makeOccMapRootSeq" "Exit"-  return (RootSeq frozenSeqOccMap seq', height)---- Generate sharing information for an open sequence expression.----makeOccMapSharingSeq-    :: Typeable e-    => Config-    -> OccMapHash Acc-    -> OccMapHash Seq-    -> Level                            -- The level of currently bound variables-    -> Seq e-    -> IO (UnscopedSeq e, Int)-makeOccMapSharingSeq config accOccMap seqOccMap = traverseSeq-  where-    traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)-    traverseAcc = makeOccMapSharingAcc config accOccMap--    traverseAfun1 :: (Arrays a, Typeable b) => Level -> (Acc a -> Acc b) -> IO (Acc a -> UnscopedAcc b, Int)-    traverseAfun1 = makeOccMapAfun1 config accOccMap--    traverseAfun2 :: (Arrays a, Arrays b, Typeable c) => Level -> (Acc a -> Acc b -> Acc c) -> IO (Acc a -> Acc b -> UnscopedAcc c, Int)-    traverseAfun2 = makeOccMapAfun2 config accOccMap--    traverseAfun3 :: (Arrays a, Arrays b, Arrays c, Typeable d) => Level -> (Acc a -> Acc b -> Acc c -> Acc d) -> IO (Acc a -> Acc b -> Acc c -> UnscopedAcc d, Int)-    traverseAfun3 = makeOccMapAfun3 config accOccMap--    traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int)-    traverseExp = makeOccMapExp config accOccMap--    traverseFun2 :: (Elt a, Elt b, Typeable c)-                 => Level-                 -> (Exp a -> Exp b -> Exp c)-                 -> IO (Exp a -> Exp b -> RootExp c, Int)-    traverseFun2 = makeOccMapFun2 config accOccMap--    traverseTup :: Level -> Atuple Seq tup -> IO (Atuple UnscopedSeq tup, Int)-    traverseTup _   NilAtup          = return (NilAtup, 1)-    traverseTup lvl (SnocAtup tup s) = do-                                        (tup', h1) <- traverseTup lvl tup-                                        (s'  , h2) <- traverseSeq lvl s-                                        return (SnocAtup tup' s', h1 `max` h2 + 1)--    traverseSeq :: forall arrs. Typeable arrs => Level -> Seq arrs -> IO (UnscopedSeq arrs, Int)-    traverseSeq lvl acc@(Seq seq)-      = mfix $ \ ~(_, height) -> do-          -- Compute stable name and enter it into the occurrence map-          ---          sn                         <- makeStableAST acc-          heightIfRepeatedOccurrence <- enterOcc seqOccMap (StableASTName sn) height--          traceLine (showPreSeqOp seq) $ do-            let hash = show (hashStableName sn)-            case heightIfRepeatedOccurrence of-              Just height -> "REPEATED occurrence (sn = " ++ hash ++ "; height = " ++ show height ++ ")"-              Nothing     -> "first occurrence (sn = " ++ hash ++ ")"--          -- Reconstruct the computation in shared form.-          ---          -- In case of a repeated occurrence, the height comes from the occurrence map; otherwise-          -- it is computed by the traversal function passed in 'newAcc'. See also 'enterOcc'.-          ---          -- NB: This function can only be used in the case alternatives below; outside of the-          --     case we cannot discharge the 'Arrays arrs' constraint.-          ---          let producer :: (arrs ~ [a], Arrays a)-                       => IO (PreSeq UnscopedAcc UnscopedSeq RootExp arrs, Int)-                       -> IO (UnscopedSeq arrs, Int)-              producer newSeq-                = case heightIfRepeatedOccurrence of-                    Just height | recoverSeqSharing config-                      -> return (UnscopedSeq (SvarSharing (StableNameHeight sn height)), height)-                    _ -> do (seq, height) <- newSeq-                            return (UnscopedSeq (SeqSharing (StableNameHeight sn height) seq), height)--          let consumer :: IO (PreSeq UnscopedAcc UnscopedSeq RootExp arrs, Int)-                       -> IO (UnscopedSeq arrs, Int)-              consumer newSeq-                = do (seq, height) <- newSeq-                     return (UnscopedSeq (SeqSharing (StableNameHeight sn height) seq), height)--          case seq of-            StreamIn arrs -> producer $ return (StreamIn arrs, 1)-            ToSeq sl acc -> producer $ do-              (acc', h1) <- traverseAcc lvl acc-              return (ToSeq sl acc', h1 + 1)-            MapSeq afun s -> producer $ do-              (afun', h1) <- traverseAfun1 lvl afun-              (s'   , h2) <- traverseSeq lvl s-              return (MapSeq afun' s', h1 `max` h2 + 1)-            ZipWithSeq afun s1 s2 -> producer $ do-              (afun', h1) <- traverseAfun2 lvl afun-              (s1'  , h2) <- traverseSeq lvl s1-              (s2'  , h3) <- traverseSeq lvl s2-              return (ZipWithSeq afun' s1' s2', h1 `max` h2 `max` h3 + 1)-            ScanSeq fun e s -> producer $ do-              (fun', h1) <- traverseFun2 lvl fun-              (e',  h2) <- traverseExp lvl e-              (s'   , h3) <- traverseSeq lvl s-              return (ScanSeq fun' e' s', h1 `max` h2 `max` h3 + 1)-            FoldSeq fun e s -> consumer $ do-              (fun', h1) <- traverseFun2 lvl fun-              (e'  , h2) <- traverseExp lvl e-              (s'  , h3) <- traverseSeq lvl s-              return (FoldSeq fun' e' s', h1 `max` h2 `max` h3 + 1)-            FoldSeqFlatten afun acc s -> consumer $ do-              (afun', h1) <- traverseAfun3 lvl afun-              (acc',  h2) <- traverseAcc lvl acc-              (s'   , h3) <- traverseSeq lvl s-              return (FoldSeqFlatten afun' acc' s', h1 `max` h2 `max` h3 + 1)-            Stuple t -> consumer $ do-              (t', h1) <- traverseTup lvl t-              return (Stuple t', h1 + 1)---}----- Type used to maintain how often each shared subterm, so far, occurred during a bottom-up sweep,--- as well as the relation between subterms. It is comprised of a list of terms and a graph giving--- their relation.------   Invariants of the list:---   - If one shared term 's' is itself a subterm of another shared term 't', then 's' must occur---     *after* 't' in the list.---   - No shared term occurs twice.---   - A term may have a final occurrence count of only 1 iff it is either a free variable ('Atag'---     or 'Tag') or an array computation lifted out of an expression.---   - All 'Exp' node counts precede all 'Acc' node counts as we don't share 'Exp' nodes across 'Acc'---     nodes. Similarly, all 'Seq' nodes precede 'Acc' nodes and 'Exp' nodes precede 'Seq' nodes.------ We determine the subterm property by using the tree height in 'StableNameHeight'.  Trees get--- smaller towards the end of a 'NodeCounts' list.  The height of free variables ('Atag' or 'Tag')--- is 0, whereas other leaves have height 1.  This guarantees that all free variables are at the end--- of the 'NodeCounts' list.------ The graph is represented as a map where a stable name 'a' is mapped to a set of stables names 'b'--- such that if there exists a edge from 'a' to 'c' that 'c' is contained within 'b'.------  Properties of the graph:---  - There exists an edge from 'a' to 'b' if the term 'a' names is a subterm of the term named by---    'b'.------ To ensure the list invariant and the graph properties are preserved over merging node counts from--- sibling subterms, the function '(+++)' must be used.----type NodeCounts = ([NodeCount], Map.HashMap NodeName (Set.HashSet NodeName))--data NodeName where-  NodeName :: Typeable a => StableName a -> NodeName--instance Eq NodeName where-  (NodeName sn1) == (NodeName sn2) | Just sn2' <- gcast sn2 = sn1 == sn2'-                                   | otherwise              = False--instance Hashable NodeName where-  hashWithSalt hash (NodeName sn1) = hash + hashStableName sn1--instance Show NodeName where-  show (NodeName sn) = show (hashStableName sn)--data NodeCount = AccNodeCount StableSharingAcc Int-               | ExpNodeCount StableSharingExp Int-               -- SeqNodeCount StableSharingSeq Int-               deriving Show---- Empty node counts----noNodeCounts :: NodeCounts-noNodeCounts = ([], Map.empty)---- Insert an Acc node into the node counts, assuming that it is a superterm of the all the existing--- nodes.------ TODO: Perform cycle detection here.-insertAccNode :: StableSharingAcc -> NodeCounts -> NodeCounts-insertAccNode ssa@(StableSharingAcc (StableNameHeight sn _) _) (subterms,g)-  = ([AccNodeCount ssa 1], g') +++ (subterms,g)-  where-    k  = NodeName sn-    hs = map nodeName subterms-    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs]---- Insert an Exp node into the node counts, assuming that it is a superterm of the all the existing--- nodes.------ TODO: Perform cycle detection here.-insertExpNode :: StableSharingExp -> NodeCounts -> NodeCounts-insertExpNode ssa@(StableSharingExp (StableNameHeight sn _) _) (subterms,g)-  = ([ExpNodeCount ssa 1], g') +++ (subterms,g)-  where-    k  = NodeName sn-    hs = map nodeName subterms-    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs]--{----- Insert an Seq node into the node counts, assuming that it is a superterm of the all the existing--- nodes.------ TODO: Perform cycle detection here.-insertSeqNode :: StableSharingSeq -> NodeCounts -> NodeCounts-insertSeqNode ssa@(StableSharingSeq (StableNameHeight sn _) _) (subterms,g)-  = ([SeqNodeCount ssa 1], g') +++ (subterms,g)-  where-    k  = NodeName sn-    hs = map nodeName subterms-    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs]---}---- Remove nodes that aren't in the list from the graph.------ RCE: This is no longer necessary when NDP is supported.-cleanCounts :: NodeCounts -> NodeCounts-cleanCounts (ns, g) = (ns, Map.fromList $ [(h, Set.filter (flip elem hs) (g Map.! h)) | h <- hs ])-  where-    hs = (map nodeName ns)--nodeName :: NodeCount -> NodeName-nodeName (AccNodeCount (StableSharingAcc (StableNameHeight sn _) _) _) = NodeName sn-nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeName sn--- nodeName (SeqNodeCount (StableSharingSeq (StableNameHeight sn _) _) _) = NodeName sn---- Combine node counts that belong to the same node.------ * We assume that the list invariant —subterms follow their parents— holds for both arguments and---   guarantee that it still holds for the result.--- * In the same manner, we assume that all 'Exp' node counts precede 'Acc' node counts and---   guarantee that this also hold for the result.------ RCE: The list combination should be able to be performed as a more efficient merge.----(+++) :: NodeCounts -> NodeCounts -> NodeCounts-(ns1,g1) +++ (ns2,g2) = (foldr insert ns1 ns2, Map.unionWith Set.union g1 g2)-  where-    insert x               []                         = [x]-    insert x@(AccNodeCount sa1 count1) ys@(y@(AccNodeCount sa2 count2) : ys')-      | sa1 == sa2          = AccNodeCount (sa1 `pickNoneAvar` sa2) (count1 + count2) : ys'-      | sa1 `higherSSA` sa2 = x : ys-      | otherwise           = y : insert x ys'-    insert x@(ExpNodeCount se1 count1) ys@(y@(ExpNodeCount se2 count2) : ys')-      | se1 == se2          = ExpNodeCount (se1 `pickNoneVar` se2) (count1 + count2) : ys'-      | se1 `higherSSE` se2 = x : ys-      | otherwise           = y : insert x ys'-    -- insert x@(SeqNodeCount se1 count1) ys@(y@(SeqNodeCount se2 count2) : ys')-    --   | se1 == se2          = SeqNodeCount (se1 `pickNoneSvar` se2) (count1 + count2) : ys'-    --   | se1 `higherSSS` se2 = x : ys-    --   | otherwise           = y : insert x ys'-    insert x@(AccNodeCount _ _) (y@(ExpNodeCount _ _) : ys')-      = y : insert x ys'-    insert x@(ExpNodeCount _ _) (y@(AccNodeCount _ _) : ys')-      = x : insert y ys'-    -- insert x@(SeqNodeCount _ _) (y@(ExpNodeCount _ _) : ys')-    --   = y : insert x ys'-    -- insert x@(ExpNodeCount _ _) (y@(SeqNodeCount _ _) : ys')-    --   = x : insert y ys'-    -- insert x@(AccNodeCount _ _) (y@(SeqNodeCount _ _) : ys')-    --   = y : insert x ys'-    -- insert x@(SeqNodeCount _ _) (y@(AccNodeCount _ _) : ys')-    --   = x : insert y ys'--    (StableSharingAcc _ (AvarSharing _)) `pickNoneAvar` sa2  = sa2-    sa1                                  `pickNoneAvar` _sa2 = sa1--    (StableSharingExp _ (VarSharing _))  `pickNoneVar`  sa2  = sa2-    sa1                                  `pickNoneVar`  _sa2 = sa1--    -- pickNoneSvar :: StableSharingSeq -> StableSharingSeq -> StableSharingSeq-    -- (StableSharingSeq _ (SvarSharing _)) `pickNoneSvar` sa2  = sa2-    -- sa1                                  `pickNoneSvar` _sa2 = sa1---- Build an initial environment for the tag values given in the first argument for traversing an--- array expression.  The 'StableSharingAcc's for all tags /actually used/ in the expressions are--- in the second argument. (Tags are not used if a bound variable has no usage occurrence.)------ Bail out if any tag occurs multiple times as this indicates that the sharing of an argument--- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments--- at 'determineScopesAcc'.----buildInitialEnvAcc :: [Level] -> [StableSharingAcc] -> [StableSharingAcc]-buildInitialEnvAcc tags sas = map (lookupSA sas) tags-  where-    lookupSA sas tag1-      = case filter hasTag sas of-          []   -> noStableSharing    -- tag is not used in the analysed expression-          [sa] -> sa                 -- tag has a unique occurrence-          sas2 -> $internalError "buildInitialEnvAcc"-                $ "Encountered duplicate 'ATag's\n  " ++ intercalate ", " (map showSA sas2)-      where-        hasTag (StableSharingAcc _ (AccSharing _ (Atag tag2))) = tag1 == tag2-        hasTag sa-          = $internalError "buildInitialEnvAcc"-          $ "Encountered a node that is not a plain 'Atag'\n  " ++ showSA sa--        noStableSharing :: StableSharingAcc-        noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ())--    showSA (StableSharingAcc _ (AccSharing  sn acc)) = show (hashStableNameHeight sn) ++ ": " ++-                                                       showPreAccOp acc-    showSA (StableSharingAcc _ (AvarSharing sn))     = "AvarSharing " ++ show (hashStableNameHeight sn)-    showSA (StableSharingAcc _ (AletSharing sa _ ))  = "AletSharing " ++ show sa ++ "..."---- Build an initial environment for the tag values given in the first argument for traversing a--- scalar expression.  The 'StableSharingExp's for all tags /actually used/ in the expressions are--- in the second argument. (Tags are not used if a bound variable has no usage occurrence.)------ Bail out if any tag occurs multiple times as this indicates that the sharing of an argument--- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments--- at 'determineScopesAcc'.----buildInitialEnvExp :: [Level] -> [StableSharingExp] -> [StableSharingExp]-buildInitialEnvExp tags ses = map (lookupSE ses) tags-  where-    lookupSE ses tag1-      = case filter hasTag ses of-          []   -> noStableSharing    -- tag is not used in the analysed expression-          [se] -> se                 -- tag has a unique occurrence-          ses2 -> $internalError "buildInitialEnvExp"-                    ("Encountered a duplicate 'Tag'\n  " ++ intercalate ", " (map showSE ses2))-      where-        hasTag (StableSharingExp _ (ExpSharing _ (Tag tag2))) = tag1 == tag2-        hasTag se-          = $internalError "buildInitialEnvExp"-              ("Encountered a node that is not a plain 'Tag'\n  " ++ showSE se)--        noStableSharing :: StableSharingExp-        noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp acc exp ())--    showSE (StableSharingExp _ (ExpSharing sn exp)) = show (hashStableNameHeight sn) ++ ": " ++-                                                      showPreExpOp exp-    showSE (StableSharingExp _ (VarSharing sn))     = "VarSharing " ++ show (hashStableNameHeight sn)-    showSE (StableSharingExp _ (LetSharing se _ ))  = "LetSharing " ++ show se ++ "..."---- Determine whether a 'NodeCount' is for an 'Atag' or 'Tag', which represent free variables.----isFreeVar :: NodeCount -> Bool-isFreeVar (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag _))) _) = True-isFreeVar (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag  _))) _) = True-isFreeVar _                                                             = False----- Determine scope of shared subterms--- ==================================---- Determine the scopes of all variables representing shared subterms (Phase Two) in a bottom-up--- sweep.  The first argument determines whether array computations are floated out of expressions--- irrespective of whether they are shared or not — 'True' implies floating them out.------ In addition to the AST with sharing information, yield the 'StableSharingAcc's for all free--- variables of 'rootAcc', which are represented by 'Atag' leaves in the tree. They are in order of--- the tag values — i.e., in the same order that they need to appear in an environment to use the--- tag for indexing into that environment.------ Precondition: there are only 'AvarSharing' and 'AccSharing' nodes in the argument.----determineScopesAcc-    :: Typeable a-    => Config-    -> [Level]-    -> OccMap Acc-    -> UnscopedAcc a-    -> (ScopedAcc a, [StableSharingAcc])-determineScopesAcc config fvs accOccMap rootAcc-  = let (sharingAcc, (counts, _)) = determineScopesSharingAcc config accOccMap rootAcc-        unboundTrees              = filter (not . isFreeVar) counts-    in-    if all isFreeVar counts-       then (sharingAcc, buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- counts])-       else $internalError "determineScopesAcc" ("unbound shared subtrees" ++ show unboundTrees)---determineScopesSharingAcc-    :: Config-    -> OccMap Acc-    -> UnscopedAcc a-    -> (ScopedAcc a, NodeCounts)-determineScopesSharingAcc config accOccMap = scopesAcc-  where-    scopesAcc :: forall arrs. UnscopedAcc arrs -> (ScopedAcc arrs, NodeCounts)-    scopesAcc (UnscopedAcc _ (AletSharing _ _))-      = $internalError "determineScopesSharingAcc: scopesAcc" "unexpected 'AletSharing'"--    scopesAcc (UnscopedAcc _ (AvarSharing sn))-      = (ScopedAcc [] (AvarSharing sn), StableSharingAcc sn (AvarSharing sn) `insertAccNode` noNodeCounts)--    scopesAcc (UnscopedAcc _ (AccSharing sn pacc))-      = case pacc of-          Atag i                  -> reconstruct (Atag i) noNodeCounts-          Pipe afun1 afun2 acc    -> let-                                       (afun1', accCount1) = scopesAfun1 afun1-                                       (afun2', accCount2) = scopesAfun1 afun2-                                       (acc', accCount3)   = scopesAcc acc-                                     in-                                     reconstruct (Pipe afun1' afun2' acc')-                                                 (accCount1 +++ accCount2 +++ accCount3)--          Aforeign ff afun acc    -> let-                                       (acc', accCount) = scopesAcc acc-                                     in-                                     reconstruct (Aforeign ff afun acc') accCount-          Acond e acc1 acc2       -> let-                                       (e'   , accCount1) = scopesExp e-                                       (acc1', accCount2) = scopesAcc acc1-                                       (acc2', accCount3) = scopesAcc acc2-                                     in-                                     reconstruct (Acond e' acc1' acc2')-                                                 (accCount1 +++ accCount2 +++ accCount3)--          Awhile pred iter init   -> let-                                       (pred', accCount1) = scopesAfun1 pred-                                       (iter', accCount2) = scopesAfun1 iter-                                       (init', accCount3) = scopesAcc init-                                     in-                                     reconstruct (Awhile pred' iter' init')-                                                 (accCount1 +++ accCount2 +++ accCount3)--          Atuple tup              -> let (tup', accCount) = travAtup tup-                                     in  reconstruct (Atuple tup') accCount-          Aprj ix a               -> travA (Aprj ix) a--          Use arr                 -> reconstruct (Use arr) noNodeCounts-          Unit e                  -> let-                                       (e', accCount) = scopesExp e-                                     in-                                     reconstruct (Unit e') accCount-          Generate sh f           -> let-                                       (sh', accCount1) = scopesExp sh-                                       (f' , accCount2) = scopesFun1 f-                                     in-                                     reconstruct (Generate sh' f') (accCount1 +++ accCount2)-          Reshape sh acc          -> travEA Reshape sh acc-          Replicate n acc         -> travEA Replicate n acc-          Slice acc i             -> travEA (flip Slice) i acc-          Map f acc               -> let-                                       (f'  , accCount1) = scopesFun1 f-                                       (acc', accCount2) = scopesAcc  acc-                                     in-                                     reconstruct (Map f' acc') (accCount1 +++ accCount2)-          ZipWith f acc1 acc2     -> travF2A2 ZipWith f acc1 acc2-          Fold f z acc            -> travF2EA Fold f z acc-          Fold1 f acc             -> travF2A Fold1 f acc-          FoldSeg f z acc1 acc2   -> let-                                       (f'   , accCount1)  = scopesFun2 f-                                       (z'   , accCount2)  = scopesExp  z-                                       (acc1', accCount3)  = scopesAcc  acc1-                                       (acc2', accCount4)  = scopesAcc  acc2-                                     in-                                     reconstruct (FoldSeg f' z' acc1' acc2')-                                       (accCount1 +++ accCount2 +++ accCount3 +++ accCount4)-          Fold1Seg f acc1 acc2    -> travF2A2 Fold1Seg f acc1 acc2-          Scanl f z acc           -> travF2EA Scanl f z acc-          Scanl' f z acc          -> travF2EA Scanl' f z acc-          Scanl1 f acc            -> travF2A Scanl1 f acc-          Scanr f z acc           -> travF2EA Scanr f z acc-          Scanr' f z acc          -> travF2EA Scanr' f z acc-          Scanr1 f acc            -> travF2A Scanr1 f acc-          Permute fc acc1 fp acc2 -> let-                                       (fc'  , accCount1) = scopesFun2 fc-                                       (acc1', accCount2) = scopesAcc  acc1-                                       (fp'  , accCount3) = scopesFun1 fp-                                       (acc2', accCount4) = scopesAcc  acc2-                                     in-                                     reconstruct (Permute fc' acc1' fp' acc2')-                                       (accCount1 +++ accCount2 +++ accCount3 +++ accCount4)-          Backpermute sh fp acc   -> let-                                       (sh' , accCount1) = scopesExp  sh-                                       (fp' , accCount2) = scopesFun1 fp-                                       (acc', accCount3) = scopesAcc  acc-                                     in-                                     reconstruct (Backpermute sh' fp' acc')-                                       (accCount1 +++ accCount2 +++ accCount3)-          Stencil st bnd acc      -> let-                                       (st' , accCount1) = scopesStencil1 acc st-                                       (bnd', accCount2) = scopesBoundary bnd-                                       (acc', accCount3) = scopesAcc acc-                                     in-                                     reconstruct (Stencil st' bnd' acc') (accCount1 +++ accCount2 +++ accCount3)-          Stencil2 st bnd1 acc1 bnd2 acc2-                                  -> let-                                       (st'  , accCount1) = scopesStencil2 acc1 acc2 st-                                       (bnd1', accCount2) = scopesBoundary bnd1-                                       (acc1', accCount3) = scopesAcc acc1-                                       (bnd2', accCount4) = scopesBoundary bnd2-                                       (acc2', accCount5) = scopesAcc acc2-                                     in-                                     reconstruct (Stencil2 st' bnd1' acc1' bnd2' acc2')-                                       (accCount1 +++ accCount2 +++ accCount3 +++ accCount4 +++ accCount5)-          -- Collect seq             -> let-          --                              (seq', accCount1) = scopesSeq seq-          --                            in-          --                            reconstruct (Collect seq') accCount1--      where-        travEA :: (ScopedExp e -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)-               -> RootExp e-               -> UnscopedAcc arrs'-               -> (ScopedAcc arrs, NodeCounts)-        travEA c e acc = reconstruct (c e' acc') (accCount1 +++ accCount2)-          where-            (e'  , accCount1) = scopesExp e-            (acc', accCount2) = scopesAcc acc--        travF2A :: (Elt a, Elt b)-                => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs'-                    -> PreAcc ScopedAcc ScopedExp arrs)-                -> (Exp a -> Exp b -> RootExp c)-                -> UnscopedAcc arrs'-                -> (ScopedAcc arrs, NodeCounts)-        travF2A c f acc = reconstruct (c f' acc') (accCount1 +++ accCount2)-          where-            (f'  , accCount1) = scopesFun2 f-            (acc', accCount2) = scopesAcc  acc--        travF2EA :: (Elt a, Elt b)-                 => ((Exp a -> Exp b -> ScopedExp c) -> ScopedExp e-                     -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)-                 -> (Exp a -> Exp b -> RootExp c)-                 -> RootExp e-                 -> UnscopedAcc arrs'-                 -> (ScopedAcc arrs, NodeCounts)-        travF2EA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3)-          where-            (f'  , accCount1) = scopesFun2 f-            (e'  , accCount2) = scopesExp  e-            (acc', accCount3) = scopesAcc  acc--        travF2A2 :: (Elt a, Elt b)-                 => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs1-                     -> ScopedAcc arrs2 -> PreAcc ScopedAcc ScopedExp arrs)-                 -> (Exp a -> Exp b -> RootExp c)-                 -> UnscopedAcc arrs1-                 -> UnscopedAcc arrs2-                 -> (ScopedAcc arrs, NodeCounts)-        travF2A2 c f acc1 acc2 = reconstruct (c f' acc1' acc2')-                                             (accCount1 +++ accCount2 +++ accCount3)-          where-            (f'   , accCount1) = scopesFun2 f-            (acc1', accCount2) = scopesAcc  acc1-            (acc2', accCount3) = scopesAcc  acc2--        travAtup ::  Atuple UnscopedAcc a-                 -> (Atuple ScopedAcc a, NodeCounts)-        travAtup NilAtup          = (NilAtup, noNodeCounts)-        travAtup (SnocAtup tup a) = let (tup', accCountT) = travAtup tup-                                        (a',   accCountA) = scopesAcc a-                                    in-                                    (SnocAtup tup' a', accCountT +++ accCountA)--        travA :: (ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)-              -> UnscopedAcc arrs'-              -> (ScopedAcc arrs, NodeCounts)-        travA c acc = reconstruct (c acc') accCount-          where-            (acc', accCount) = scopesAcc acc--          -- Occurrence count of the currently processed node-        accOccCount = let StableNameHeight sn' _ = sn-                      in-                      lookupWithASTName accOccMap (StableASTName sn')--        -- Reconstruct the current tree node.-        ---        -- * If the current node is being shared ('accOccCount > 1'), replace it by a 'AvarSharing'-        --   node and float the shared subtree out wrapped in a 'NodeCounts' value.-        -- * If the current node is not shared, reconstruct it in place.-        -- * Special case for free variables ('Atag'): Replace the tree by a sharing variable and-        --   float the 'Atag' out in a 'NodeCounts' value.  This is independent of the number of-        --   occurrences.-        ---        -- In either case, any completed 'NodeCounts' are injected as bindings using 'AletSharing'-        -- node.-        ---        reconstruct :: PreAcc ScopedAcc ScopedExp arrs-                    -> NodeCounts-                    -> (ScopedAcc arrs, NodeCounts)-        reconstruct newAcc@(Atag _) _subCount-              -- free variable => replace by a sharing variable regardless of the number of-              -- occurrences-          = let thisCount = StableSharingAcc sn (AccSharing sn newAcc) `insertAccNode` noNodeCounts-            in-            tracePure "FREE" (show thisCount)-            (ScopedAcc [] (AvarSharing sn), thisCount)-        reconstruct newAcc subCount-              -- shared subtree => replace by a sharing variable (if 'recoverAccSharing' enabled)-          | accOccCount > 1 && recoverAccSharing config-          = let allCount = (StableSharingAcc sn sharingAcc `insertAccNode` newCount)-            in-            tracePure ("SHARED" ++ completed) (show allCount)-            (ScopedAcc [] (AvarSharing sn), allCount)-              -- neither shared nor free variable => leave it as it is-          | otherwise-          = tracePure ("Normal" ++ completed) (show newCount)-            (ScopedAcc [] sharingAcc, newCount)-          where-              -- Determine the bindings that need to be attached to the current node...-            (newCount, bindHere) = filterCompleted subCount--              -- ...and wrap them in 'AletSharing' constructors-            lets       = foldl (flip (.)) id . map (\x y -> AletSharing x (ScopedAcc [] y)) $ bindHere-            sharingAcc = lets $ AccSharing sn newAcc--              -- trace support-            completed | null bindHere = ""-                      | otherwise     = "(" ++ show (length bindHere) ++ " lets)"--        -- Extract *leading* nodes that have a complete node count (i.e., their node count is equal-        -- to the number of occurrences of that node in the overall expression).-        ---        -- Nodes with a completed node count should be let bound at the currently processed node.-        ---        -- NB: Only extract leading nodes (i.e., the longest run at the *front* of the list that is-        --     complete).  Otherwise, we would let-bind subterms before their parents, which leads-        --     scope errors.-        ---        filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingAcc])-        filterCompleted (ns, graph)-          = let bindable     = map (isBindable bindable (map nodeName ns)) ns-                (bind, rest) = partition fst $ zip bindable ns-            in ((map snd rest, graph), [sa | AccNodeCount sa _ <- map snd bind])-          where-            -- a node is not yet complete while the node count 'n' is below the overall number-            -- of occurrences for that node in the whole program, with the exception that free-            -- variables are never complete-            isCompleted nc@(AccNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingAcc accOccMap sa == n-            isCompleted _                                             = False--            isBindable :: [Bool] -> [NodeName] -> NodeCount -> Bool-            isBindable bindable nodes nc@(AccNodeCount _ _) =-              let superTerms = Set.toList $ graph Map.! nodeName nc-                  unbound    = mapMaybe (`elemIndex` nodes) superTerms-              in    isCompleted nc-                 && all (bindable !!) unbound-            isBindable _ _ (ExpNodeCount _ _) = False-            -- isBindable _ _ (SeqNodeCount _ _) = False--    -- scopesSeq :: forall arrs. RootSeq arrs -> (ScopedSeq arrs, NodeCounts)-    -- scopesSeq = determineScopesSeq config accOccMap--    scopesExp :: RootExp t -> (ScopedExp t, NodeCounts)-    scopesExp = determineScopesExp config accOccMap--    -- The lambda bound variable is at this point already irrelevant; for details, see-    -- Note [Traversing functions and side effects]-    ---    scopesAfun1 :: Arrays a1 => (Acc a1 -> UnscopedAcc a2) -> (Acc a1 -> ScopedAcc a2, NodeCounts)-    scopesAfun1 f = (const (ScopedAcc ssa body'), (counts',graph))-      where-        body@(UnscopedAcc fvs _) = f undefined-        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body-        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]-        (freeCounts, counts') = partition isBoundHere counts--        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs-        isBoundHere _                                                             = False--    -- The lambda bound variable is at this point already irrelevant; for details, see-    -- Note [Traversing functions and side effects]-    ---    scopesFun1 :: Elt e1 => (Exp e1 -> RootExp e2) -> (Exp e1 -> ScopedExp e2, NodeCounts)-    scopesFun1 f = (const body, counts)-      where-        (body, counts) = scopesExp (f undefined)--    -- The lambda bound variable is at this point already irrelevant; for details, see-    -- Note [Traversing functions and side effects]-    ---    scopesFun2 :: (Elt e1, Elt e2)-               => (Exp e1 -> Exp e2 -> RootExp e3)-               -> (Exp e1 -> Exp e2 -> ScopedExp e3, NodeCounts)-    scopesFun2 f = (\_ _ -> body, counts)-      where-        (body, counts) = scopesExp (f undefined undefined)--    -- The lambda bound variable is at this point already irrelevant; for details, see-    -- Note [Traversing functions and side effects]-    ---    scopesStencil1 :: forall sh e1 e2 stencil. Stencil sh e1 stencil-                   => UnscopedAcc (Array sh e1){-dummy-}-                   -> (stencil -> RootExp e2)-                   -> (stencil -> ScopedExp e2, NodeCounts)-    scopesStencil1 _ stencilFun = (const body, counts)-      where-        (body, counts) = scopesExp (stencilFun undefined)--    -- The lambda bound variable is at this point already irrelevant; for details, see-    -- Note [Traversing functions and side effects]-    ---    scopesStencil2 :: forall sh e1 e2 e3 stencil1 stencil2.-                      (Stencil sh e1 stencil1, Stencil sh e2 stencil2)-                   => UnscopedAcc (Array sh e1){-dummy-}-                   -> UnscopedAcc (Array sh e2){-dummy-}-                   -> (stencil1 -> stencil2 -> RootExp e3)-                   -> (stencil1 -> stencil2 -> ScopedExp e3, NodeCounts)-    scopesStencil2 _ _ stencilFun = (\_ _ -> body, counts)-      where-        (body, counts) = scopesExp (stencilFun undefined undefined)--    scopesBoundary :: PreBoundary UnscopedAcc RootExp t-                   -> (PreBoundary ScopedAcc ScopedExp t, NodeCounts)-    scopesBoundary bndy =-      case bndy of-        Clamp      -> (Clamp, noNodeCounts)-        Mirror     -> (Mirror, noNodeCounts)-        Wrap       -> (Wrap, noNodeCounts)-        Constant v -> (Constant v, noNodeCounts)-        Function f -> let (body, counts) = scopesFun1 f-                      in  (Function body, counts)---determineScopesExp-    :: Config-    -> OccMap Acc-    -> RootExp t-    -> (ScopedExp t, NodeCounts)          -- Root (closed) expression plus Acc node counts-determineScopesExp config accOccMap (RootExp expOccMap exp@(UnscopedExp fvs _))-  = let-        ((ScopedExp [] expWithScopes), (nodeCounts,graph)) = determineScopesSharingExp config accOccMap expOccMap exp-        (expCounts, accCounts)          = partition isExpNodeCount nodeCounts--        isExpNodeCount ExpNodeCount{}   = True-        isExpNodeCount _                = False-    in-    (ScopedExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, cleanCounts (accCounts,graph))---determineScopesSharingExp-    :: Config-    -> OccMap Acc-    -> OccMap Exp-    -> UnscopedExp t-    -> (ScopedExp t, NodeCounts)-determineScopesSharingExp config accOccMap expOccMap = scopesExp-  where-    scopesAcc :: UnscopedAcc a -> (ScopedAcc a, NodeCounts)-    scopesAcc = determineScopesSharingAcc config accOccMap--    scopesFun1 :: (Exp a -> UnscopedExp b) -> (Exp a -> ScopedExp b, NodeCounts)-    scopesFun1 f = tracePure ("LAMBDA " ++ (show ssa)) (show counts) (const (ScopedExp ssa body'), (counts',graph))-      where-        body@(UnscopedExp fvs _) = f undefined-        ((ScopedExp [] body'), (counts, graph)) = scopesExp body-        ssa     = buildInitialEnvExp fvs [se | ExpNodeCount se _ <- freeCounts]-        (freeCounts, counts') = partition isBoundHere counts--        isBoundHere (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag i))) _) = i `elem` fvs-        isBoundHere _                                                            = False---    scopesExp :: forall t. UnscopedExp t -> (ScopedExp t, NodeCounts)-    scopesExp (UnscopedExp _ (LetSharing _ _))-      = $internalError "determineScopesSharingExp: scopesExp" "unexpected 'LetSharing'"--    scopesExp (UnscopedExp _ (VarSharing sn))-      = (ScopedExp [] (VarSharing sn), StableSharingExp sn (VarSharing sn) `insertExpNode` noNodeCounts)--    scopesExp (UnscopedExp _ (ExpSharing sn pexp))-      = case pexp of-          Tag i                 -> reconstruct (Tag i) noNodeCounts-          Const c               -> reconstruct (Const c) noNodeCounts-          Tuple tup             -> let (tup', accCount) = travTup tup-                                   in-                                   reconstruct (Tuple tup') accCount-          Prj i e               -> travE1 (Prj i) e-          IndexNil              -> reconstruct IndexNil noNodeCounts-          IndexCons ix i        -> travE2 IndexCons ix i-          IndexHead i           -> travE1 IndexHead i-          IndexTail ix          -> travE1 IndexTail ix-          IndexAny              -> reconstruct IndexAny noNodeCounts-          ToIndex sh ix         -> travE2 ToIndex sh ix-          FromIndex sh e        -> travE2 FromIndex sh e-          Cond e1 e2 e3         -> travE3 Cond e1 e2 e3-          While p it i          -> let-                                     (p' , accCount1) = scopesFun1 p-                                     (it', accCount2) = scopesFun1 it-                                     (i' , accCount3) = scopesExp i-                                   in reconstruct (While p' it' i') (accCount1 +++ accCount2 +++ accCount3)-          PrimConst c           -> reconstruct (PrimConst c) noNodeCounts-          PrimApp p e           -> travE1 (PrimApp p) e-          Index a e             -> travAE Index a e-          LinearIndex a e       -> travAE LinearIndex a e-          Shape a               -> travA Shape a-          ShapeSize e           -> travE1 ShapeSize e-          Intersect sh1 sh2     -> travE2 Intersect sh1 sh2-          Union sh1 sh2         -> travE2 Union sh1 sh2-          Foreign ff f e        -> travE1 (Foreign ff f) e-      where-        travTup :: Tuple UnscopedExp tup -> (Tuple ScopedExp tup, NodeCounts)-        travTup NilTup          = (NilTup, noNodeCounts)-        travTup (SnocTup tup e) = let-                                    (tup', accCountT) = travTup tup-                                    (e'  , accCountE) = scopesExp e-                                  in-                                  (SnocTup tup' e', accCountT +++ accCountE)--        travE1 :: (ScopedExp a -> PreExp ScopedAcc ScopedExp t) -> UnscopedExp a-               -> (ScopedExp t, NodeCounts)-        travE1 c e = reconstruct (c e') accCount-          where-            (e', accCount) = scopesExp e--        travE2 :: (ScopedExp a -> ScopedExp b -> PreExp ScopedAcc ScopedExp t)-               -> UnscopedExp a-               -> UnscopedExp b-               -> (ScopedExp t, NodeCounts)-        travE2 c e1 e2 = reconstruct (c e1' e2') (accCount1 +++ accCount2)-          where-            (e1', accCount1) = scopesExp e1-            (e2', accCount2) = scopesExp e2--        travE3 :: (ScopedExp a -> ScopedExp b -> ScopedExp c -> PreExp ScopedAcc ScopedExp t)-               -> UnscopedExp a-               -> UnscopedExp b-               -> UnscopedExp c-               -> (ScopedExp t, NodeCounts)-        travE3 c e1 e2 e3 = reconstruct (c e1' e2' e3') (accCount1 +++ accCount2 +++ accCount3)-          where-            (e1', accCount1) = scopesExp e1-            (e2', accCount2) = scopesExp e2-            (e3', accCount3) = scopesExp e3--        travA :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t) -> UnscopedAcc a-              -> (ScopedExp t, NodeCounts)-        travA c acc = maybeFloatOutAcc c acc' accCount-          where-            (acc', accCount)  = scopesAcc acc--        travAE :: (ScopedAcc a -> ScopedExp b -> PreExp ScopedAcc ScopedExp t)-               -> UnscopedAcc a-               -> UnscopedExp b-               -> (ScopedExp t, NodeCounts)-        travAE c acc e = maybeFloatOutAcc (`c` e') acc' (accCountA +++ accCountE)-          where-            (acc', accCountA) = scopesAcc acc-            (e'  , accCountE) = scopesExp e--        maybeFloatOutAcc :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t)-                         -> ScopedAcc a-                         -> NodeCounts-                         -> (ScopedExp t, NodeCounts)-        maybeFloatOutAcc c acc@(ScopedAcc _ (AvarSharing _)) accCount        -- nothing to float out-          = reconstruct (c acc) accCount-        maybeFloatOutAcc c acc                 accCount-          | floatOutAcc config = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount)-          | otherwise          = reconstruct (c acc) accCount-          where-             (var, stableAcc) = abstract acc (\(ScopedAcc _ s) -> s)--        abstract :: ScopedAcc a -> (ScopedAcc a -> SharingAcc ScopedAcc ScopedExp a)-                 -> (ScopedAcc a, StableSharingAcc)-        abstract (ScopedAcc _ (AvarSharing _))       _      = $internalError "sharingAccToVar" "AvarSharing"-        abstract (ScopedAcc ssa (AletSharing sa acc))  lets = abstract acc (lets . (\x -> ScopedAcc ssa (AletSharing sa x)))-        abstract acc@(ScopedAcc ssa (AccSharing sn _)) lets = (ScopedAcc ssa (AvarSharing sn), StableSharingAcc sn (lets acc))--        -- Occurrence count of the currently processed node-        expOccCount = let StableNameHeight sn' _ = sn-                      in-                      lookupWithASTName expOccMap (StableASTName sn')--        -- Reconstruct the current tree node.-        ---        -- * If the current node is being shared ('expOccCount > 1'), replace it by a 'VarSharing'-        --   node and float the shared subtree out wrapped in a 'NodeCounts' value.-        -- * If the current node is not shared, reconstruct it in place.-        -- * Special case for free variables ('Tag'): Replace the tree by a sharing variable and-        --   float the 'Tag' out in a 'NodeCounts' value.  This is independent of the number of-        --   occurrences.-        ---        -- In either case, any completed 'NodeCounts' are injected as bindings using 'LetSharing'-        -- node.-        ---        reconstruct :: PreExp ScopedAcc ScopedExp t -> NodeCounts-                    -> (ScopedExp t, NodeCounts)-        reconstruct newExp@(Tag _) _subCount-              -- free variable => replace by a sharing variable regardless of the number of-              -- occurrences-          = let thisCount = StableSharingExp sn (ExpSharing sn newExp) `insertExpNode` noNodeCounts-            in-            tracePure "FREE" (show thisCount)-            (ScopedExp [] (VarSharing sn), thisCount)-        reconstruct newExp subCount-              -- shared subtree => replace by a sharing variable (if 'recoverExpSharing' enabled)-          | expOccCount > 1 && recoverExpSharing config-          = let allCount = StableSharingExp sn sharingExp `insertExpNode` newCount-            in-            tracePure ("SHARED" ++ completed) (show allCount)-            (ScopedExp [] (VarSharing sn), allCount)-              -- neither shared nor free variable => leave it as it is-          | otherwise-          = tracePure ("Normal" ++ completed) (show newCount)-            (ScopedExp [] sharingExp, newCount)-          where-              -- Determine the bindings that need to be attached to the current node...-            (newCount, bindHere) = filterCompleted subCount--              -- ...and wrap them in 'LetSharing' constructors-            lets       = foldl (flip (.)) id . map (\x y -> LetSharing x (ScopedExp [] y)) $ bindHere-            sharingExp = lets $ ExpSharing sn newExp--              -- trace support-            completed | null bindHere = ""-                      | otherwise     = "(" ++ show (length bindHere) ++ " lets)"--        -- Extract *leading* nodes that have a complete node count (i.e., their node count is equal-        -- to the number of occurrences of that node in the overall expression).-        ---        -- Nodes with a completed node count should be let bound at the currently processed node.-        ---        -- NB: Only extract leading nodes (i.e., the longest run at the *front* of the list that is-        --     complete).  Otherwise, we would let-bind subterms before their parents, which leads-        --     scope errors.-        ---        filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingExp])-        filterCompleted (ns,graph)-          = let bindable       = map (isBindable bindable (map nodeName ns)) ns-                (bind, unbind) = partition fst $ zip bindable ns-            in ((map snd unbind, graph), [se | ExpNodeCount se _ <- map snd bind])-          where-            -- a node is not yet complete while the node count 'n' is below the overall number-            -- of occurrences for that node in the whole program, with the exception that free-            -- variables are never complete-            isCompleted nc@(ExpNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingExp expOccMap sa == n-            isCompleted _                                             = False--            isBindable :: [Bool] -> [NodeName] -> NodeCount -> Bool-            isBindable bindable nodes nc@(ExpNodeCount _ _) =-              let superTerms = Set.toList $ graph Map.! nodeName nc-                  unbound    = mapMaybe (`elemIndex` nodes) superTerms-              in    isCompleted nc-                 && all (bindable !!) unbound-            isBindable _ _ (AccNodeCount _ _) = False-            -- isBindable _ _ (SeqNodeCount _ _) = False--{---determineScopesSeq-    :: Config-    -> OccMap Acc-    -> RootSeq t-    -> (ScopedSeq t, NodeCounts)          -- Root (closed) expression plus Acc node counts-determineScopesSeq config accOccMap (RootSeq seqOccMap seq)-  = let-        (ScopedSeq seqWithScopes, (nodeCounts,graph)) = determineScopesSharingSeq config accOccMap seqOccMap seq-        binds      = [s | SeqNodeCount s _ <- nodeCounts]-        lets       = foldl (flip (.)) id . map (\x y -> SletSharing x (ScopedSeq y)) $ binds-        sharingSeq = lets seqWithScopes-        newCounts  = filter (not . isSeqCount) nodeCounts-        isSeqCount SeqNodeCount{} = True-        isSeqCount _              = False-    in-    (ScopedSeq sharingSeq, cleanCounts (newCounts,graph))--determineScopesSharingSeq-  :: Config-  -> OccMap Acc-  -> OccMap Seq-  -> UnscopedSeq t-  -> (ScopedSeq t, NodeCounts)-determineScopesSharingSeq config accOccMap _seqOccMap = scopesSeq-  where-    scopesAcc :: UnscopedAcc a -> (ScopedAcc a, NodeCounts)-    scopesAcc = determineScopesSharingAcc config accOccMap--    scopesExp :: RootExp t -> (ScopedExp t, NodeCounts)-    scopesExp = determineScopesExp config accOccMap--    scopesFun2 :: (Elt e1, Elt e2)-               => (Exp e1 -> Exp e2 -> RootExp e3)-               -> (Exp e1 -> Exp e2 -> ScopedExp e3, NodeCounts)-    scopesFun2 f = (\_ _ -> body, counts)-      where-        (body, counts) = scopesExp (f undefined undefined)--    -- The lambda bound variable is at this point already irrelevant; for details, see-    -- Note [Traversing functions and side effects]-    ---    scopesAfun1 :: Arrays a1 => (Acc a1 -> UnscopedAcc a2) -> (Acc a1 -> ScopedAcc a2, NodeCounts)-    scopesAfun1 f = (const (ScopedAcc ssa body'), (counts',graph))-      where-        body@(UnscopedAcc fvs _) = f undefined-        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body-        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]-        (freeCounts, counts') = partition isBoundHere counts--        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs-        isBoundHere _                                                             = False--    scopesAfun2 :: (Arrays a1, Arrays a2) => (Acc a1 -> Acc a2 -> UnscopedAcc a3) -> (Acc a1 -> Acc a2 -> ScopedAcc a3, NodeCounts)-    scopesAfun2 f = (\ _ _ -> (ScopedAcc ssa body'), (counts',graph))-      where-        body@(UnscopedAcc fvs _) = f undefined undefined-        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body-        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]-        (freeCounts, counts') = partition isBoundHere counts--        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs-        isBoundHere _                                                             = False--    scopesAfun3 :: (Arrays a1, Arrays a2, Arrays a3) => (Acc a1 -> Acc a2 -> Acc a3 -> UnscopedAcc a4) -> (Acc a1 -> Acc a2 -> Acc a3 -> ScopedAcc a4, NodeCounts)-    scopesAfun3 f = (\ _ _ _ -> (ScopedAcc ssa body'), (counts',graph))-      where-        body@(UnscopedAcc fvs _) = f undefined undefined undefined-        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body-        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]-        (freeCounts, counts') = partition isBoundHere counts--        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs-        isBoundHere _                                                             = False--    scopesTup :: Atuple UnscopedSeq tup -> (Atuple ScopedSeq tup, NodeCounts)-    scopesTup NilAtup          = (NilAtup, noNodeCounts)-    scopesTup (SnocAtup tup s) = let-                                   (tup', accCountT) = scopesTup tup-                                   (s'  , accCountS) = scopesSeq s-                                 in-                                 (SnocAtup tup' s', accCountT +++ accCountS)--    scopesSeq :: forall t. UnscopedSeq t -> (ScopedSeq t, NodeCounts)-    scopesSeq (UnscopedSeq (SletSharing _ _))-      = $internalError "determineScopesSharingSeq: scopesSeq" "unexpected 'LetSharing'"-    scopesSeq (UnscopedSeq (SvarSharing sn))-      = (ScopedSeq (SvarSharing sn), StableSharingSeq sn (SvarSharing sn) `insertSeqNode` noNodeCounts)--    scopesSeq (UnscopedSeq (SeqSharing sn s)) =-      case s of-        StreamIn arrs -> producer (StreamIn arrs) noNodeCounts-        ToSeq sl acc   -> let-                            (acc', accCount1) = scopesAcc acc-                          in producer (ToSeq sl acc') accCount1-        MapSeq     afun s'  -> let-                                 (afun', accCount1) = scopesAfun1 afun-                                 (s''  , accCount2) = scopesSeq s'-                               in producer (MapSeq afun' s'') (accCount1 +++ accCount2)-        ZipWithSeq afun s1 s2 -> let-                                   (afun', accCount1) = scopesAfun2 afun-                                   (s1'  , accCount2) = scopesSeq s1-                                   (s2'  , accCount3) = scopesSeq s2-                                 in producer (ZipWithSeq afun' s1' s2') (accCount1 +++ accCount2 +++ accCount3)-        ScanSeq fun e s' -> let-                              (fun', accCount1) = scopesFun2 fun-                              (e'  , accCount2) = scopesExp e-                              (s'' , accCount3) = scopesSeq s'-                            in producer (ScanSeq fun' e' s'') (accCount1 +++ accCount2 +++ accCount3)-        FoldSeq fun e s' -> let-                              (fun', accCount1) = scopesFun2 fun-                              (e'  , accCount2) = scopesExp e-                              (s'' , accCount3) = scopesSeq s'-                            in consumer (FoldSeq fun' e' s'') (accCount1 +++ accCount2 +++ accCount3)-        FoldSeqFlatten afun acc s' ->-                               let-                                 (afun', accCount1) = scopesAfun3 afun-                                 (acc' , accCount2) = scopesAcc acc-                                 (s''  , accCount3) = scopesSeq s'-                               in consumer (FoldSeqFlatten afun' acc' s'') (accCount1 +++ accCount2 +++ accCount3)-        Stuple tup          -> let-                                 (tup', accCount1) = scopesTup tup-                               in consumer (Stuple tup') accCount1-      where-        -- All producers must be replaced by sharing variables-        ---        producer :: (t ~ [a], Arrays a)-                 => PreSeq ScopedAcc ScopedSeq ScopedExp t-                 -> NodeCounts-                 -> (ScopedSeq t, NodeCounts)-        producer newSeq subCount-          = let allCount = StableSharingSeq sn (SeqSharing sn newSeq) `insertSeqNode` subCount-            in-            tracePure "Producer" (show allCount)-            (ScopedSeq (SvarSharing sn), allCount)--        -- Consumers cannot be shared.-        ---        consumer :: PreSeq ScopedAcc ScopedSeq ScopedExp t-                 -> NodeCounts-                 -> (ScopedSeq t, NodeCounts)-        consumer newSeq subCount-          = tracePure "Consumer" (show subCount)-            (ScopedSeq (SeqSharing sn newSeq), subCount)---}---- |Recover sharing information and annotate the HOAS AST with variable and let binding--- annotations.  The first argument determines whether array computations are floated out of--- expressions irrespective of whether they are shared or not — 'True' implies floating them out.------ Also returns the 'StableSharingAcc's of all 'Atag' leaves in environment order — they represent--- the free variables of the AST.------ NB: Strictly speaking, this function is not deterministic, as it uses stable pointers to---     determine the sharing of subterms.  The stable pointer API does not guarantee its---     completeness; i.e., it may miss some equalities, which implies that we may fail to discover---     some sharing.  However, sharing does not affect the denotational meaning of an array---     computation; hence, we do not compromise denotational correctness.------     There is one caveat: We currently rely on the 'Atag' and 'Tag' leaves representing free---     variables to be shared if any of them is used more than once.  If one is duplicated, the---     environment for de Bruijn conversion will have a duplicate entry, and hence, be of the wrong---     size, which is fatal. (The 'buildInitialEnv*' functions will already bail out.)----{-# NOINLINE recoverSharingAcc #-}-recoverSharingAcc-    :: Typeable a-    => Config-    -> Level            -- The level of currently bound array variables-    -> [Level]          -- The tags of newly introduced free array variables-    -> Acc a-    -> (ScopedAcc a, [StableSharingAcc])-recoverSharingAcc config alvl avars acc-  = let (acc', occMap)-          = unsafePerformIO             -- to enable stable pointers; this is safe as explained above-          $ makeOccMapAcc config alvl acc-    in-    determineScopesAcc config avars occMap acc'---{-# NOINLINE recoverSharingExp #-}-recoverSharingExp-    :: Typeable e-    => Config-    -> Level            -- The level of currently bound scalar variables-    -> [Level]          -- The tags of newly introduced free scalar variables-    -> Exp e-    -> (ScopedExp e, [StableSharingExp])-recoverSharingExp config lvl fvar exp-  = let-        (rootExp, accOccMap) = unsafePerformIO $ do-          accOccMap       <- newASTHashTable-          (exp', _)       <- makeOccMapRootExp config accOccMap lvl fvar exp-          frozenAccOccMap <- freezeOccMap accOccMap--          return (exp', frozenAccOccMap)--        (ScopedExp sse sharingExp, _) =-          determineScopesExp config accOccMap rootExp-    in-    (ScopedExp [] sharingExp, sse)---{---{-# NOINLINE recoverSharingSeq #-}-recoverSharingSeq-    :: Typeable e-    => Config-    -> Seq e-    -> (ScopedSeq e, [StableSharingSeq])-recoverSharingSeq config seq-  = let-        (rootSeq, accOccMap) = unsafePerformIO $ do-          accOccMap       <- newASTHashTable-          (seq', _)       <- makeOccMapRootSeq config accOccMap 0 seq-          frozenAccOccMap <- freezeOccMap accOccMap--          return (seq', frozenAccOccMap)--        (ScopedSeq sharingSeq, (ns, _)) =-          determineScopesSeq config accOccMap rootSeq-    in-    (ScopedSeq sharingSeq, [a | SeqNodeCount a _ <- ns])---}----- Debugging--- -----------traceLine :: String -> String -> IO ()-traceLine header msg-  = Debug.traceIO Debug.dump_sharing-  $ header ++ ": " ++ msg--traceChunk :: String -> String -> IO ()-traceChunk header msg-  = Debug.traceIO Debug.dump_sharing-  $ header ++ "\n      " ++ msg--tracePure :: String -> String -> a -> a-tracePure header msg-  = Debug.trace Debug.dump_sharing-  $ header ++ ": " ++ msg-
− Data/Array/Accelerate/Trafo/Shrink.hs 
@@ -1,481 +0,0 @@-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns        #-}--- |--- Module      : Data.Array.Accelerate.Trafo.Shrink--- 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)------ The shrinking substitution arises as a restriction of beta-reduction to cases--- where the bound variable is used zero (dead-code elimination) or one (linear--- inlining) times. By simplifying terms, the shrinking reduction can expose--- opportunities for further optimisation.------ TODO: replace with a linear shrinking algorithm; e.g.------   * Andrew Appel & Trevor Jim, "Shrinking lambda expressions in linear time".------   * Nick Benton, Andrew Kennedy, Sam Lindley and Claudio Russo, "Shrinking---     Reductions in SML.NET"-----module Data.Array.Accelerate.Trafo.Shrink (--  -- Shrinking-  Shrink(..),-  ShrinkAcc, shrinkPreAcc, basicReduceAcc,--  -- Occurrence counting-  UsesOfAcc, usesOfPreAcc, usesOfExp,--) where---- standard library-import Data.Monoid-import Control.Applicative                              hiding ( Const )-import Prelude                                          hiding ( exp, seq )---- friends-import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Array.Sugar               hiding ( Any )-import Data.Array.Accelerate.Trafo.Base-import Data.Array.Accelerate.Trafo.Substitution--import qualified Data.Array.Accelerate.Debug            as Stats---class Shrink f where-  shrink  :: f -> f-  shrink' :: f -> (Bool, f)--  shrink = snd . shrink'--instance Kit acc => Shrink (PreOpenExp acc env aenv e) where-  shrink' = shrinkExp--instance Kit acc => Shrink (PreOpenFun acc env aenv f) where-  shrink' = shrinkFun----- Shrinking--- =========---- The shrinking substitution for scalar expressions. This is a restricted--- instance of beta-reduction to cases where the bound variable is used zero--- (dead-code elimination) or one (linear inlining) times.----shrinkExp :: Kit acc => PreOpenExp acc env aenv t -> (Bool, PreOpenExp acc env aenv t)-shrinkExp = Stats.substitution "shrink exp" . first getAny . shrinkE-  where-    -- If the bound variable is used at most this many times, it will be inlined-    -- into the body. In cases where it is not used at all, this is equivalent-    -- to dead-code elimination.-    ---    lIMIT :: Int-    lIMIT = 1--    shrinkE :: Kit acc => PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t)-    shrinkE exp = case exp of-      Let bnd body-        | Var _ <- bnd  -> Stats.inline "Var"   . yes $ shrinkE (inline body bnd)-        | uses <= lIMIT -> Stats.betaReduce msg . yes $ shrinkE (inline (snd body') (snd bnd'))-        | otherwise     -> Let <$> bnd' <*> body'-        where-          bnd'  = shrinkE bnd-          body' = shrinkE body-          uses  = usesOfExp ZeroIdx (snd body')--          msg   = case uses of-            0 -> "dead exp"-            _ -> "inline exp"   -- forced inlining when lIMIT > 1-      ---      Var idx                   -> pure (Var idx)-      Const c                   -> pure (Const c)-      Tuple t                   -> Tuple <$> shrinkT t-      Prj tup e                 -> Prj tup <$> shrinkE e-      IndexNil                  -> pure IndexNil-      IndexCons sl sz           -> IndexCons <$> shrinkE sl <*> shrinkE sz-      IndexHead sh              -> IndexHead <$> shrinkE sh-      IndexTail sh              -> IndexTail <$> shrinkE sh-      IndexSlice x ix sh        -> IndexSlice x <$> shrinkE ix <*> shrinkE sh-      IndexFull x ix sl         -> IndexFull x <$> shrinkE ix <*> shrinkE sl-      IndexAny                  -> pure IndexAny-      ToIndex sh ix             -> ToIndex <$> shrinkE sh <*> shrinkE ix-      FromIndex sh i            -> FromIndex <$> shrinkE sh <*> shrinkE i-      Cond p t e                -> Cond <$> shrinkE p <*> shrinkE t <*> shrinkE e-      While p f x               -> While <$> shrinkF p <*> shrinkF f <*> shrinkE x-      PrimConst c               -> pure (PrimConst c)-      PrimApp f x               -> PrimApp f <$> shrinkE x-      Index a sh                -> Index a <$> shrinkE sh-      LinearIndex a i           -> LinearIndex a <$> shrinkE i-      Shape a                   -> pure (Shape a)-      ShapeSize sh              -> ShapeSize <$> shrinkE sh-      Intersect sh sz           -> Intersect <$> shrinkE sh <*> shrinkE sz-      Union sh sz               -> Union <$> shrinkE sh <*> shrinkE sz-      Foreign ff f e            -> Foreign ff <$> shrinkF f <*> shrinkE e--    shrinkT :: Kit acc => Tuple (PreOpenExp acc env aenv) t -> (Any, Tuple (PreOpenExp acc env aenv) t)-    shrinkT NilTup        = pure NilTup-    shrinkT (SnocTup t e) = SnocTup <$> shrinkT t <*> shrinkE e--    shrinkF :: Kit acc => PreOpenFun acc env aenv t -> (Any, PreOpenFun acc env aenv t)-    shrinkF = first Any . shrinkFun--    first :: (a -> a') -> (a,b) -> (a',b)-    first f (x,y) = (f x, y)--    yes :: (Any, x) -> (Any, x)-    yes (_, x) = (Any True, x)--shrinkFun :: Kit acc => PreOpenFun acc env aenv f -> (Bool, PreOpenFun acc env aenv f)-shrinkFun (Lam f)  = Lam  <$> shrinkFun f-shrinkFun (Body b) = Body <$> shrinkExp b----- The shrinking substitution for array computations. This is further limited to--- dead-code elimination only, primarily because linear inlining may inline--- array computations into scalar expressions, which is generally not desirable.----type ShrinkAcc acc = forall aenv a.   acc aenv a -> acc aenv a-type ReduceAcc acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Maybe (PreOpenAcc acc aenv t)--shrinkPreAcc-    :: forall acc aenv arrs. ShrinkAcc acc -> ReduceAcc acc-    -> PreOpenAcc acc aenv arrs-    -> PreOpenAcc acc aenv arrs-shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrink acc" shrinkA-  where-    shrinkA :: PreOpenAcc acc aenv' a -> PreOpenAcc acc aenv' a-    shrinkA pacc = case pacc of-      Alet bnd body-        | Just reduct <- reduceAcc bnd' body'   -> shrinkA reduct-        | otherwise                             -> Alet bnd' body'-        where-          bnd'  = shrinkAcc bnd-          body' = shrinkAcc body-      ---      Avar ix                   -> Avar ix-      Atuple tup                -> Atuple (shrinkAT tup)-      Aprj tup a                -> Aprj tup (shrinkAcc a)-      Apply f a                 -> Apply (shrinkAF f) (shrinkAcc a)-      Aforeign ff af a          -> Aforeign ff af (shrinkAcc a)-      Acond p t e               -> Acond (shrinkE p) (shrinkAcc t) (shrinkAcc e)-      Awhile p f a              -> Awhile (shrinkAF p) (shrinkAF f) (shrinkAcc a)-      Use a                     -> Use a-      Unit e                    -> Unit (shrinkE e)-      Reshape e a               -> Reshape (shrinkE e) (shrinkAcc a)-      Generate e f              -> Generate (shrinkE e) (shrinkF f)-      Transform sh ix f a       -> Transform (shrinkE sh) (shrinkF ix) (shrinkF f) (shrinkAcc a)-      Replicate sl slix a       -> Replicate sl (shrinkE slix) (shrinkAcc a)-      Slice sl a slix           -> Slice sl (shrinkAcc a) (shrinkE slix)-      Map f a                   -> Map (shrinkF f) (shrinkAcc a)-      ZipWith f a1 a2           -> ZipWith (shrinkF f) (shrinkAcc a1) (shrinkAcc a2)-      Fold f z a                -> Fold (shrinkF f) (shrinkE z) (shrinkAcc a)-      Fold1 f a                 -> Fold1 (shrinkF f) (shrinkAcc a)-      FoldSeg f z a b           -> FoldSeg (shrinkF f) (shrinkE z) (shrinkAcc a) (shrinkAcc b)-      Fold1Seg f a b            -> Fold1Seg (shrinkF f) (shrinkAcc a) (shrinkAcc b)-      Scanl f z a               -> Scanl (shrinkF f) (shrinkE z) (shrinkAcc a)-      Scanl' f z a              -> Scanl' (shrinkF f) (shrinkE z) (shrinkAcc a)-      Scanl1 f a                -> Scanl1 (shrinkF f) (shrinkAcc a)-      Scanr f z a               -> Scanr (shrinkF f) (shrinkE z) (shrinkAcc a)-      Scanr' f z a              -> Scanr' (shrinkF f) (shrinkE z) (shrinkAcc a)-      Scanr1 f a                -> Scanr1 (shrinkF f) (shrinkAcc a)-      Permute f1 a1 f2 a2       -> Permute (shrinkF f1) (shrinkAcc a1) (shrinkF f2) (shrinkAcc a2)-      Backpermute sh f a        -> Backpermute (shrinkE sh) (shrinkF f) (shrinkAcc a)-      Stencil f b a             -> Stencil (shrinkF f) b (shrinkAcc a)-      Stencil2 f b1 a1 b2 a2    -> Stencil2 (shrinkF f) b1 (shrinkAcc a1) b2 (shrinkAcc a2)-      -- Collect s                 -> Collect (shrinkS s)--{---    shrinkS :: PreOpenSeq acc aenv' senv a -> PreOpenSeq acc aenv' senv a-    shrinkS seq =-      case seq of-        Producer p s -> Producer (shrinkP p) (shrinkS s)-        Consumer c   -> Consumer (shrinkC c)-        Reify ix     -> Reify ix--    shrinkP :: Producer acc aenv' senv a -> Producer acc aenv' senv a-    shrinkP p =-      case p of-        StreamIn arrs        -> StreamIn arrs-        ToSeq sl slix a      -> ToSeq sl slix (shrinkAcc a)-        MapSeq f x           -> MapSeq (shrinkAF f) x-        ChunkedMapSeq f x    -> ChunkedMapSeq (shrinkAF f) x-        ZipWithSeq f x y     -> ZipWithSeq (shrinkAF f) x y-        ScanSeq f e x        -> ScanSeq (shrinkF f) (shrinkE e) x--    shrinkC :: Consumer acc aenv' senv a -> Consumer acc aenv' senv a-    shrinkC c =-      case c of-        FoldSeq f e x        -> FoldSeq (shrinkF f) (shrinkE e) x-        FoldSeqFlatten f a x -> FoldSeqFlatten (shrinkAF f) (shrinkAcc a) x-        Stuple t             -> Stuple (shrinkCT t)--    shrinkCT :: Atuple (Consumer acc aenv' senv) t -> Atuple (Consumer acc aenv' senv) t-    shrinkCT NilAtup        = NilAtup-    shrinkCT (SnocAtup t c) = SnocAtup (shrinkCT t) (shrinkC c)---}--    shrinkE :: PreOpenExp acc env aenv' t -> PreOpenExp acc env aenv' t-    shrinkE exp = case exp of-      Let bnd body              -> Let (shrinkE bnd) (shrinkE body)-      Var idx                   -> Var idx-      Const c                   -> Const c-      Tuple t                   -> Tuple (shrinkT t)-      Prj tup e                 -> Prj tup (shrinkE e)-      IndexNil                  -> IndexNil-      IndexCons sl sz           -> IndexCons (shrinkE sl) (shrinkE sz)-      IndexHead sh              -> IndexHead (shrinkE sh)-      IndexTail sh              -> IndexTail (shrinkE sh)-      IndexSlice x ix sh        -> IndexSlice x (shrinkE ix) (shrinkE sh)-      IndexFull x ix sl         -> IndexFull x (shrinkE ix) (shrinkE sl)-      IndexAny                  -> IndexAny-      ToIndex sh ix             -> ToIndex (shrinkE sh) (shrinkE ix)-      FromIndex sh i            -> FromIndex (shrinkE sh) (shrinkE i)-      Cond p t e                -> Cond (shrinkE p) (shrinkE t) (shrinkE e)-      While p f x               -> While (shrinkF p) (shrinkF f) (shrinkE x)-      PrimConst c               -> PrimConst c-      PrimApp f x               -> PrimApp f (shrinkE x)-      Index a sh                -> Index (shrinkAcc a) (shrinkE sh)-      LinearIndex a i           -> LinearIndex (shrinkAcc a) (shrinkE i)-      Shape a                   -> Shape (shrinkAcc a)-      ShapeSize sh              -> ShapeSize (shrinkE sh)-      Intersect sh sz           -> Intersect (shrinkE sh) (shrinkE sz)-      Union sh sz               -> Union (shrinkE sh) (shrinkE sz)-      Foreign ff f e            -> Foreign ff (shrinkF f) (shrinkE e)--    shrinkF :: PreOpenFun acc env aenv' f -> PreOpenFun acc env aenv' f-    shrinkF (Lam f)  = Lam (shrinkF f)-    shrinkF (Body b) = Body (shrinkE b)--    shrinkT :: Tuple (PreOpenExp acc env aenv') t -> Tuple (PreOpenExp acc env aenv') t-    shrinkT NilTup        = NilTup-    shrinkT (SnocTup t e) = shrinkT t `SnocTup` shrinkE e--    shrinkAT :: Atuple (acc aenv') t -> Atuple (acc aenv') t-    shrinkAT NilAtup        = NilAtup-    shrinkAT (SnocAtup t a) = shrinkAT t `SnocAtup` shrinkAcc a--    shrinkAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f-    shrinkAF (Alam  f) = Alam (shrinkAF f)-    shrinkAF (Abody a) = Abody (shrinkAcc a)----- A somewhat hacky example implementation of the reduction step. It requires a--- function to open the recursive closure of an array term.----basicReduceAcc-    :: Kit acc-    => (forall aenv a. acc aenv a -> PreOpenAcc acc aenv a)-    -> UsesOfAcc acc-    -> ReduceAcc acc-basicReduceAcc unwrapAcc countAcc (unwrapAcc -> bnd) body@(unwrapAcc -> pbody)-  | Avar _ <- bnd       = Stats.inline "Avar"  . Just $ rebuildA (subAtop bnd) pbody-  | uses <= lIMIT       = Stats.betaReduce msg . Just $ rebuildA (subAtop bnd) pbody-  | otherwise           = Nothing-  where-    -- If the bound variable is used at most this many times, it will be inlined-    -- into the body. Since this implies an array computation could be inlined-    -- into a scalar expression, we limit the shrinking reduction for array-    -- computations to dead-code elimination only.-    ---    lIMIT = 0--    uses  = countAcc True ZeroIdx body-    msg   = case uses of-      0 -> "dead acc"-      _ -> "inline acc"         -- forced inlining when lIMIT > 1----- Occurrence Counting--- ===================---- Count the number of occurrences an in-scope scalar expression bound at the--- given variable index recursively in a term.----usesOfExp :: forall acc env aenv s t. Idx env s -> PreOpenExp acc env aenv t -> Int-usesOfExp idx = countE-  where-    countE :: PreOpenExp acc env aenv e -> Int-    countE exp = case exp of-      Var this-        | Just Refl <- match this idx   -> 1-        | otherwise                     -> 0-      ---      Let bnd body              -> countE bnd + usesOfExp (SuccIdx idx) body-      Const _                   -> 0-      Tuple t                   -> countT t-      Prj _ e                   -> countE e-      IndexNil                  -> 0-      IndexCons sl sz           -> countE sl + countE sz-      IndexHead sh              -> countE sh-      IndexTail sh              -> countE sh-      IndexSlice _ ix sh        -> countE ix + countE sh-      IndexFull _ ix sl         -> countE ix + countE sl-      IndexAny                  -> 0-      ToIndex sh ix             -> countE sh + countE ix-      FromIndex sh i            -> countE sh + countE i-      Cond p t e                -> countE p  + countE t + countE e-      While p f x               -> countE x  + countF idx p + countF idx f-      PrimConst _               -> 0-      PrimApp _ x               -> countE x-      Index _ sh                -> countE sh-      LinearIndex _ i           -> countE i-      Shape _                   -> 0-      ShapeSize sh              -> countE sh-      Intersect sh sz           -> countE sh + countE sz-      Union sh sz               -> countE sh + countE sz-      Foreign _ _ e             -> countE e--    countF :: Idx env' s -> PreOpenFun acc env' aenv f -> Int-    countF idx' (Lam  f) = countF (SuccIdx idx') f-    countF idx' (Body b) = usesOfExp idx' b--    countT :: Tuple (PreOpenExp acc env aenv) e -> Int-    countT NilTup        = 0-    countT (SnocTup t e) = countT t + countE e----- Count the number of occurrences of the array term bound at the given--- environment index. If the first argument is 'True' then it includes in the--- total uses of the variable for 'Shape' information, otherwise not.----type UsesOfAcc acc = forall aenv s t. Bool -> Idx aenv s -> acc aenv t -> Int--usesOfPreAcc-    :: forall acc aenv s t.-       Bool-    -> UsesOfAcc  acc-    -> Idx            aenv s-    -> PreOpenAcc acc aenv t-    -> Int-usesOfPreAcc withShape countAcc idx = count-  where-    countIdx :: Idx aenv a -> Int-    countIdx this-        | Just Refl <- match this idx   = 1-        | otherwise                     = 0--    count :: PreOpenAcc acc aenv a -> Int-    count pacc = case pacc of-      Avar this                 -> countIdx this-      ---      Alet bnd body             -> countA bnd + countAcc withShape (SuccIdx idx) body-      Atuple tup                -> countAT tup-      Aprj _ a                  -> countA a     -- special case discount?-      Apply _ a                 -> countA a-      Aforeign _ _ a            -> countA a-      Acond p t e               -> countE p  + countA t + countA e-      Awhile _ _ a              -> countA a-      Use _                     -> 0-      Unit e                    -> countE e-      Reshape e a               -> countE e  + countA a-      Generate e f              -> countE e  + countF f-      Transform sh ix f a       -> countE sh + countF ix + countF f  + countA a-      Replicate _ sh a          -> countE sh + countA a-      Slice _ a sl              -> countE sl + countA a-      Map f a                   -> countF f  + countA a-      ZipWith f a1 a2           -> countF f  + countA a1 + countA a2-      Fold f z a                -> countF f  + countE z  + countA a-      Fold1 f a                 -> countF f  + countA a-      FoldSeg f z a s           -> countF f  + countE z  + countA a  + countA s-      Fold1Seg f a s            -> countF f  + countA a  + countA s-      Scanl f z a               -> countF f  + countE z  + countA a-      Scanl' f z a              -> countF f  + countE z  + countA a-      Scanl1 f a                -> countF f  + countA a-      Scanr f z a               -> countF f  + countE z  + countA a-      Scanr' f z a              -> countF f  + countE z  + countA a-      Scanr1 f a                -> countF f  + countA a-      Permute f1 a1 f2 a2       -> countF f1 + countA a1 + countF f2 + countA a2-      Backpermute sh f a        -> countE sh + countF f  + countA a-      Stencil f _ a             -> countF f  + countA a-      Stencil2 f _ a1 _ a2      -> countF f  + countA a1 + countA a2-      -- Collect s                 -> countS s--    countE :: PreOpenExp acc env aenv e -> Int-    countE exp = case exp of-      Let bnd body              -> countE bnd + countE body-      Var _                     -> 0-      Const _                   -> 0-      Tuple t                   -> countT t-      Prj _ e                   -> countE e-      IndexNil                  -> 0-      IndexCons sl sz           -> countE sl + countE sz-      IndexHead sh              -> countE sh-      IndexTail sh              -> countE sh-      IndexSlice _ ix sh        -> countE ix + countE sh-      IndexFull _ ix sl         -> countE ix + countE sl-      IndexAny                  -> 0-      ToIndex sh ix             -> countE sh + countE ix-      FromIndex sh i            -> countE sh + countE i-      Cond p t e                -> countE p  + countE t + countE e-      While p f x               -> countF p  + countF f + countE x-      PrimConst _               -> 0-      PrimApp _ x               -> countE x-      Index a sh                -> countA a + countE sh-      LinearIndex a i           -> countA a + countE i-      ShapeSize sh              -> countE sh-      Intersect sh sz           -> countE sh + countE sz-      Union sh sz               -> countE sh + countE sz-      Shape a-        | withShape             -> countA a-        | otherwise             -> 0-      Foreign _ _ e             -> countE e--    countA :: acc aenv a -> Int-    countA = countAcc withShape idx--    -- countAF :: PreOpenAfun acc aenv' f-    --         -> Idx aenv' s-    --         -> Int-    -- countAF (Alam f)  v = countAF f (SuccIdx v)-    -- countAF (Abody a) v = countAcc withShape v a--    countF :: PreOpenFun acc env aenv f -> Int-    countF (Lam  f) = countF f-    countF (Body b) = countE b--    countT :: Tuple (PreOpenExp acc env aenv) e -> Int-    countT NilTup        = 0-    countT (SnocTup t e) = countT t + countE e--    countAT :: Atuple (acc aenv) a -> Int-    countAT NilAtup        = 0-    countAT (SnocAtup t a) = countAT t + countA a--{---    countS :: PreOpenSeq acc aenv senv arrs -> Int-    countS seq =-      case seq of-        Producer p s -> countP p + countS s-        Consumer c   -> countC c-        Reify _      -> 0--    countP :: Producer acc aenv senv arrs -> Int-    countP p =-      case p of-        StreamIn _           -> 0-        ToSeq _ _ a          -> countA a-        MapSeq f _           -> countAF f idx-        ChunkedMapSeq f _    -> countAF f idx-        ZipWithSeq f _ _     -> countAF f idx-        ScanSeq f e _        -> countF f + countE e--    countC :: Consumer acc aenv senv arrs -> Int-    countC c =-      case c of-        FoldSeq f e _        -> countF f + countE e-        FoldSeqFlatten f a _ -> countAF f idx + countA a-        Stuple t             -> countCT t--    countCT :: Atuple (Consumer acc aenv senv) t' -> Int-    countCT NilAtup        = 0-    countCT (SnocAtup t c) = countCT t + countC c---}-
− Data/Array/Accelerate/Trafo/Simplify.hs 
@@ -1,701 +0,0 @@-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE PatternGuards        #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns         #-}--- |--- Module      : Data.Array.Accelerate.Trafo.Simplify--- 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.Trafo.Simplify (--  Simplify(..),--) where---- standard library-import Data.Label-import Data.List                                        ( nubBy )-import Data.Maybe-import Data.Monoid-import Data.Typeable-import Text.Printf-import Control.Applicative                              hiding ( Const )-import Prelude                                          hiding ( exp, iterate )---- friends-import Data.Array.Accelerate.AST                        hiding ( prj )-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Analysis.Shape-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Trafo.Algebra-import Data.Array.Accelerate.Trafo.Base-import Data.Array.Accelerate.Trafo.Shrink-import Data.Array.Accelerate.Trafo.Substitution-import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Sugar                ( Array, Elt(eltType), Shape, Slice, toElt, fromElt, Z(..), (:.)(..)-                                                        , Tuple(..), IsTuple, fromTuple, TupleRepr, shapeToList )-import qualified Data.Array.Accelerate.Debug            as Stats---class Simplify f where-  simplify :: f -> f--instance Kit acc => Simplify (PreFun acc aenv f) where-  simplify = simplifyFun--instance (Kit acc, Elt e) => Simplify (PreExp acc aenv e) where-  simplify = simplifyExp----- Scalar optimisations--- ====================---- Common subexpression elimination finds computations that are performed at--- least twice on a given execution path and eliminates the second and later--- occurrences, replacing them with uses of saved values. This implements a--- simplified version of that idea, where we look for the expressions of the--- form:------   let x = e1 in e2------ and replace all occurrences of e1 in e2 with x. This is not full redundancy--- elimination, but good enough to catch some cases, and in particular those--- likely to be introduced by scalar composition of terms in the fusion process.------ While it may seem that common subexpression elimination is always worthwhile,--- as it reduces the number of arithmetic operations performed, this is not--- necessarily advantageous. The simplest case in which it may not be desirable--- is if it causes a register to be occupied for a long time in order to hold--- the shared expression's value, which hence reduces the number of registers--- available for other uses. Even worse is if the value has to be spilled to--- memory because there are insufficient registers available. We sidestep this--- tricky and target-dependent issue by, for now, simply ignoring it.----localCSE :: (Kit acc, Elt a)-         => Gamma      acc env env aenv-         -> PreOpenExp acc env     aenv a-         -> PreOpenExp acc (env,a) aenv b-         -> Maybe (PreOpenExp acc env aenv b)-localCSE env bnd body-  | Just ix <- lookupExp env bnd = Stats.ruleFired "CSE" . Just $ inline body (Var ix)-  | otherwise                    = Nothing---- Common subexpression elimination, which attempts to match the given--- expression against something already bound in the environment. This can occur--- due to simplification, in which case we replace the entire subterm with x.------ > let x = e in .. e ..----globalCSE :: (Kit acc, Elt t)-          => Gamma      acc env env aenv-          -> PreOpenExp acc env     aenv t-          -> Maybe (PreOpenExp acc env aenv t)-globalCSE env exp-  | Just ix <- lookupExp env exp = Stats.ruleFired "CSE" . Just $ Var ix-  | otherwise                    = Nothing---{----- Compared to regular Haskell, the scalar expression language of Accelerate is--- rather limited in order to meet the restrictions of what can be efficiently--- implemented on specialised hardware, such as GPUs. For example, to avoid--- excessive SIMD divergence, we do not support any form of recursion or--- iteration in scalar expressions. This harmonises well with the stratified--- design of the Accelerate language: collective array operations comprise many--- scalar computations that are executed in parallel, so for simplicity of--- scheduling these operations we would like some assurance that each scalar--- computation takes approximately the same time to execute as all others.------ However, some computations are naturally expressed in terms of iteration. For--- some problems, we can instead use generative techniques to implement the--- program by defining a single step of a recurrence relation as an Accelerate--- collective operation and using standard Haskell to unroll the loop a _fixed_--- number of times.------ However, this is outrageously slow because the intermediate values are--- written to memory at the end of every iteration. Luckily the fusion process--- will eliminate this intermediate memory traffic by combining the 'n'--- collective operations into a single operation with 'n' instances of the loop--- body. However, doing this we uncover an embarrassing secret: C compilers do--- not compile C code, they compile _idiomatic_ C code.------ This process recovers the iteration structure that was lost in the process of--- fusing the collective operations. This allows a backend to generate explicit--- loops in its target language.----recoverLoops-    :: (Kit acc, Elt b)-    => Gamma      acc env env aenv-    -> PreOpenExp acc env     aenv a-    -> PreOpenExp acc (env,a) aenv b-    -> Maybe (PreOpenExp acc env aenv b)-recoverLoops _ bnd e3-  -- To introduce scaler loops, we look for expressions of the form:-  ---  --   let x =-  --     let y = e1 in e2-  --   in e3-  ---  -- and if e2 and e3 are congruent, replace with:-  ---  --   iterate[2] (\y -> e2) e1-  ---  | Let e1 e2           <- bnd-  , Just Refl           <- matchEnvTop e2 e3-  , Just Refl           <- match e2 e3-  = Stats.ruleFired "loop recovery/intro" . Just-  $ Iterate (constant 2) e2 e1--  -- To merge expressions into a loop body, look for the pattern:-  ---  --   let x = iterate[n] f e1-  --   in e3-  ---  -- and if e3 matches the loop body, replace the let binding with the bare-  -- iteration with the trip count increased by one.-  ---  | Iterate n f e1      <- bnd-  , Just Refl           <- match f e3-  = Stats.ruleFired "loop recovery/merge" . Just-  $ Iterate (constant 1 `plus` n) f e1--  | otherwise-  = Nothing--  where-    plus :: PreOpenExp acc env aenv Int -> PreOpenExp acc env aenv Int -> PreOpenExp acc env aenv Int-    plus x y = PrimApp (PrimAdd numType) $ Tuple $ NilTup `SnocTup` x `SnocTup` y--    constant :: Int -> PreOpenExp acc env aenv Int-    constant i = Const ((),i)--    matchEnvTop :: (Elt s, Elt t)-                => PreOpenExp acc (env,s) aenv f-                -> PreOpenExp acc (env,t) aenv g-                -> Maybe (s :=: t)-    matchEnvTop _ _ = gcast Refl---}----- Walk a scalar expression applying simplifications to terms bottom-up.------ TODO: Look for particular patterns of expressions that can be replaced by---       something equivalent and simpler. In particular, indexing operations---       introduced by the fusion transformation. This would benefit from a---       rewrite rule schema.----simplifyOpenExp-    :: forall acc env aenv e. (Kit acc, Elt e)-    => Gamma acc env env aenv-    -> PreOpenExp acc env aenv e-    -> (Bool, PreOpenExp acc env aenv e)-simplifyOpenExp env = first getAny . cvtE-  where-    cvtE :: Elt t => PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t)-    cvtE exp | Just e <- globalCSE env exp = yes e-    cvtE exp = case exp of-      Let bnd body-        -- Just reduct <- recoverLoops env (snd bnd') (snd body') -> yes . snd $ cvtE reduct-        | Just reduct <- localCSE env (snd bnd') (snd body') -> yes . snd $ cvtE reduct-        | otherwise                                          -> Let <$> bnd' <*> body'-        where-          bnd'  = cvtE bnd-          env'  = PushExp env (snd bnd')-          body' = cvtE' (incExp env') body--      Var ix                    -> pure $ Var ix-      Const c                   -> pure $ Const c-      Tuple tup                 -> Tuple <$> cvtT tup-      Prj ix t                  -> prj env ix (cvtE t)-      IndexNil                  -> pure IndexNil-      IndexAny                  -> pure IndexAny-      IndexCons sh sz           -> indexCons (cvtE sh) (cvtE sz)-      IndexHead sh              -> indexHead (cvtE sh)-      IndexTail sh              -> indexTail (cvtE sh)-      IndexSlice x ix sh        -> IndexSlice x <$> cvtE ix <*> cvtE sh-      IndexFull x ix sl         -> IndexFull x <$> cvtE ix <*> cvtE sl-      ToIndex sh ix             -> toIndex (cvtE sh) (cvtE ix)-      FromIndex sh ix           -> fromIndex (cvtE sh) (cvtE ix)-      Cond p t e                -> cond (cvtE p) (cvtE t) (cvtE e)-      PrimConst c               -> pure $ PrimConst c-      PrimApp f x               -> (u<>v, fx)-        where-          (u, x') = cvtE x-          (v, fx) = evalPrimApp env f x'-      Index a sh                -> Index a <$> cvtE sh-      LinearIndex a i           -> LinearIndex a <$> cvtE i-      Shape a                   -> shape a-      ShapeSize sh              -> shapeSize (cvtE sh)-      Intersect s t             -> cvtE s `intersect` cvtE t-      Union s t                 -> cvtE s `union` cvtE t-      Foreign ff f e            -> Foreign ff <$> first Any (simplifyOpenFun EmptyExp f) <*> cvtE e-      While p f x               -> While <$> cvtF env p <*> cvtF env f <*> cvtE x--    cvtT :: Tuple (PreOpenExp acc env aenv) t -> (Any, Tuple (PreOpenExp acc env aenv) t)-    cvtT NilTup        = pure NilTup-    cvtT (SnocTup t e) = SnocTup <$> cvtT t <*> cvtE e--    cvtE' :: Elt e' => Gamma acc env' env' aenv -> PreOpenExp acc env' aenv e' -> (Any, PreOpenExp acc env' aenv e')-    cvtE' env' = first Any . simplifyOpenExp env'--    cvtF :: Gamma acc env' env' aenv -> PreOpenFun acc env' aenv f -> (Any, PreOpenFun acc env' aenv f)-    cvtF env' = first Any . simplifyOpenFun env'--    -- Return the minimal set of unique shapes to intersect. This is a bit-    -- inefficient, but the number of shapes is expected to be small so should-    -- be fine in practice.-    ---    intersect :: Shape t-              => (Any, PreOpenExp acc env aenv t)-              -> (Any, PreOpenExp acc env aenv t)-              -> (Any, PreOpenExp acc env aenv t)-    intersect (c1, sh1) (c2, sh2)-      | Nothing <- match sh sh' = Stats.ruleFired "intersect" (yes sh')-      | otherwise               = (c1 <> c2, sh')-      where-        sh      = Intersect sh1 sh2-        sh'     = foldl1 Intersect-                $ nubBy (\x y -> isJust (match x y))-                $ leaves sh1 ++ leaves sh2--        leaves :: Shape t => PreOpenExp acc env aenv t -> [PreOpenExp acc env aenv t]-        leaves (Intersect x y)  = leaves x ++ leaves y-        leaves rest             = [rest]--    -- Return the minimal set of unique shapes to take the union of. This is a bit-    -- inefficient, but the number of shapes is expected to be small so should-    -- be fine in practice.-    ---    union :: Shape t-          => (Any, PreOpenExp acc env aenv t)-          -> (Any, PreOpenExp acc env aenv t)-          -> (Any, PreOpenExp acc env aenv t)-    union (c1, sh1) (c2, sh2)-      | Nothing <- match sh sh' = Stats.ruleFired "union" (yes sh')-      | otherwise               = (c1 <> c2, sh')-      where-        sh      = Union sh1 sh2-        sh'     = foldl1 Union-                $ nubBy (\x y -> isJust (match x y))-                $ leaves sh1 ++ leaves sh2--        leaves :: Shape t => PreOpenExp acc env aenv t -> [PreOpenExp acc env aenv t]-        leaves (Union x y)  = leaves x ++ leaves y-        leaves rest         = [rest]---    -- Simplify conditional expressions, in particular by eliminating branches-    -- when the predicate is a known constant.-    ---    cond :: forall t. Elt t-         => (Any, PreOpenExp acc env aenv Bool)-         -> (Any, PreOpenExp acc env aenv t)-         -> (Any, PreOpenExp acc env aenv t)-         -> (Any, PreOpenExp acc env aenv t)-    cond p@(_,p') t@(_,t') e@(_,e')-      | Const True  <- p'        = Stats.knownBranch "True"      (yes t')-      | Const False <- p'        = Stats.knownBranch "False"     (yes e')-      | Just Refl <- match t' e' = Stats.knownBranch "redundant" (yes e')-      | otherwise                = Cond <$> p <*> t <*> e--    -- If we are projecting elements from a tuple structure or tuple of constant-    -- valued tuple, pick out the appropriate component directly.-    ---    -- Follow variable bindings, but only if they result in a simplification.-    ---    prj :: forall env' s t. (Elt s, Elt t, IsTuple t)-        => Gamma acc env' env' aenv-        -> TupleIdx (TupleRepr t) s-        -> (Any, PreOpenExp acc env' aenv t)-        -> (Any, PreOpenExp acc env' aenv s)-    prj env' ix top@(_,e) = case e of-      Tuple t                      -> Stats.inline "prj/Tuple" . yes $ prjT ix t-      Const c                      -> Stats.inline "prj/Const" . yes $ prjC ix (fromTuple (toElt c :: t))-      Var v   | Just x <- prjV v   -> Stats.inline "prj/Var"   . yes $ x-      Let a b | Just x <- prjL a b -> Stats.inline "prj/Let"   . yes $ x-      _                            -> Prj ix <$> top-      where-        prjT :: TupleIdx tup s -> Tuple (PreOpenExp acc env' aenv) tup -> PreOpenExp acc env' aenv s-        prjT ZeroTupIdx       (SnocTup _ v) = v-        prjT (SuccTupIdx idx) (SnocTup t _) = prjT idx t-#if __GLASGOW_HASKELL__ < 800-        prjT _                _             = error "DO MORE OF WHAT MAKES YOU HAPPY"-#endif--        prjC :: TupleIdx tup s -> tup -> PreOpenExp acc env' aenv s-        prjC ZeroTupIdx       (_,   v) = Const (fromElt v)-        prjC (SuccTupIdx idx) (tup, _) = prjC idx tup--        prjV :: Idx env' t -> Maybe (PreOpenExp acc env' aenv s)-        prjV var-          | e'      <- prjExp var env'-          , Nothing <- match e e'-          = case e' of-              -- Don't push through nested let-bindings; this leads to code explosion-              Let _ _                                    -> Nothing-              _ | (Any True, x) <- prj env' ix (pure e') -> Just x-              _                                          -> Nothing-          | otherwise-          = Nothing--        prjL :: Elt a-             => PreOpenExp acc env'     aenv a-             -> PreOpenExp acc (env',a) aenv t-             -> Maybe (PreOpenExp acc env' aenv s)-        prjL a b-          | (Any True, c) <- prj (incExp $ PushExp env' a) ix (pure b) = Just (Let a c)-        prjL _ _                                                       = Nothing---    -- Shape manipulations-    ---    indexCons :: (Slice sl, Elt sz)-              => (Any, PreOpenExp acc env aenv sl)-              -> (Any, PreOpenExp acc env aenv sz)-              -> (Any, PreOpenExp acc env aenv (sl :. sz))-    indexCons (_,IndexNil) (_,Const c)-      | Just c'         <- cast c       -- EltRepr Z ~ EltRepr ()-      = Stats.ruleFired "Z:.const" $ yes (Const c')-    indexCons (_,IndexNil) (_,IndexHead sz')-      | 1               <- expDim sz'   -- no type information that this is a 1D shape, hence gcast next-      , Just sh'        <- gcast sz'-      = Stats.ruleFired "Z:.indexHead" $ yes sh'-    indexCons (_,IndexTail sl') (_,IndexHead sz')-      | Just Refl       <- match sl' sz'-      = Stats.ruleFired "indexTail:.indexHead" $ yes sl'-    indexCons sl sz-      = IndexCons <$> sl <*> sz--    indexHead :: forall sl sz. (Slice sl, Elt sz) => (Any, PreOpenExp acc env aenv (sl :. sz)) -> (Any, PreOpenExp acc env aenv sz)-    indexHead (_, Const c)-      | _ :. sz <- toElt c :: sl :. sz  = Stats.ruleFired "indexHead/const"     $ yes (Const (fromElt sz))-    indexHead (_, IndexCons _ sz)       = Stats.ruleFired "indexHead/indexCons" $ yes sz-    indexHead sh                        = IndexHead <$> sh--    indexTail :: forall sl sz. (Slice sl, Elt sz) => (Any, PreOpenExp acc env aenv (sl :. sz)) -> (Any, PreOpenExp acc env aenv sl)-    indexTail (_, Const c)-      | sl :. _ <- toElt c :: sl :. sz  = Stats.ruleFired "indexTail/const"     $ yes (Const (fromElt sl))-    indexTail (_, IndexCons sl _)       = Stats.ruleFired "indexTail/indexCons" $ yes sl-    indexTail sh                        = IndexTail <$> sh--    shape :: forall sh t. (Shape sh, Elt t) => acc aenv (Array sh t) -> (Any, PreOpenExp acc env aenv sh)-    shape _-      | Just Refl <- matchTupleType (eltType (undefined::sh)) (eltType (undefined::Z))-      = Stats.ruleFired "shape/Z" $ yes (Const (fromElt Z))-    shape a-      = pure $ Shape a--    shapeSize :: forall sh. Shape sh => (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int)-    shapeSize (_, Const c) = Stats.ruleFired "shapeSize/const" $ yes (Const (product (shapeToList (toElt c :: sh))))-    shapeSize sh           = ShapeSize <$> sh--    toIndex :: forall sh. Shape sh => (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int)-    toIndex  (_,sh) (_,FromIndex sh' ix)-      | Just Refl <- match sh sh' = Stats.ruleFired "toIndex/fromIndex" $ yes ix-    toIndex sh ix                 = ToIndex <$> sh <*> ix--    fromIndex :: forall sh. Shape sh => (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) -> (Any, PreOpenExp acc env aenv sh)-    fromIndex  (_,sh) (_,ToIndex sh' ix)-      | Just Refl <- match sh sh' = Stats.ruleFired "fromIndex/toIndex" $ yes ix-    fromIndex sh ix               = FromIndex <$> sh <*> ix--    first :: (a -> a') -> (a,b) -> (a',b)-    first f (x,y) = (f x, y)--    yes :: x -> (Any, x)-    yes x = (Any True, x)----- Simplification for open functions----simplifyOpenFun-    :: Kit acc-    => Gamma acc env env aenv-    -> PreOpenFun acc env aenv f-    -> (Bool, PreOpenFun acc env aenv f)-simplifyOpenFun env (Body e) = Body <$> simplifyOpenExp env  e-simplifyOpenFun env (Lam f)  = Lam  <$> simplifyOpenFun env' f-  where-    env' = incExp env `PushExp` Var ZeroIdx----- Simplify closed expressions and functions. The process is applied--- repeatedly until no more changes are made.----simplifyExp :: (Elt t, Kit acc) => PreExp acc aenv t -> PreExp acc aenv t-simplifyExp = iterate summariseOpenExp (simplifyOpenExp EmptyExp)--simplifyFun :: Kit acc => PreFun acc aenv f -> PreFun acc aenv f-simplifyFun = iterate summariseOpenFun (simplifyOpenFun EmptyExp)----- NOTE: [Simplifier iterations]------ Run the simplification pass _before_ the shrinking step. There are cases--- where it is better to run shrinking first, and then simplification would--- complete in a single step, but the converse is also true. However, as--- shrinking can remove some structure of the let bindings, which might be--- useful for the transformations (e.g. loop recovery) we want to maintain this--- information for at least the first pass.------ We always apply the simplification step once. Following this, we iterate--- shrinking and simplification until the expression no longer changes. Both--- shrink and simplify return a boolean indicating whether any work was done; we--- stop as soon as either returns false.------ With internal checks on, we also issue a warning if the iteration limit is--- reached, but it was still possible to make changes to the expression.----{-# SPECIALISE iterate :: (Exp aenv t -> Stats) -> (Exp aenv t -> (Bool, Exp aenv t)) -> Exp aenv t -> Exp aenv t #-}-{-# SPECIALISE iterate :: (Fun aenv t -> Stats) -> (Fun aenv t -> (Bool, Fun aenv t)) -> Fun aenv t -> Fun aenv t #-}--iterate-    :: forall f a. (Match f, Shrink (f a))-    => (f a -> Stats)-    -> (f a -> (Bool, f a))-    -> f a-    -> f a-iterate summarise f = fix 1 . setup-  where-    -- The maximum number of simplifier iterations. To be conservative and avoid-    -- excessive run times, we (should) set this value very low.-    ---    -- TODO: make this tunable via debug flags.-    ---    lIMIT       = 25--    simplify'   = Stats.simplifierDone . f-    setup x     = Stats.trace Stats.dump_simpl_iterations (msg 0 "init" x)-                $ snd (trace 1 "simplify" (simplify' x))--    fix :: Int -> f a -> f a-    fix i x0-      | i > lIMIT       = $internalWarning "simplify" "iteration limit reached" (not (x0 ==^ f x0)) x0-      | not shrunk      = x1-      | not simplified  = x2-      | otherwise       = fix (i+1) x2-      where-        (shrunk,     x1) = trace i "shrink"   $ shrink' x0-        (simplified, x2) = trace i "simplify" $ simplify' x1--    -- debugging support-    ---    u ==^ (_,v)         = isJust (match u v)--    trace i s v@(changed,x)-      | changed         = Stats.trace Stats.dump_simpl_iterations (msg i s x) v-      | otherwise       = v--    msg :: Int -> String -> f a -> String-    msg i s x = printf "simpl-iters/%-8s [%d]: %s" s i (ppr x)--    ppr :: f a -> String-    ppr = show . summarise----- Debugging support--- -------------------data Stats = Stats-  { _terms    :: {-# UNPACK #-} !Int-  , _types    :: {-# UNPACK #-} !Int-  , _binders  :: {-# UNPACK #-} !Int-  , _vars     :: {-# UNPACK #-} !Int-  , _ops      :: {-# UNPACK #-} !Int-  }--instance Show Stats where-  show (Stats a b c d e) =-    printf "terms = %d, types = %d, lets = %d, vars = %d, primops = %d" a b c d e---- Rather than using the TH deriving mechanism, otherwise the summarise*--- functions will not be in scope for the above.----terms, types, binders, vars, ops :: Stats :-> Int-terms   = lens _terms   (\f Stats{..} -> Stats { _terms   = f _terms, ..})-types   = lens _types   (\f Stats{..} -> Stats { _types   = f _types, ..})-binders = lens _binders (\f Stats{..} -> Stats { _binders = f _binders, ..})-vars    = lens _vars    (\f Stats{..} -> Stats { _vars    = f _vars, ..})-ops     = lens _ops     (\f Stats{..} -> Stats { _ops     = f _ops, ..})--infixl 1 &-(&) :: a -> (a -> b) -> b-(&) x f = f x--infixr 4 +~-(+~) :: Num a => f :-> a -> a -> f -> f-(+~) l c s = modify l (+c) s--infixl 6 +++-(+++) :: Stats -> Stats -> Stats-Stats a1 b1 c1 d1 e1 +++ Stats a2 b2 c2 d2 e2 = Stats (a1+a2) (b1+b2) (c1+c2) (d1+d2) (e1+e2)--summariseOpenFun :: PreOpenFun acc env aenv f -> Stats-summariseOpenFun (Body e) = summariseOpenExp e & terms +~ 1-summariseOpenFun (Lam f)  = summariseOpenFun f & terms +~ 1 & binders +~ 1--summariseOpenExp :: PreOpenExp acc env aenv t -> Stats-summariseOpenExp = modify terms (+1) . goE-  where-    zero = Stats 0 0 0 0 0--    travE :: PreOpenExp acc env aenv t -> Stats-    travE = summariseOpenExp--    travF :: PreOpenFun acc env aenv t -> Stats-    travF = summariseOpenFun--    travA :: acc aenv a -> Stats-    travA _ = zero & vars +~ 1  -- assume an array index, else we should have failed elsewhere--    travT :: Tuple (PreOpenExp acc env aenv) t -> Stats-    travT NilTup        = zero & terms +~ 1-    travT (SnocTup t e) = travT t +++ travE e & terms +~ 1--    travTix :: TupleIdx t e -> Stats-    travTix ZeroTupIdx     = zero & terms +~ 1-    travTix (SuccTupIdx t) = travTix t & terms +~ 1--    travC :: PrimConst c -> Stats-    travC (PrimMinBound t) = travBoundedType t & terms +~ 1-    travC (PrimMaxBound t) = travBoundedType t & terms +~ 1-    travC (PrimPi t)       = travFloatingType t & terms +~ 1--    travNonNumType :: NonNumType t -> Stats-    travNonNumType _ = zero & types +~ 1--    travIntegralType :: IntegralType t -> Stats-    travIntegralType _ = zero & types +~ 1--    travFloatingType :: FloatingType t -> Stats-    travFloatingType _ = zero & types +~ 1--    travNumType :: NumType t -> Stats-    travNumType (IntegralNumType t) = travIntegralType t & types +~ 1-    travNumType (FloatingNumType t) = travFloatingType t & types +~ 1--    travBoundedType :: BoundedType t -> Stats-    travBoundedType (IntegralBoundedType t) = travIntegralType t & types +~ 1-    travBoundedType (NonNumBoundedType t)   = travNonNumType t & types +~ 1--    travScalarType :: ScalarType t -> Stats-    travScalarType (NumScalarType t)    = travNumType t & types +~ 1-    travScalarType (NonNumScalarType t) = travNonNumType t & types +~ 1--    -- The scrutinee has already been counted-    goE :: PreOpenExp acc env aenv t -> Stats-    goE exp =-      case exp of-        Let bnd body          -> travE bnd +++ travE body & binders +~ 1-        Var{}                 -> zero & vars +~ 1-        Foreign _ _ x         -> travE x & terms +~ 1   -- +1 for asm, ignore fallback impls.-        Const{}               -> zero-        Tuple tup             -> travT tup & terms +~ 1-        Prj ix e              -> travTix ix +++ travE e-        IndexNil              -> zero-        IndexCons sh sz       -> travE sh +++ travE sz-        IndexHead sh          -> travE sh-        IndexTail sh          -> travE sh-        IndexAny              -> zero-        IndexSlice _ slix sh  -> travE slix +++ travE sh & terms +~ 1 -- +1 for sliceIndex-        IndexFull _ slix sl   -> travE slix +++ travE sl & terms +~ 1 -- +1 for sliceIndex-        ToIndex sh ix         -> travE sh +++ travE ix-        FromIndex sh ix       -> travE sh +++ travE ix-        Cond p t e            -> travE p +++ travE t +++ travE e-        While p f x           -> travF p +++ travF f +++ travE x-        PrimConst c           -> travC c-        Index a ix            -> travA a +++ travE ix-        LinearIndex a ix      -> travA a +++ travE ix-        Shape a               -> travA a-        ShapeSize sh          -> travE sh-        Intersect sh1 sh2     -> travE sh1 +++ travE sh2-        Union sh1 sh2         -> travE sh1 +++ travE sh2-        PrimApp f x           -> travPrimFun f +++ travE x--    travPrimFun :: PrimFun f -> Stats-    travPrimFun = modify ops (+1) . goF-      where-        goF :: PrimFun f -> Stats-        goF fun =-          case fun of-            PrimAdd                t -> travNumType t-            PrimSub                t -> travNumType t-            PrimMul                t -> travNumType t-            PrimNeg                t -> travNumType t-            PrimAbs                t -> travNumType t-            PrimSig                t -> travNumType t-            PrimQuot               t -> travIntegralType t-            PrimRem                t -> travIntegralType t-            PrimQuotRem            t -> travIntegralType t-            PrimIDiv               t -> travIntegralType t-            PrimMod                t -> travIntegralType t-            PrimDivMod             t -> travIntegralType t-            PrimBAnd               t -> travIntegralType t-            PrimBOr                t -> travIntegralType t-            PrimBXor               t -> travIntegralType t-            PrimBNot               t -> travIntegralType t-            PrimBShiftL            t -> travIntegralType t-            PrimBShiftR            t -> travIntegralType t-            PrimBRotateL           t -> travIntegralType t-            PrimBRotateR           t -> travIntegralType t-            PrimPopCount           t -> travIntegralType t-            PrimCountLeadingZeros  t -> travIntegralType t-            PrimCountTrailingZeros t -> travIntegralType t-            PrimFDiv               t -> travFloatingType t-            PrimRecip              t -> travFloatingType t-            PrimSin                t -> travFloatingType t-            PrimCos                t -> travFloatingType t-            PrimTan                t -> travFloatingType t-            PrimAsin               t -> travFloatingType t-            PrimAcos               t -> travFloatingType t-            PrimAtan               t -> travFloatingType t-            PrimSinh               t -> travFloatingType t-            PrimCosh               t -> travFloatingType t-            PrimTanh               t -> travFloatingType t-            PrimAsinh              t -> travFloatingType t-            PrimAcosh              t -> travFloatingType t-            PrimAtanh              t -> travFloatingType t-            PrimExpFloating        t -> travFloatingType t-            PrimSqrt               t -> travFloatingType t-            PrimLog                t -> travFloatingType t-            PrimFPow               t -> travFloatingType t-            PrimLogBase            t -> travFloatingType t-            PrimTruncate         f i -> travFloatingType f +++ travIntegralType i-            PrimRound            f i -> travFloatingType f +++ travIntegralType i-            PrimFloor            f i -> travFloatingType f +++ travIntegralType i-            PrimCeiling          f i -> travFloatingType f +++ travIntegralType i-            PrimIsNaN              t -> travFloatingType t-            PrimIsInfinite         t -> travFloatingType t-            PrimAtan2              t -> travFloatingType t-            PrimLt                 t -> travScalarType t-            PrimGt                 t -> travScalarType t-            PrimLtEq               t -> travScalarType t-            PrimGtEq               t -> travScalarType t-            PrimEq                 t -> travScalarType t-            PrimNEq                t -> travScalarType t-            PrimMax                t -> travScalarType t-            PrimMin                t -> travScalarType t-            PrimLAnd                 -> zero-            PrimLOr                  -> zero-            PrimLNot                 -> zero-            PrimOrd                  -> zero-            PrimChr                  -> zero-            PrimBoolToInt            -> zero-            PrimFromIntegral     i n -> travIntegralType i +++ travNumType n-            PrimToFloating       n f -> travNumType n +++ travFloatingType f-            PrimCoerce           a b -> travScalarType a +++ travScalarType b-
− Data/Array/Accelerate/Trafo/Substitution.hs 
@@ -1,597 +0,0 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE KindSignatures      #-}-{-# LANGUAGE PatternGuards       #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Trafo.Substitution--- 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.Trafo.Substitution (--  -- ** Renaming & Substitution-  inline, substitute, compose,-  subTop, subAtop,--  -- ** Weakening-  (:>), Sink(..), SinkExp(..),--  -- ** Strengthening-  (:?>), strengthen, strengthenE,--  -- ** Rebuilding terms-  RebuildAcc, Rebuildable(..), RebuildableAcc,-  RebuildableExp(..), RebuildTup(..)--) where--import Control.Applicative                              hiding ( Const )-import Prelude                                          hiding ( exp, seq )--import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Array.Sugar                ( Elt, Arrays, Tuple(..), Atuple(..) )-import qualified Data.Array.Accelerate.Debug.Stats      as Stats----- NOTE: [Renaming and Substitution]------ To do things like renaming and substitution, we need some operation on--- variables that we push structurally through terms, applying to each variable.--- We have a type preserving but environment changing operation:------   v :: forall t. Idx env t -> f env' aenv t------ The crafty bit is that 'f' might represent variables (for renaming) or terms--- (for substitutions). The demonic forall, --- which is to say that the--- quantifier is in a position which gives us obligation, not opportunity ------ forces us to respect type: when pattern matching detects the variable we care--- about, happily we discover that it has the type we must respect. The demon is--- not so free to mess with us as one might fear at first.------ We then lift this to an operation which traverses terms and rebuild them--- after applying 'v' to the variables:------   rebuildPartial v :: OpenExp env aenv t -> OpenExp env' aenv t------ The Syntactic class tells us what we need to know about 'f' if we want to be--- able to rebuildPartial terms. In essence, the crucial functionality is to propagate--- a class of operations on variables that is closed under shifting.----infixr `compose`-infixr `substitute`---- | Replace the first variable with the given expression. The environment--- shrinks.----inline :: RebuildableAcc acc-       => PreOpenExp acc (env, s) aenv t-       -> PreOpenExp acc env      aenv s-       -> PreOpenExp acc env      aenv t-inline f g = Stats.substitution "inline" $ rebuildE (subTop g) f---- | Replace an expression that uses the top environment variable with another.--- The result of the first is let bound into the second.----substitute :: (RebuildableAcc acc, Elt b, Elt c)-           => PreOpenExp acc (env, b) aenv c-           -> PreOpenExp acc (env, a) aenv b-           -> PreOpenExp acc (env, a) aenv c-substitute f g-  | Stats.substitution "substitute" False = undefined--  | Var ZeroIdx <- g    = f     -- don't rebind an identity function-  | otherwise           = Let g $ rebuildE split f-  where-    split :: Elt c => Idx (env,b) c -> PreOpenExp acc ((env,a),b) aenv c-    split ZeroIdx       = Var ZeroIdx-    split (SuccIdx ix)  = Var (SuccIdx (SuccIdx ix))----- | Composition of unary functions.----compose :: (RebuildableAcc acc, Elt c)-        => PreOpenFun acc env aenv (b -> c)-        -> PreOpenFun acc env aenv (a -> b)-        -> PreOpenFun acc env aenv (a -> c)-compose (Lam (Body f)) (Lam (Body g)) = Stats.substitution "compose" . Lam . Body $ substitute f g-compose _              _              = error "compose: impossible evaluation"--subTop :: Elt t => PreOpenExp acc env aenv s -> Idx (env, s) t -> PreOpenExp acc env aenv t-subTop s ZeroIdx      = s-subTop _ (SuccIdx ix) = Var ix--subAtop :: Arrays t => PreOpenAcc acc aenv s -> Idx (aenv, s) t -> PreOpenAcc acc aenv t-subAtop t ZeroIdx       = t-subAtop _ (SuccIdx idx) = Avar idx--data Identity a = Identity { runIdentity :: a }--instance Functor Identity where-  fmap f (Identity a) = Identity (f a)--instance Applicative Identity where-  Identity f <*> Identity a = Identity (f a)-  pure a                    = Identity a---- A class for rebuilding terms.----class Rebuildable f where-  {-# MINIMAL rebuildPartial #-}-  type AccClo f :: (* -> * -> *)--  rebuildPartial :: (Applicative f', SyntacticAcc fa)-                 => (forall a'. Arrays a' => Idx aenv a' -> f' (fa (AccClo f) aenv' a'))-                 -> f aenv  a-                 -> f' (f aenv' a)--  {-# INLINEABLE rebuildA #-}-  rebuildA :: (SyntacticAcc fa)-              => (forall a'. Arrays a' => Idx aenv a' -> fa (AccClo f) aenv' a')-              -> f aenv  a-              -> f aenv' a-  rebuildA av = runIdentity . rebuildPartial (Identity . av)---- A class for rebuilding scalar terms.----class RebuildableExp f where-  {-# MINIMAL rebuildPartialE #-}-  rebuildPartialE :: (Applicative f', SyntacticExp fe)-                  => (forall e'. Elt e' => Idx env e' -> f' (fe (AccClo (f env)) env' aenv e'))-                  -> f env aenv  e-                  -> f' (f env' aenv e)--  {-# INLINABLE rebuildE #-}-  rebuildE :: SyntacticExp fe-           => (forall e'. Elt e' => Idx env e' -> fe (AccClo (f env)) env' aenv e')-           -> f env aenv  e-           -> f env' aenv e-  rebuildE v = runIdentity . rebuildPartialE (Identity . v)---- Terms that are rebuildable and also recursive closures----type RebuildableAcc acc = (Rebuildable acc, AccClo acc ~ acc)---- We can use the same plumbing to rebuildPartial all the things we want to rebuild.----instance RebuildableAcc acc => Rebuildable (PreOpenExp acc env) where-  type AccClo (PreOpenExp acc env) = acc-  {-# INLINEABLE rebuildPartial #-}-  rebuildPartial = rebuildPreOpenExp rebuildPartial (pure . IE)--instance RebuildableAcc acc => Rebuildable (PreOpenFun acc env) where-  type AccClo (PreOpenFun acc env) = acc-  {-# INLINEABLE rebuildPartial #-}-  rebuildPartial = rebuildFun rebuildPartial (pure . IE)--instance RebuildableAcc acc => Rebuildable (PreOpenAcc acc) where-  type AccClo (PreOpenAcc acc) = acc-  {-# INLINEABLE rebuildPartial #-}-  rebuildPartial = rebuildPreOpenAcc rebuildPartial--instance RebuildableAcc acc => Rebuildable (PreOpenAfun acc) where-  type AccClo (PreOpenAfun acc) = acc-  {-# INLINEABLE rebuildPartial #-}-  rebuildPartial = rebuildAfun rebuildPartial---- Tuples have to be handled specially.-newtype RebuildTup acc env aenv t = RebuildTup { unRTup :: Tuple (PreOpenExp acc env aenv) t }--instance RebuildableAcc acc => Rebuildable (RebuildTup acc env) where-  type AccClo (RebuildTup acc env) = acc-  {-# INLINEABLE rebuildPartial #-}-  rebuildPartial v t = RebuildTup <$> rebuildTup rebuildPartial (pure . IE) v (unRTup t)--instance Rebuildable OpenAcc where-  type AccClo OpenAcc = OpenAcc-  {-# INLINEABLE rebuildPartial #-}-  rebuildPartial = rebuildOpenAcc--instance RebuildableAcc acc => RebuildableExp (PreOpenExp acc) where-  {-# INLINEABLE rebuildPartialE #-}-  rebuildPartialE v = rebuildPreOpenExp rebuildPartial v (pure . IA)--instance RebuildableAcc acc => RebuildableExp (PreOpenFun acc) where-  {-# INLINEABLE rebuildPartialE #-}-  rebuildPartialE v = rebuildFun rebuildPartial v (pure . IA)---- NOTE: [Weakening]------ Weakening is something we usually take for granted: every time you learn a--- new word, old sentences still make sense. If a conclusion is justified by a--- hypothesis, it is still justified if you add more hypotheses. Similarly, a--- term remains in scope if you bind more (fresh) variables. Weakening is the--- operation of shifting things from one scope to a larger scope in which new--- things have become meaningful, but no old things have vanished.------ When we use a named representation (or HOAS) we get weakening for free. But--- in the de Bruijn representation weakening takes work: you have to shift all--- variable references to make room for the new bindings.------- The type of shifting terms from one context into another----type env :> env' = forall t'. Idx env t' -> Idx env' t'--class Sink f where-  weaken :: env :> env' -> f env t -> f env' t--  -- TLM: We can't use this default instance because it doesn't lead to-  --      specialised code. Perhaps the INLINEABLE pragma is ignored: GHC bug?-  ---  -- {-# INLINEABLE weaken #-}-  -- default weaken :: Rebuildable f => env :> env' -> f env t -> f env' t-  -- weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)----instance Rebuildable f => Sink f where -- undecidable, incoherent---  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)--instance Sink Idx where-  {-# INLINEABLE weaken #-}-  weaken k = k--instance RebuildableAcc acc => Sink (PreOpenAcc acc) where-  {-# INLINEABLE weaken #-}-  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)--instance RebuildableAcc acc => Sink (PreOpenAfun acc) where-  {-# INLINEABLE weaken #-}-  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)--instance RebuildableAcc acc => Sink (PreOpenExp acc env) where-  {-# INLINEABLE weaken #-}-  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)--instance RebuildableAcc acc => Sink (PreOpenFun acc env) where-  {-# INLINEABLE weaken #-}-  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)--instance RebuildableAcc acc => Sink (RebuildTup acc env) where-  {-# INLINEABLE weaken #-}-  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)--instance RebuildableAcc acc => Sink (PreBoundary acc) where-  {-# INLINEABLE weaken #-}-  weaken k bndy =-    case bndy of-      Clamp      -> Clamp-      Mirror     -> Mirror-      Wrap       -> Wrap-      Constant c -> Constant c-      Function f -> Function (weaken k f)--instance Sink OpenAcc where-  {-# INLINEABLE weaken #-}-  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)---- This rewrite rule is disabled because 'weaken' is now part of a type class.--- As such, we cannot attach a NOINLINE pragma because it has many definitions.--- {-# RULES--- "weaken/weaken" forall a (v1 :: env' :> env'') (v2 :: env :> env').---     weaken v1 (weaken v2 a) = weaken (v1 . v2) a---  #-}--class SinkExp f where-  weakenE :: env :> env' -> f env aenv t -> f env' aenv t--  -- See comment in 'weaken'-  ---  -- {-# INLINEABLE weakenE #-}-  -- default weakenE :: RebuildableExp f => env :> env' -> f env aenv t -> f env' aenv t-  -- weakenE v = Stats.substitution "weakenE" . rebuildE (IE . v)--instance RebuildableAcc acc => SinkExp (PreOpenExp acc) where-  {-# INLINEABLE weakenE #-}-  weakenE v = Stats.substitution "weakenE" . rebuildE (IE . v)--instance RebuildableAcc acc => SinkExp (PreOpenFun acc) where-  {-# INLINEABLE weakenE #-}-  weakenE v = Stats.substitution "weakenE" . rebuildE (IE . v)---- See above for why this is disabled.--- {-# RULES--- "weakenE/weakenE" forall a (v1 :: env' :> env'') (v2 :: env :> env').---    weakenE v1 (weakenE v2 a) = weakenE (v1 . v2) a---  #-}---- NOTE: [Strengthening]------ Strengthening is the dual of weakening. Shifting terms from one scope to a--- smaller scope. Of course this is not always possible. If the term contains--- any variables not in the new environment, then it cannot be strengthened.--- This partial behaviour is captured with 'Maybe'.------- The type of partially shifting terms from one context into another.-type env :?> env' = forall t'. Idx env t' -> Maybe (Idx env' t')--{-# INLINEABLE strengthen #-}-strengthen :: Rebuildable f => env :?> env' -> f env t -> Maybe (f env' t)-strengthen k = rebuildPartial (fmap IA . k)--{-# INLINEABLE strengthenE #-}-strengthenE :: RebuildableExp f => env :?> env' -> f env aenv t -> Maybe (f env' aenv t)-strengthenE k = rebuildPartialE (fmap IE . k)---- Simultaneous Substitution ===================================================------- The scalar environment--- ---------------------- SEE: [Renaming and Substitution]--- SEE: [Weakening]----class SyntacticExp f where-  varIn         :: Elt t => Idx env t        -> f acc env aenv t-  expOut        :: Elt t => f acc env aenv t -> PreOpenExp acc env aenv t-  weakenExp     :: Elt t => RebuildAcc acc -> f acc env aenv t -> f acc (env, s) aenv t-  weakenExpAcc  :: Elt t => RebuildAcc acc -> f acc env aenv t -> f acc env (aenv, s) t--newtype IdxE (acc :: * -> * -> *) env aenv t = IE { unIE :: Idx env t }--instance SyntacticExp IdxE where-  varIn          = IE-  expOut         = Var . unIE-  weakenExp _    = IE . SuccIdx . unIE-  weakenExpAcc _ = IE . unIE--instance SyntacticExp PreOpenExp where-  varIn          = Var-  expOut         = id-  weakenExp k    = runIdentity . rebuildPreOpenExp k (Identity . weakenExp k . IE) (Identity . IA)-  weakenExpAcc k = runIdentity . rebuildPreOpenExp k (Identity . IE) (Identity . weakenAcc k . IA)--{-# INLINEABLE shiftE #-}-shiftE-    :: (Applicative f, SyntacticExp fe, Elt t)-    => RebuildAcc acc-    -> (forall t'. Elt t' => Idx env t' -> f (fe acc env' aenv t'))-    -> Idx       (env,  s)      t-    -> f (fe acc (env', s) aenv t)-shiftE _ _ ZeroIdx      = pure $ varIn ZeroIdx-shiftE k v (SuccIdx ix) = weakenExp k <$> (v ix)--{-# INLINEABLE rebuildPreOpenExp #-}-rebuildPreOpenExp-    :: (Applicative f, SyntacticExp fe, SyntacticAcc fa)-    => RebuildAcc acc-    -> (forall t'. Elt t'    => Idx env t'  -> f (fe acc env' aenv' t'))-    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-    -> PreOpenExp acc env  aenv t-    -> f (PreOpenExp acc env' aenv' t)-rebuildPreOpenExp k v av exp =-  case exp of-    Const c             -> pure (Const c)-    PrimConst c         -> pure (PrimConst c)-    IndexNil            -> pure IndexNil-    IndexAny            -> pure IndexAny-    Var ix              -> expOut       <$> v ix-    Let a b             -> Let          <$> rebuildPreOpenExp k v av a  <*> rebuildPreOpenExp k (shiftE k v) av b-    Tuple tup           -> Tuple        <$> rebuildTup k v av tup-    Prj tup e           -> Prj tup      <$> rebuildPreOpenExp k v av e-    IndexCons sh sz     -> IndexCons    <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av sz-    IndexHead sh        -> IndexHead    <$> rebuildPreOpenExp k v av sh-    IndexTail sh        -> IndexTail    <$> rebuildPreOpenExp k v av sh-    IndexSlice x ix sh  -> IndexSlice x <$> rebuildPreOpenExp k v av ix <*> rebuildPreOpenExp k v av sh-    IndexFull x ix sl   -> IndexFull x  <$> rebuildPreOpenExp k v av ix <*> rebuildPreOpenExp k v av sl-    ToIndex sh ix       -> ToIndex      <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av ix-    FromIndex sh ix     -> FromIndex    <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av ix-    Cond p t e          -> Cond         <$> rebuildPreOpenExp k v av p  <*> rebuildPreOpenExp k v av t  <*> rebuildPreOpenExp k v av e-    While p f x         -> While        <$> rebuildFun k v av p         <*> rebuildFun k v av f         <*> rebuildPreOpenExp k v av x-    PrimApp f x         -> PrimApp f    <$> rebuildPreOpenExp k v av x-    Index a sh          -> Index        <$> k av a                      <*> rebuildPreOpenExp k v av sh-    LinearIndex a i     -> LinearIndex  <$> k av a                      <*> rebuildPreOpenExp k v av i-    Shape a             -> Shape        <$> k av a-    ShapeSize sh        -> ShapeSize    <$> rebuildPreOpenExp k v av sh-    Intersect s t       -> Intersect    <$> rebuildPreOpenExp k v av s  <*> rebuildPreOpenExp k v av t-    Union s t           -> Union        <$> rebuildPreOpenExp k v av s  <*> rebuildPreOpenExp k v av t-    Foreign ff f e      -> Foreign ff f <$> rebuildPreOpenExp k v av e--{-# INLINEABLE rebuildTup #-}-rebuildTup-    :: (Applicative f, SyntacticExp fe, SyntacticAcc fa)-    => RebuildAcc acc-    -> (forall t'. Elt t'    => Idx env t'  -> f (fe acc env' aenv' t'))-    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-    -> Tuple (PreOpenExp acc env  aenv)  t-    -> f (Tuple (PreOpenExp acc env' aenv') t)-rebuildTup k v av tup =-  case tup of-    NilTup      -> pure NilTup-    SnocTup t e -> SnocTup <$> rebuildTup k v av t <*> rebuildPreOpenExp k v av e--{-# INLINEABLE rebuildFun #-}-rebuildFun-    :: (Applicative f, SyntacticExp fe, SyntacticAcc fa)-    => RebuildAcc acc-    -> (forall t'. Elt t'    => Idx env t'  -> f (fe acc env' aenv' t'))-    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-    -> PreOpenFun acc env  aenv  t-    -> f (PreOpenFun acc env' aenv' t)-rebuildFun k v av fun =-  case fun of-    Body e      -> Body <$> rebuildPreOpenExp k v av e-    Lam f       -> Lam  <$> rebuildFun k (shiftE k v) av f---- The array environment--- -------------------type RebuildAcc acc =-  forall aenv aenv' f fa a. (Applicative f, SyntacticAcc fa)-    => (forall a'. Arrays a' => Idx aenv a' -> f (fa acc aenv' a'))-    -> acc aenv  a-    -> f (acc aenv' a)--class SyntacticAcc f where-  avarIn        :: Arrays t => Idx aenv t     -> f acc aenv t-  accOut        :: Arrays t => f acc aenv t   -> PreOpenAcc acc aenv t-  weakenAcc     :: Arrays t => RebuildAcc acc -> f acc aenv t -> f acc (aenv, s) t--newtype IdxA (acc :: * -> * -> *) aenv t = IA { unIA :: Idx aenv t }--instance SyntacticAcc IdxA where-  avarIn         = IA-  accOut         = Avar . unIA-  weakenAcc _    = IA . SuccIdx . unIA--instance SyntacticAcc PreOpenAcc where-  avarIn        = Avar-  accOut        = id-  weakenAcc k   = runIdentity . rebuildPreOpenAcc k (Identity . weakenAcc k . IA)--{-# INLINEABLE shiftA #-}-shiftA-    :: (Applicative f, SyntacticAcc fa, Arrays t)-    => RebuildAcc acc-    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-    -> Idx         (aenv,  s) t-    -> f (fa   acc (aenv', s) t)-shiftA _ _ ZeroIdx      = pure $ avarIn ZeroIdx-shiftA k v (SuccIdx ix) = weakenAcc k <$> v ix--{-# INLINEABLE rebuildOpenAcc #-}-rebuildOpenAcc-    :: (Applicative f, SyntacticAcc fa)-    => (forall t'. Arrays t' => Idx aenv t' -> f (fa OpenAcc aenv' t'))-    -> OpenAcc aenv  t-    -> f (OpenAcc aenv' t)-rebuildOpenAcc av (OpenAcc acc) = OpenAcc <$> rebuildPreOpenAcc rebuildOpenAcc av acc--{-# INLINEABLE rebuildPreOpenAcc #-}-rebuildPreOpenAcc-    :: (Applicative f, SyntacticAcc fa)-    => RebuildAcc acc-    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-    -> PreOpenAcc acc aenv  t-    -> f (PreOpenAcc acc aenv' t)-rebuildPreOpenAcc k av acc =-  case acc of-    Use a                   -> pure (Use a)-    Alet a b                -> Alet         <$> k av a <*> k (shiftA k av) b-    Avar ix                 -> accOut       <$> av ix-    Atuple tup              -> Atuple       <$> rebuildAtup k av tup-    Aprj tup a              -> Aprj tup     <$> k av a-    Apply f a               -> Apply        <$> rebuildAfun k av f <*> k av a-    Acond p t e             -> Acond        <$> rebuildPreOpenExp k (pure . IE) av p <*> k av t <*> k av e-    Awhile p f a            -> Awhile       <$> rebuildAfun k av p <*> rebuildAfun k av f <*> k av a-    Unit e                  -> Unit         <$> rebuildPreOpenExp k (pure . IE) av e-    Reshape e a             -> Reshape      <$> rebuildPreOpenExp k (pure . IE) av e <*> k av a-    Generate e f            -> Generate     <$> rebuildPreOpenExp k (pure . IE) av e <*> rebuildFun k (pure . IE) av f-    Transform sh ix f a     -> Transform    <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av ix <*> rebuildFun k (pure . IE) av f <*> k av a-    Replicate sl slix a     -> Replicate sl <$> rebuildPreOpenExp k (pure . IE) av slix <*> k av a-    Slice sl a slix         -> Slice sl     <$> k av a <*> rebuildPreOpenExp k (pure . IE) av slix-    Map f a                 -> Map          <$> rebuildFun k (pure . IE) av f <*> k av a-    ZipWith f a1 a2         -> ZipWith      <$> rebuildFun k (pure . IE) av f <*> k av a1 <*> k av a2-    Fold f z a              -> Fold         <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a-    Fold1 f a               -> Fold1        <$> rebuildFun k (pure . IE) av f <*> k av a-    FoldSeg f z a s         -> FoldSeg      <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a <*> k av s-    Fold1Seg f a s          -> Fold1Seg     <$> rebuildFun k (pure . IE) av f <*> k av a <*> k av s-    Scanl f z a             -> Scanl        <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a-    Scanl' f z a            -> Scanl'       <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a-    Scanl1 f a              -> Scanl1       <$> rebuildFun k (pure . IE) av f <*> k av a-    Scanr f z a             -> Scanr        <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a-    Scanr' f z a            -> Scanr'       <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a-    Scanr1 f a              -> Scanr1       <$> rebuildFun k (pure . IE) av f <*> k av a-    Permute f1 a1 f2 a2     -> Permute      <$> rebuildFun k (pure . IE) av f1 <*> k av a1 <*> rebuildFun k (pure . IE) av f2 <*> k av a2-    Backpermute sh f a      -> Backpermute  <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av f <*> k av a-    Stencil f b a           -> Stencil      <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b  <*> k av a-    Stencil2 f b1 a1 b2 a2  -> Stencil2     <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b1 <*> k av a1 <*> rebuildBoundary k av b2 <*> k av a2-    -- Collect seq             -> Collect      <$> rebuildSeq k av seq-    Aforeign ff afun as     -> Aforeign ff afun <$> k av as--{-# INLINEABLE rebuildAfun #-}-rebuildAfun-    :: (Applicative f, SyntacticAcc fa)-    => RebuildAcc acc-    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-    -> PreOpenAfun acc aenv  t-    -> f (PreOpenAfun acc aenv' t)-rebuildAfun k av afun =-  case afun of-    Abody b     -> Abody <$> k av b-    Alam f      -> Alam  <$> rebuildAfun k (shiftA k av) f--{-# INLINEABLE rebuildAtup #-}-rebuildAtup-    :: (Applicative f, SyntacticAcc fa)-    => RebuildAcc acc-    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-    -> Atuple (acc aenv)  t-    -> f (Atuple (acc aenv') t)-rebuildAtup k av atup =-  case atup of-    NilAtup      -> pure NilAtup-    SnocAtup t a -> SnocAtup <$> rebuildAtup k av t <*> k av a--{-# INLINEABLE rebuildBoundary #-}-rebuildBoundary-    :: (Applicative f, SyntacticAcc fa)-    => RebuildAcc acc-    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-    -> PreBoundary acc aenv t-    -> f (PreBoundary acc aenv' t)-rebuildBoundary k av bndy =-  case bndy of-    Clamp       -> pure Clamp-    Mirror      -> pure Mirror-    Wrap        -> pure Wrap-    Constant v  -> pure (Constant v)-    Function f  -> Function <$> rebuildFun k (pure . IE) av f--{---{-# INLINEABLE rebuildSeq #-}-rebuildSeq-    :: (SyntacticAcc fa, Applicative f)-    => RebuildAcc acc-    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-    -> PreOpenSeq acc aenv senv t-    -> f (PreOpenSeq acc aenv' senv t)-rebuildSeq k v seq =-  case seq of-    Producer p s -> Producer <$> (rebuildP k v p) <*> (rebuildSeq k v s)-    Consumer c   -> Consumer <$> (rebuildC k v c)-    Reify ix     -> pure $ Reify ix--{-# INLINEABLE rebuildP #-}-rebuildP :: (SyntacticAcc fa, Applicative f)-         => RebuildAcc acc-         -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-         -> Producer acc aenv senv a-         -> f (Producer acc aenv' senv a)-rebuildP k v p =-  case p of-    StreamIn arrs        -> pure (StreamIn arrs)-    ToSeq sl slix acc    -> ToSeq sl slix <$> k v acc-    MapSeq f x           -> MapSeq <$> rebuildAfun k v f <*> pure x-    ChunkedMapSeq f x    -> ChunkedMapSeq <$> rebuildAfun k v f <*> pure x-    ZipWithSeq f x y     -> ZipWithSeq <$> rebuildAfun k v f <*> pure x <*> pure y-    ScanSeq f e x        -> ScanSeq <$> rebuildFun k (pure . IE) v f <*> rebuildPreOpenExp k (pure . IE) v e <*> pure x--{-# INLINEABLE rebuildC #-}-rebuildC :: forall acc fa f aenv aenv' senv a. (SyntacticAcc fa, Applicative f)-         => RebuildAcc acc-         -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))-         -> Consumer acc aenv senv a-         -> f (Consumer acc aenv' senv a)-rebuildC k v c =-  case c of-    FoldSeq f e x          -> FoldSeq <$> rebuildFun k (pure . IE) v f <*> rebuildPreOpenExp k (pure . IE) v e <*> pure x-    FoldSeqFlatten f acc x -> FoldSeqFlatten <$> rebuildAfun k v f <*> k v acc <*> pure x-    Stuple t               -> Stuple <$> rebuildT t-  where-    rebuildT :: Atuple (Consumer acc aenv senv) t -> f (Atuple (Consumer acc aenv' senv) t)-    rebuildT NilAtup        = pure NilAtup-    rebuildT (SnocAtup t s) = SnocAtup <$> (rebuildT t) <*> (rebuildC k v s)---}-
− Data/Array/Accelerate/Type.hs 
@@ -1,712 +0,0 @@-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE DeriveDataTypeable   #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module      : Data.Array.Accelerate.Type--- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller---               [2009..2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------  /Scalar types supported in array computations/------  Integral types:---    * Int---    * Int8---    * Int16---    * Int32---    * Int64---    * Word---    * Word8---    * Word16---    * Word32---    * Word64---    * CShort---    * CUShort---    * CInt---    * CUInt---    * CLong---    * CULong---    * CLLong---    * CULLong------  Floating types:---    * Float---    * Double---    * CFloat---    * CDouble------  Non-numeric types:---    * Bool---    * Char---    * CChar---    * CSChar---    * CUChar------  Note that 'Int' has the same bit width as in plain Haskell computations, and---  'Float' and 'Double' represent IEEE single and double precision floating---  point numbers, respectively.-----module Data.Array.Accelerate.Type (-  Float, Double, Char, Bool(..),-  module Data.Int,-  module Data.Word,-  module Foreign.C.Types,-  module Data.Array.Accelerate.Type-) where---import Data.Orphans ()    -- orphan instances for 8-tuples and beyond---- standard libraries-import Data.Bits-import Data.Int-import Data.Type.Equality-import Data.Typeable-import Data.Word-import GHC.TypeLits-import Foreign.Storable-import Foreign.C.Types (-  CChar, CSChar, CUChar, CShort, CUShort, CInt, CUInt, CLong, CULong,-  CLLong, CULLong, CFloat, CDouble)-  -- in the future, CHalf----- Scalar types--- ---------------- Reified dictionaries-----data IntegralDict a where-  IntegralDict :: ( Bounded a, Enum a, Eq a, Ord a, Show a-                  , Bits a, FiniteBits a, Integral a, Num a, Real a, Storable a )-               => IntegralDict a--data FloatingDict a where-  FloatingDict :: ( Enum a, Eq a, Ord a, Show a-                  , Floating a, Fractional a, Num a, Real a, RealFrac a-                  , RealFloat a, Storable a )-               => FloatingDict a--data NonNumDict a where-  NonNumDict :: ( Bounded a, Enum a, Eq a, Ord a, Show a, Storable a )-             => NonNumDict a----- Scalar type representation------- |Integral types supported in array computations.----data IntegralType a where-  TypeInt     :: IntegralDict Int     -> IntegralType Int-  TypeInt8    :: IntegralDict Int8    -> IntegralType Int8-  TypeInt16   :: IntegralDict Int16   -> IntegralType Int16-  TypeInt32   :: IntegralDict Int32   -> IntegralType Int32-  TypeInt64   :: IntegralDict Int64   -> IntegralType Int64-  TypeWord    :: IntegralDict Word    -> IntegralType Word-  TypeWord8   :: IntegralDict Word8   -> IntegralType Word8-  TypeWord16  :: IntegralDict Word16  -> IntegralType Word16-  TypeWord32  :: IntegralDict Word32  -> IntegralType Word32-  TypeWord64  :: IntegralDict Word64  -> IntegralType Word64-  TypeCShort  :: IntegralDict CShort  -> IntegralType CShort-  TypeCUShort :: IntegralDict CUShort -> IntegralType CUShort-  TypeCInt    :: IntegralDict CInt    -> IntegralType CInt-  TypeCUInt   :: IntegralDict CUInt   -> IntegralType CUInt-  TypeCLong   :: IntegralDict CLong   -> IntegralType CLong-  TypeCULong  :: IntegralDict CULong  -> IntegralType CULong-  TypeCLLong  :: IntegralDict CLLong  -> IntegralType CLLong-  TypeCULLong :: IntegralDict CULLong -> IntegralType CULLong---- |Floating-point types supported in array computations.----data FloatingType a where-  TypeFloat   :: FloatingDict Float   -> FloatingType Float-  TypeDouble  :: FloatingDict Double  -> FloatingType Double-  TypeCFloat  :: FloatingDict CFloat  -> FloatingType CFloat-  TypeCDouble :: FloatingDict CDouble -> FloatingType CDouble---- |Non-numeric types supported in array computations.----data NonNumType a where-  TypeBool    :: NonNumDict Bool      -> NonNumType Bool   --  marshalled to Word8-  TypeChar    :: NonNumDict Char      -> NonNumType Char-  TypeCChar   :: NonNumDict CChar     -> NonNumType CChar-  TypeCSChar  :: NonNumDict CSChar    -> NonNumType CSChar-  TypeCUChar  :: NonNumDict CUChar    -> NonNumType CUChar---- |Numeric element types implement Num & Real----data NumType a where-  IntegralNumType :: IntegralType a -> NumType a-  FloatingNumType :: FloatingType a -> NumType a---- |Bounded element types implement Bounded----data BoundedType a where-  IntegralBoundedType :: IntegralType a -> BoundedType a-  NonNumBoundedType   :: NonNumType a   -> BoundedType a---- |All scalar element types implement Eq, Ord & Enum----data ScalarType a where-  NumScalarType    :: NumType a    -> ScalarType a-  NonNumScalarType :: NonNumType a -> ScalarType a---- Showing type names-----instance Show (IntegralType a) where-  show (TypeInt _)     = "Int"-  show (TypeInt8 _)    = "Int8"-  show (TypeInt16 _)   = "Int16"-  show (TypeInt32 _)   = "Int32"-  show (TypeInt64 _)   = "Int64"-  show (TypeWord _)    = "Word"-  show (TypeWord8 _)   = "Word8"-  show (TypeWord16 _)  = "Word16"-  show (TypeWord32 _)  = "Word32"-  show (TypeWord64 _)  = "Word64"-  show (TypeCShort _)  = "CShort"-  show (TypeCUShort _) = "CUShort"-  show (TypeCInt _)    = "CInt"-  show (TypeCUInt _)   = "CUInt"-  show (TypeCLong _)   = "CLong"-  show (TypeCULong _)  = "CULong"-  show (TypeCLLong _)  = "CLLong"-  show (TypeCULLong _) = "CULLong"--instance Show (FloatingType a) where-  show (TypeFloat _)   = "Float"-  show (TypeDouble _)  = "Double"-  show (TypeCFloat _)  = "CFloat"-  show (TypeCDouble _) = "CDouble"--instance Show (NonNumType a) where-  show (TypeBool _)   = "Bool"-  show (TypeChar _)   = "Char"-  show (TypeCChar _)  = "CChar"-  show (TypeCSChar _) = "CSChar"-  show (TypeCUChar _) = "CUChar"--instance Show (NumType a) where-  show (IntegralNumType ty) = show ty-  show (FloatingNumType ty) = show ty--instance Show (BoundedType a) where-  show (IntegralBoundedType ty) = show ty-  show (NonNumBoundedType ty)   = show ty--instance Show (ScalarType a) where-  show (NumScalarType ty)    = show ty-  show (NonNumScalarType ty) = show ty----- Querying scalar type representations------- |Integral types----class (IsScalar a, IsNum a, IsBounded a) => IsIntegral a where-  integralType :: IntegralType a--instance IsIntegral Int where-  integralType = TypeInt IntegralDict--instance IsIntegral Int8 where-  integralType = TypeInt8 IntegralDict--instance IsIntegral Int16 where-  integralType = TypeInt16 IntegralDict--instance IsIntegral Int32 where-  integralType = TypeInt32 IntegralDict--instance IsIntegral Int64 where-  integralType = TypeInt64 IntegralDict--instance IsIntegral Word where-  integralType = TypeWord IntegralDict--instance IsIntegral Word8 where-  integralType = TypeWord8 IntegralDict--instance IsIntegral Word16 where-  integralType = TypeWord16 IntegralDict--instance IsIntegral Word32 where-  integralType = TypeWord32 IntegralDict--instance IsIntegral Word64 where-  integralType = TypeWord64 IntegralDict--instance IsIntegral CShort where-  integralType = TypeCShort IntegralDict--instance IsIntegral CUShort where-  integralType = TypeCUShort IntegralDict--instance IsIntegral CInt where-  integralType = TypeCInt IntegralDict--instance IsIntegral CUInt where-  integralType = TypeCUInt IntegralDict--instance IsIntegral CLong where-  integralType = TypeCLong IntegralDict--instance IsIntegral CULong where-  integralType = TypeCULong IntegralDict--instance IsIntegral CLLong where-  integralType = TypeCLLong IntegralDict--instance IsIntegral CULLong where-  integralType = TypeCULLong IntegralDict---- |Floating types----class (Floating a, IsScalar a, IsNum a) => IsFloating a where-  floatingType :: FloatingType a--instance IsFloating Float where-  floatingType = TypeFloat FloatingDict--instance IsFloating Double where-  floatingType = TypeDouble FloatingDict--instance IsFloating CFloat where-  floatingType = TypeCFloat FloatingDict--instance IsFloating CDouble where-  floatingType = TypeCDouble FloatingDict---- |Non-numeric types----class IsNonNum a where-  nonNumType :: NonNumType a--instance IsNonNum Bool where-  nonNumType = TypeBool NonNumDict--instance IsNonNum Char where-  nonNumType = TypeChar NonNumDict--instance IsNonNum CChar where-  nonNumType = TypeCChar NonNumDict--instance IsNonNum CSChar where-  nonNumType = TypeCSChar NonNumDict--instance IsNonNum CUChar where-  nonNumType = TypeCUChar NonNumDict---- |Numeric types----class (Num a, IsScalar a) => IsNum a where-  numType :: NumType a--instance IsNum Int where-  numType = IntegralNumType integralType--instance IsNum Int8 where-  numType = IntegralNumType integralType--instance IsNum Int16 where-  numType = IntegralNumType integralType--instance IsNum Int32 where-  numType = IntegralNumType integralType--instance IsNum Int64 where-  numType = IntegralNumType integralType--instance IsNum Word where-  numType = IntegralNumType integralType--instance IsNum Word8 where-  numType = IntegralNumType integralType--instance IsNum Word16 where-  numType = IntegralNumType integralType--instance IsNum Word32 where-  numType = IntegralNumType integralType--instance IsNum Word64 where-  numType = IntegralNumType integralType--instance IsNum CShort where-  numType = IntegralNumType integralType--instance IsNum CUShort where-  numType = IntegralNumType integralType--instance IsNum CInt where-  numType = IntegralNumType integralType--instance IsNum CUInt where-  numType = IntegralNumType integralType--instance IsNum CLong where-  numType = IntegralNumType integralType--instance IsNum CULong where-  numType = IntegralNumType integralType--instance IsNum CLLong where-  numType = IntegralNumType integralType--instance IsNum CULLong where-  numType = IntegralNumType integralType--instance IsNum Float where-  numType = FloatingNumType floatingType--instance IsNum Double where-  numType = FloatingNumType floatingType--instance IsNum CFloat where-  numType = FloatingNumType floatingType--instance IsNum CDouble where-  numType = FloatingNumType floatingType---- |Bounded types----class IsBounded a where-  boundedType :: BoundedType a--instance IsBounded Int where-  boundedType = IntegralBoundedType integralType--instance IsBounded Int8 where-  boundedType = IntegralBoundedType integralType--instance IsBounded Int16 where-  boundedType = IntegralBoundedType integralType--instance IsBounded Int32 where-  boundedType = IntegralBoundedType integralType--instance IsBounded Int64 where-  boundedType = IntegralBoundedType integralType--instance IsBounded Word where-  boundedType = IntegralBoundedType integralType--instance IsBounded Word8 where-  boundedType = IntegralBoundedType integralType--instance IsBounded Word16 where-  boundedType = IntegralBoundedType integralType--instance IsBounded Word32 where-  boundedType = IntegralBoundedType integralType--instance IsBounded Word64 where-  boundedType = IntegralBoundedType integralType--instance IsBounded CShort where-  boundedType = IntegralBoundedType integralType--instance IsBounded CUShort where-  boundedType = IntegralBoundedType integralType--instance IsBounded CInt where-  boundedType = IntegralBoundedType integralType--instance IsBounded CUInt where-  boundedType = IntegralBoundedType integralType--instance IsBounded CLong where-  boundedType = IntegralBoundedType integralType--instance IsBounded CULong where-  boundedType = IntegralBoundedType integralType--instance IsBounded CLLong where-  boundedType = IntegralBoundedType integralType--instance IsBounded CULLong where-  boundedType = IntegralBoundedType integralType--instance IsBounded Bool where-  boundedType = NonNumBoundedType nonNumType--instance IsBounded Char where-  boundedType = NonNumBoundedType nonNumType--instance IsBounded CChar where-  boundedType = NonNumBoundedType nonNumType--instance IsBounded CSChar where-  boundedType = NonNumBoundedType nonNumType--instance IsBounded CUChar where-  boundedType = NonNumBoundedType nonNumType---- |All scalar types----class Typeable a => IsScalar a where-  scalarType :: ScalarType a--instance IsScalar Int where-  scalarType = NumScalarType numType--instance IsScalar Int8 where-  scalarType = NumScalarType numType--instance IsScalar Int16 where-  scalarType = NumScalarType numType--instance IsScalar Int32 where-  scalarType = NumScalarType numType--instance IsScalar Int64 where-  scalarType = NumScalarType numType--instance IsScalar Word where-  scalarType = NumScalarType numType--instance IsScalar Word8 where-  scalarType = NumScalarType numType--instance IsScalar Word16 where-  scalarType = NumScalarType numType--instance IsScalar Word32 where-  scalarType = NumScalarType numType--instance IsScalar Word64 where-  scalarType = NumScalarType numType--instance IsScalar CShort where-  scalarType = NumScalarType numType--instance IsScalar CUShort where-  scalarType = NumScalarType numType--instance IsScalar CInt where-  scalarType = NumScalarType numType--instance IsScalar CUInt where-  scalarType = NumScalarType numType--instance IsScalar CLong where-  scalarType = NumScalarType numType--instance IsScalar CULong where-  scalarType = NumScalarType numType--instance IsScalar CLLong where-  scalarType = NumScalarType numType--instance IsScalar CULLong where-  scalarType = NumScalarType numType--instance IsScalar Float where-  scalarType = NumScalarType numType--instance IsScalar Double where-  scalarType = NumScalarType numType--instance IsScalar CFloat where-  scalarType = NumScalarType numType--instance IsScalar CDouble where-  scalarType = NumScalarType numType--instance IsScalar Bool where-  scalarType = NonNumScalarType nonNumType--instance IsScalar Char where-  scalarType = NonNumScalarType nonNumType--instance IsScalar CChar where-  scalarType = NonNumScalarType nonNumType--instance IsScalar CSChar where-  scalarType = NonNumScalarType nonNumType--instance IsScalar CUChar where-  scalarType = NonNumScalarType nonNumType---- Extract reified dictionaries-----integralDict :: IntegralType a -> IntegralDict a-integralDict (TypeInt     dict) = dict-integralDict (TypeInt8    dict) = dict-integralDict (TypeInt16   dict) = dict-integralDict (TypeInt32   dict) = dict-integralDict (TypeInt64   dict) = dict-integralDict (TypeWord    dict) = dict-integralDict (TypeWord8   dict) = dict-integralDict (TypeWord16  dict) = dict-integralDict (TypeWord32  dict) = dict-integralDict (TypeWord64  dict) = dict-integralDict (TypeCShort  dict) = dict-integralDict (TypeCUShort dict) = dict-integralDict (TypeCInt    dict) = dict-integralDict (TypeCUInt   dict) = dict-integralDict (TypeCLong   dict) = dict-integralDict (TypeCULong  dict) = dict-integralDict (TypeCLLong  dict) = dict-integralDict (TypeCULLong dict) = dict--floatingDict :: FloatingType a -> FloatingDict a-floatingDict (TypeFloat dict) = dict-floatingDict (TypeDouble dict) = dict-floatingDict (TypeCFloat dict) = dict-floatingDict (TypeCDouble dict) = dict--nonNumDict :: NonNumType a -> NonNumDict a-nonNumDict (TypeBool   dict) = dict-nonNumDict (TypeChar   dict) = dict-nonNumDict (TypeCChar  dict) = dict-nonNumDict (TypeCSChar dict) = dict-nonNumDict (TypeCUChar dict) = dict----- Tuple types--- -------------data TupleType a where-  UnitTuple   ::                               TupleType ()-  SingleTuple :: ScalarType a               -> TupleType a-  PairTuple   :: TupleType a -> TupleType b -> TupleType (a, b)--instance Show (TupleType a) where-  show UnitTuple              = "()"-  show (SingleTuple scalarTy) = show scalarTy-  show (PairTuple a b)        = "("++show a++", "++show b++")"----- Type-level bit sizes--- ------------------------ |Constraint that values of these two types have the same bit width----type BitSizeEq a b = (BitSize a == BitSize b) ~ 'True--type family BitSize a :: Nat--type instance BitSize Int8    = 8-type instance BitSize Int16   = 16-type instance BitSize Int32   = 32-type instance BitSize Int64   = 64-type instance BitSize Word8   = 8-type instance BitSize Word16  = 16-type instance BitSize Word32  = 32-type instance BitSize Word64  = 64-type instance BitSize Char    = 32-type instance BitSize Bool    = 1--type instance BitSize CShort  = 16-type instance BitSize CUShort = 16-type instance BitSize CInt    = 32-type instance BitSize CUInt   = 32-type instance BitSize CLLong  = 64-type instance BitSize CULLong = 64-type instance BitSize CChar   = 8-type instance BitSize CUChar  = 8-type instance BitSize CSChar  = 8--type instance BitSize Float   = 32-type instance BitSize CFloat  = 32-type instance BitSize Double  = 64-type instance BitSize CDouble = 64--type instance BitSize Int    = $( case finiteBitSize (undefined::Int) of-                                    32 -> [t| 32 |]-                                    64 -> [t| 64 |]-                                    _  -> error "I don't know what architecture I am"  )--type instance BitSize Word   = $( case finiteBitSize (undefined::Word) of-                                    32 -> [t| 32 |]-                                    64 -> [t| 64 |]-                                    _  -> error "I don't know what architecture I am"  )--type instance BitSize CLong  = $( case finiteBitSize (undefined::CLong) of-                                    32 -> [t| 32 |]-                                    64 -> [t| 64 |]-                                    _  -> error "I don't know what architecture I am"  )--type instance BitSize CULong = $( case finiteBitSize (undefined::CULong) of-                                    32 -> [t| 32 |]-                                    64 -> [t| 64 |]-                                    _  -> error "I don't know what architecture I am"  )---{---- Vector GPU data types--- -----------------------data CChar1 = CChar1 CChar-data CChar2 = CChar2 CChar CChar-data CChar3 = CChar3 CChar CChar CChar-data CChar4 = CChar4 CChar CChar CChar CChar-data CSChar1 = CSChar1 CSChar-data CSChar2 = CSChar2 CSChar CSChar-data CSChar3 = CSChar3 CSChar CSChar CSChar-data CSChar4 = CSChar4 CSChar CSChar CSChar CSChar-data CUChar1 = CUChar1 CUChar-data CUChar2 = CUChar2 CUChar CUChar-data CUChar3 = CUChar3 CUChar CUChar CUChar-data CUChar4 = CUChar4 CUChar CUChar CUChar CUChar-data CShort1 = CShort1 CShort-data CShort2 = CShort2 CShort CShort-data CShort3 = CShort3 CShort CShort CShort-data CShort4 = CShort4 CShort CShort CShort CShort-data CUShort1 = CUShort1 CUShort-data CUShort2 = CUShort2 CUShort CUShort-data CUShort3 = CUShort3 CUShort CUShort CUShort-data CUShort4 = CUShort4 CUShort CUShort CUShort CUShort-data CInt1 = CInt1 CInt-data CInt2 = CInt2 CInt CInt-data CInt3 = CInt3 CInt CInt CInt-data CInt4 = CInt4 CInt CInt CInt CInt-data CUInt1 = CUInt1 CUInt-data CUInt2 = CUInt2 CUInt CUInt-data CUInt3 = CUInt3 CUInt CUInt CUInt-data CUInt4 = CUInt4 CUInt CUInt CUInt CUInt-data CLong1 = CLong1 CLong-data CLong2 = CLong2 CLong CLong-data CLong3 = CLong3 CLong CLong CLong-data CLong4 = CLong4 CLong CLong CLong CLong-data CULong1 = CULong1 CULong-data CULong2 = CULong2 CULong CULong-data CULong3 = CULong3 CULong CULong CULong-data CULong4 = CULong4 CULong CULong CULong CULong-data CLLong1 = CLLong1 CLLong-data CLLong2 = CLLong2 CLLong CLLong-data CLLong3 = CLLong3 CLLong CLLong CLLong-data CLLong4 = CLLong4 CLLong CLLong CLLong CLLong-data CULLong1 = CULLong1 CULLong-data CULLong2 = CULLong2 CULLong CULLong-data CULLong3 = CULLong3 CULLong CULLong CULLong-data CULLong4 = CULLong4 CULLong CULLong CULLong CULLong-data CFloat1 = CFloat1 CFloat-data CFloat2 = CFloat2 CFloat CFloat-data CFloat3 = CFloat3 CFloat CFloat CFloat-data CFloat4 = CFloat4 CFloat CFloat CFloat CFloat-data CDouble1 = CDouble1 CDouble-data CDouble2 = CDouble2 CDouble CDouble-data CDouble3 = CDouble3 CDouble CDouble CDouble-data CDouble4 = CDouble4 CDouble CDouble CDouble CDouble--- in the future, vector types for CHalf- -}-
− Data/Atomic.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--- |--- Module      : Data.Atomic--- Copyright   : [2016..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)------ Atomic integer values. All operations are thread safe.-----module Data.Atomic (--  Atomic,-  new,-  add, and,--) where--import Data.Int-import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.Storable-import Prelude                                                      ( ($), IO, return )----- | A mutable atomic integer----newtype Atomic = Atomic ( ForeignPtr Int64 )---- | Create a new atomic variable initialised to the given value----new :: Int64 -> IO Atomic-new v = do-  fp <- mallocForeignPtr-  withForeignPtr fp $ \p -> poke p v-  return $ Atomic fp---- | Increase the atomic by the given amount. Returns the old value.----add :: Atomic -> Int64 -> IO Int64-add (Atomic fp) v =-  withForeignPtr fp $ \p -> atomic_fetch_and_add_64 p v---- | Bitwise AND the atomic with the given value. Return the old value.----and :: Atomic -> Int64 -> IO Int64-and (Atomic fp) v =-  withForeignPtr fp $ \p -> atomic_fetch_and_and_64 p v----- Perform the operation suggested by the name and return the old value------ > { tmp = *ptr; *ptr op= value; return tmp; }----foreign import ccall unsafe "hs_atomic_fetch_and_add_64" atomic_fetch_and_add_64 :: Ptr Int64 -> Int64 -> IO Int64-foreign import ccall unsafe "hs_atomic_fetch_and_and_64" atomic_fetch_and_and_64 :: Ptr Int64 -> Int64 -> IO Int64-
README.md view
@@ -1,9 +1,14 @@ An Embedded Language for Accelerated Array Computations ======================================================= -[![Build Status](https://travis-ci.org/AccelerateHS/accelerate.svg?branch=master)](https://travis-ci.org/AccelerateHS/accelerate)+[![Travis](https://img.shields.io/travis/AccelerateHS/accelerate/master.svg?label=linux)](https://travis-ci.org/AccelerateHS/accelerate)+[![AppVeyor](https://img.shields.io/appveyor/ci/tmcdonell/accelerate/master.svg?label=windows)](https://ci.appveyor.com/project/tmcdonell/accelerate)+[![Stackage LTS](https://stackage.org/package/accelerate/badge/lts)](https://stackage.org/lts/package/accelerate)+[![Stackage Nightly](https://stackage.org/package/accelerate/badge/nightly)](https://stackage.org/nightly/package/accelerate) [![Hackage](https://img.shields.io/hackage/v/accelerate.svg)](https://hackage.haskell.org/package/accelerate)+[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) + `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 executed on a range of architectures.  For more details, see our papers:@@ -73,6 +78,7 @@   * [linear-accelerate][linear-accelerate]: [Linear][linear] vector spaces in Accelerate   * [mwc-random-accelerate][mwc-random-accelerate]: Generate Accelerate arrays filled with high quality pseudorandom numbers   * [numeric-prelude-accelerate][numeric-prelude-accelerate]: Lifting the [numeric-prelude][numeric-prelude] to Accelerate+  * [wigner-ville-accelerate](https://github.com/Haskell-mouse/wigner-ville-accelerate): Wigner-Ville time-frequency distribution.  Install them from Hackage with `cabal install PACKAGENAME`.
Setup.hs view
@@ -1,3 +1,21 @@+{-# LANGUAGE CPP #-}++module Main where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)+import Distribution.Extra.Doctest++main :: IO ()+main = defaultMainWithDoctests "doctest"++#else import Distribution.Simple++main :: IO () main = defaultMain+#endif
accelerate.cabal view
@@ -1,8 +1,8 @@ Name:                   accelerate-Version:                1.1.1.0-Cabal-version:          >= 1.8+Version:                1.2.0.0+Cabal-version:          >= 1.18 Tested-with:            GHC >= 7.8-Build-type:             Simple+Build-type:             Custom  Synopsis:               An embedded language for accelerated array processing @@ -26,6 +26,8 @@   online-compiled for performance - for example, using   @Data.Array.Accelerate.LLVM.PTX@ it may be on-the-fly off-loaded to the GPU.   .+  See the "Data.Array.Accelerate" module for further information.+  .   [/Additional components/]   .   The following supported add-ons are available as separate packages. Install@@ -85,8 +87,6 @@   .     * A simple interactive ray tracer   .-    * A particle based simulation of stable fluid flows-  .     * A cellular automata simulation   .     * A \"password recovery\" tool, for dictionary lookup of MD5 hashes@@ -128,7 +128,18 @@ Extra-source-files:     README.md     CHANGELOG.md+    cbits/flags.inc+    cbits/monitoring.inc +Extra-doc-files:+    images/*.png++custom-setup+  setup-depends:+      base              >= 4.7+    , Cabal+    , cabal-doctest     >= 1.0+ Flag debug   Default:              False   Description:@@ -249,26 +260,43 @@   Description:          Enable internal consistency checks   Default:              False +Flag nofib+  Default:              True+  Description:+    You can disable building the nofib test suite with this flag. Disabling this+    is an unsupported configuration, but is useful for accelerating builds.+ Library   Build-depends:-          base                          >= 4.7 && < 4.11+          base                          >= 4.7 && < 4.12+        , ansi-terminal                 >= 0.6.2+        , ansi-wl-pprint                >= 0.6         , base-orphans                  >= 0.3+        , bytestring                    >= 0.10.2         , containers                    >= 0.3+        , constraints                   >= 0.9+        , cryptonite                    >= 0.21         , deepseq                       >= 1.3         , directory                     >= 1.0         , exceptions                    >= 0.6-        , fclabels                      >= 2.0         , filepath                      >= 1.0         , ghc-prim+        , half                          >= 0.2         , hashable                      >= 1.1-        , hashtables                    >= 1.0+        , hashtables                    >= 1.2.3+        , hedgehog                      >= 0.5+        , lens                          >= 4.0         , mtl                           >= 2.0-        , ansi-wl-pprint                >= 0.6+        , tasty                         >= 0.11+        , tasty-expected-failure        >= 0.11+        , tasty-hedgehog                >= 0.1+        , tasty-hunit                   >= 0.9         , template-haskell-        , time                          >= 1.4+        , terminal-size                 >= 0.3         , transformers                  >= 0.3         , unique         , unordered-containers          >= 0.2+        , vector                        >= 0.10    Exposed-modules:         -- The core language and reference implementation@@ -278,10 +306,14 @@         -- Prelude-like         Data.Array.Accelerate.Data.Bits         Data.Array.Accelerate.Data.Complex+        Data.Array.Accelerate.Data.Either         Data.Array.Accelerate.Data.Fold+        Data.Array.Accelerate.Data.Functor+        Data.Array.Accelerate.Data.Maybe         Data.Array.Accelerate.Data.Monoid+        Data.Array.Accelerate.Unsafe -        -- For backend development+        -- For backend development (hidden)         Data.Array.Accelerate.AST         Data.Array.Accelerate.Analysis.Hash         Data.Array.Accelerate.Analysis.Match@@ -299,7 +331,6 @@         Data.Array.Accelerate.Async         Data.Array.Accelerate.Debug         Data.Array.Accelerate.Error-        Data.Array.Accelerate.FullList         Data.Array.Accelerate.Lifetime         Data.Array.Accelerate.Pretty         Data.Array.Accelerate.Product@@ -307,6 +338,10 @@         Data.Array.Accelerate.Trafo         Data.Array.Accelerate.Type +        -- For testing+        Data.Array.Accelerate.Test.NoFib+        Data.Array.Accelerate.Test.Similar+   Other-modules:         Data.Atomic         Data.Array.Accelerate.Analysis.Hash.TH@@ -348,28 +383,108 @@         Data.Array.Accelerate.Trafo.Substitution         -- Data.Array.Accelerate.Trafo.Vectorise -  c-sources:            cbits/atomic.c+        -- nofib test suite+        Data.Array.Accelerate.Test.NoFib.Base+        Data.Array.Accelerate.Test.NoFib.Config +  if flag(nofib)+    -- build-depends:+    --     , pipes                         >= 4.1.6   -- #286++    other-modules:+        Data.Array.Accelerate.Test.NoFib.Sharing+        Data.Array.Accelerate.Test.NoFib.Prelude+        Data.Array.Accelerate.Test.NoFib.Prelude.Map+        Data.Array.Accelerate.Test.NoFib.Prelude.ZipWith+        Data.Array.Accelerate.Test.NoFib.Prelude.Fold+        Data.Array.Accelerate.Test.NoFib.Prelude.Scan+        Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute+        Data.Array.Accelerate.Test.NoFib.Prelude.Permute+        Data.Array.Accelerate.Test.NoFib.Prelude.Filter+        Data.Array.Accelerate.Test.NoFib.Prelude.Stencil+        Data.Array.Accelerate.Test.NoFib.Imaginary+        Data.Array.Accelerate.Test.NoFib.Imaginary.DotP+        Data.Array.Accelerate.Test.NoFib.Imaginary.SASUM+        Data.Array.Accelerate.Test.NoFib.Imaginary.SAXPY+        Data.Array.Accelerate.Test.NoFib.Spectral+        Data.Array.Accelerate.Test.NoFib.Spectral.SMVM+        Data.Array.Accelerate.Test.NoFib.Spectral.RadixSort+        Data.Array.Accelerate.Test.NoFib.Spectral.BlackScholes+        Data.Array.Accelerate.Test.NoFib.Issues+        Data.Array.Accelerate.Test.NoFib.Issues.Issue93+        Data.Array.Accelerate.Test.NoFib.Issues.Issue102+        Data.Array.Accelerate.Test.NoFib.Issues.Issue114+        Data.Array.Accelerate.Test.NoFib.Issues.Issue119+        Data.Array.Accelerate.Test.NoFib.Issues.Issue123+        Data.Array.Accelerate.Test.NoFib.Issues.Issue137+        Data.Array.Accelerate.Test.NoFib.Issues.Issue168+        Data.Array.Accelerate.Test.NoFib.Issues.Issue184+        Data.Array.Accelerate.Test.NoFib.Issues.Issue185+        Data.Array.Accelerate.Test.NoFib.Issues.Issue187+        Data.Array.Accelerate.Test.NoFib.Issues.Issue228+        Data.Array.Accelerate.Test.NoFib.Issues.Issue255+        Data.Array.Accelerate.Test.NoFib.Issues.Issue264+        -- Data.Array.Accelerate.Test.NoFib.Issues.Issue286+        Data.Array.Accelerate.Test.NoFib.Issues.Issue287+        Data.Array.Accelerate.Test.NoFib.Issues.Issue288+        Data.Array.Accelerate.Test.NoFib.Issues.Issue362+        Data.Array.Accelerate.Test.NoFib.Issues.Issue407+        Data.Array.Accelerate.Test.NoFib.Issues.Issue409+  else+    cpp-options:+        -DACCELERATE_DISABLE_NOFIB++  if impl(ghc >= 8.0)+    exposed-modules:+        Data.Array.Accelerate.Data.Semigroup++  default-language:+        Haskell2010++  hs-source-dirs:+        src+   if flag(debug) || flag(ekg)-    cpp-options:        -DACCELERATE_DEBUG+    ghc-options:+        -optc-DACCELERATE_DEBUG +    cpp-options:+        -DACCELERATE_DEBUG++    -- Weird handling of C files because Cabal is not recompile C files on+    -- changes to cc-options: <https://github.com/haskell/cabal/issues/4937>+    c-sources:+        cbits/atomic.c+        cbits/clock.c+        cbits/flags_debug.c+        cbits/monitoring_debug.c+  else+    c-sources:+        cbits/atomic.c+        cbits/flags.c+        cbits/monitoring.c+   if flag(ekg)-    cpp-options:        -DACCELERATE_MONITORING+    cpp-options:+        -DACCELERATE_MONITORING+     build-depends:           async                         >= 2.0         , ekg                           >= 0.1         , ekg-core                      >= 0.1         , text                          >= 1.0-        , time                          >= 1.4    if flag(bounds-checks)-    cpp-options:        -DACCELERATE_BOUNDS_CHECKS+    cpp-options:+        -DACCELERATE_BOUNDS_CHECKS    if flag(unsafe-checks)-    cpp-options:        -DACCELERATE_UNSAFE_CHECKS+    cpp-options:+        -DACCELERATE_UNSAFE_CHECKS    if flag(internal-checks)-    cpp-options:        -DACCELERATE_INTERNAL_CHECKS+    cpp-options:+        -DACCELERATE_INTERNAL_CHECKS    if os(windows)     cpp-options:        -DWIN32@@ -378,17 +493,32 @@     cpp-options:        -DUNIX     build-depends:      unix -  ghc-options:          -O2 -Wall -funbox-strict-fields -fno-warn-name-shadowing-  ghc-prof-options:     -caf-all -auto-all+  cc-options:+        -O3+        -Wall +  ghc-options:+        -O2+        -Wall+        -funbox-strict-fields+        -fno-warn-name-shadowing++  ghc-prof-options:+        -caf-all+        -auto-all+   if impl(ghc >= 7.0)-    ghc-options:        -fspec-constr-count=25+    ghc-options:+        -fspec-constr-count=25    if impl(ghc == 7.*)-    ghc-options:        -fcontext-stack=35+    ghc-options:+        -fcontext-stack=35    if impl(ghc >= 8.0)-    ghc-options:        -freduction-depth=35+    ghc-options:+        -Wcompat+        -freduction-depth=35    if impl(ghc < 7.10)     build-depends:@@ -400,13 +530,61 @@   --   -- Extensions: ++test-suite doctest+  type:                 exitcode-stdio-1.0+  default-language:     Haskell2010+  hs-source-dirs:       test/doctest+  main-is:              Main.hs++  build-depends:+          base                          >= 4.7+        , accelerate+        , doctest                       >= 0.11++  ghc-options:+        -Wall+        -threaded+        -rtsopts++  -- older ghc does not support the dimension-specialised show instances for+  -- arrays, which the doctests use+  if impl(ghc < 7.10)+    buildable:          False++  -- doctest only supports a single x-doctest-options line+  if impl(ghc == 7.*)+    x-doctest-options:  -fspec-constr-count=25 -fcontext-stack=35++  if impl(ghc >= 8.0)+    x-doctest-options:  -fspec-constr-count=25 -freduction-depth=35+++test-suite nofib-interpreter+  type:                 exitcode-stdio-1.0+  default-language:     Haskell2010+  hs-source-dirs:       test/nofib+  main-is:              Main.hs++  build-depends:+          base                          >= 4.7+        , accelerate++  ghc-options:+        -O2+        -Wall+        -threaded+        -rtsopts+        -with-rtsopts=-A128M+        -with-rtsopts=-n4M+ source-repository head   Type:                 git   Location:             git://github.com/AccelerateHS/accelerate.git  source-repository this   Type:                 git-  Tag:                  1.1.1.0+  Tag:                  v1.2.0.0   Location:             git://github.com/AccelerateHS/accelerate.git  -- vim: nospell
cbits/atomic.c view
@@ -1,12 +1,40 @@-#include "HsFFI.h"+/*+ * Module      : Data.Atomic+ * Copyright   : [2017] Trevor L. McDonell+ * License     : BSD3+ *+ * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+ * Stability   : experimental+ * Portability : non-portable (GHC extensions)+ *+ * Thread-safe atomic integer operations+ */ -StgInt64 hs_atomic_fetch_and_add_64(volatile StgInt64* ptr, StgInt64 val)+#include <stdint.h>++int64_t atomic_fetch_and_add_64(volatile int64_t* ptr, int64_t val) {   return __sync_fetch_and_add(ptr, val); } -StgInt64 hs_atomic_fetch_and_and_64(volatile StgInt64* ptr, StgInt64 val)+int64_t atomic_fetch_and_sub_64(volatile int64_t* ptr, int64_t val) {+  return __sync_fetch_and_sub(ptr, val);+}++int64_t atomic_fetch_and_and_64(volatile int64_t* ptr, int64_t val)+{   return __sync_fetch_and_and(ptr, val);+}++int64_t atomic_read_64(volatile int64_t* ptr)+{+  return *ptr;+}++void atomic_write_64(volatile int64_t* ptr, int64_t val)+{+  *ptr = val;+  return; }
+ cbits/clock.c view
@@ -0,0 +1,122 @@+/*+ * Module      : Data.Array.Accelerate.Debug.Clock+ * Copyright   : [2017] Trevor L. McDonell+ * License     : BSD3+ *+ * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+ * Stability   : experimental+ * Portability : non-portable (GHC extensions)+ *+ * Get the monotonic wall-clock time.+ *+ * Implementations for macOS and Win32 stolen from the clock package, which has+ * a BSD3 license.+ *+ * <https://github.com/corsis/clock/tree/0.5.1>+ */++#if defined(__MACH__) && defined(__APPLE__)+/*+ * macOS+ *+ * macOS 10.12 also has clock_gettime(), so it might be worthwhile to use that+ * when available.+ */+#include <time.h>+#include <mach/clock.h>+#include <mach/mach.h>++static void clock_darwin_gettime(clock_id_t clock, struct timespec *t)+{+    // OS X does not have clock_gettime, use clock_get_time+    // see http://stackoverflow.com/questions/11680461/monotonic-clock-on-osx+    clock_serv_t cclock;+    mach_timespec_t mts;++    host_get_clock_service(mach_host_self(), clock, &cclock);+    clock_get_time(cclock, &mts);+    mach_port_deallocate(mach_task_self(), cclock);++    t->tv_sec  = mts.tv_sec;+    t->tv_nsec = mts.tv_nsec;+}++double clock_gettime_monotonic_seconds()+{+    struct timespec t;+    clock_darwin_gettime(SYSTEM_CLOCK, &t);++    return (double) t.tv_sec + (double) t.tv_nsec * 1.0E-9;+}++#elif defined(_WIN32)+/*+ * Windows+ */+#include <windows.h>++static long ticks_to_nanos(LONGLONG subsecond_time, LONGLONG frequency)+{+    return (long)((1E9 * subsecond_time) / frequency);+}++static void clock_win32_gettime_monotonic(long long* t)+{+    LARGE_INTEGER time;+    static LARGE_INTEGER frequency;+    static int hasFreq = 0;++    QueryPerformanceCounter(&time);+    if (!hasFreq)+    {+        hasFreq = 1;+        QueryPerformanceFrequency(&frequency);+    }++    // seconds+    t[0] = time.QuadPart / frequency.QuadPart;++    // nanoseconds+    t[1] = ticks_to_nanos(time.QuadPart % frequency.QuadPart, frequency.QuadPart);+}++double clock_gettime_monotonic_seconds()+{+    long long t[2];+    clock_win32_gettime_monotonic(t);++    return (double) t[0] + (double) t[1] * 1.0E-9;+}++#else+/*+ * *nix+ */+#include <time.h>++double clock_gettime_monotonic_seconds()+{+    struct timespec t;+    clock_gettime(CLOCK_MONOTONIC, &t);++    return (double) t.tv_sec + (double) t.tv_nsec * 1.0E-9;+}++#endif /* OS */+++static double __program_epoch;++double clock_gettime_elapsed_seconds(void)+{+    double now  = clock_gettime_monotonic_seconds();+    double diff = now - __program_epoch;++    return diff;+}++__attribute__((constructor)) void initialise_program_epoch(void)+{+    __program_epoch = clock_gettime_monotonic_seconds();+}+
+ cbits/flags.c view
@@ -0,0 +1,12 @@+/*+ * Module      : Data.Array.Accelerate.Debug.Flags+ * Copyright   : [2017] Trevor L. McDonell+ * License     : BSD3+ *+ * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+ * Stability   : experimental+ * Portability : non-portable (GHC extensions)+ */++#include "flags.inc"+
+ cbits/flags.inc view
@@ -0,0 +1,336 @@+/*+ * Module      : Data.Array.Accelerate.Debug.Flags+ * Copyright   : [2017] Trevor L. McDonell+ * License     : BSD3+ *+ * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+ * Stability   : experimental+ * Portability : non-portable (GHC extensions)+ *+ * Option parsing for debug flags. This is a translation of the module+ * Data.Array.Accelerate.Debug.Flags into C, so that we can implement it at+ * program initialisation.+ *+ * This processes flags between +ACC ... -ACC on the command line. The+ * corresponding fields are removed from the command line. Note that we can't at+ * this stage update the number of command line arguments, but with some tricks+ * they can be mostly deleted.+ *+ * This is a hack to work around <https://github.com/haskell/cabal/issues/4937>+ */++#include <ctype.h>+#include <getopt.h>+#include <libgen.h>+#include <stdint.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>+++/* These globals will be accessed from the Haskell side to implement the+ * corresponding behaviour.+ */+int32_t __acc_sharing               = 1;+int32_t __exp_sharing               = 1;+int32_t __fusion                    = 1;+int32_t __simplify                  = 1;+int32_t __unfolding_use_threshold   = 1;+int32_t __fast_math                 = 1;+int32_t __flush_cache               = 0;+int32_t __force_recomp              = 0;+int32_t __debug                     = 0;++int32_t __verbose                   = 0;+int32_t __dump_phases               = 0;+int32_t __dump_sharing              = 0;+int32_t __dump_fusion               = 0;+int32_t __dump_simpl_stats          = 0;+int32_t __dump_simpl_iterations     = 0;+int32_t __dump_vectorisation        = 0;+int32_t __dump_dot                  = 0;+int32_t __dump_simpl_dot            = 0;+int32_t __dump_gc                   = 0;+int32_t __dump_gc_stats             = 0;+int32_t __dump_cc                   = 0;+int32_t __dump_ld                   = 0;+int32_t __dump_asm                  = 0;+int32_t __dump_exec                 = 0;+int32_t __dump_sched                = 0;++#if defined(ACCELERATE_DEBUG)++static const char*         shortopts  = "";+static const struct option longopts[] =+  { { "dverbose",                     no_argument,       &__verbose,               1    }+  , { "ddump-phases",                 no_argument,       &__dump_phases,           1    }+  , { "ddump-sharing",                no_argument,       &__dump_sharing,          1    }+  , { "ddump-fusion",                 no_argument,       &__dump_fusion,           1    }+  , { "ddump-simpl-stats",            no_argument,       &__dump_simpl_stats,      1    }+  , { "ddump-simpl-iterations",       no_argument,       &__dump_simpl_iterations, 1    }+  , { "ddump-vectorisation",          no_argument,       &__dump_vectorisation,    1    }+  , { "ddump-dot",                    no_argument,       &__dump_dot,              1    }+  , { "ddump-simpl-dot",              no_argument,       &__dump_simpl_dot,        1    }+  , { "ddump-gc",                     no_argument,       &__dump_gc,               1    }+  , { "ddump-gc-stats",               no_argument,       &__dump_gc_stats,         1    }+  , { "ddump-cc",                     no_argument,       &__dump_cc,               1    }+  , { "ddump-ld",                     no_argument,       &__dump_ld,               1    }+  , { "ddump-asm",                    no_argument,       &__dump_asm,              1    }+  , { "ddump-exec",                   no_argument,       &__dump_exec,             1    }+  , { "ddump-sched",                  no_argument,       &__dump_sched,            1    }++  , { "facc-sharing",                 no_argument,       &__acc_sharing,           1    }+  , { "fexp-sharing",                 no_argument,       &__exp_sharing,           1    }+  , { "ffusion",                      no_argument,       &__fusion,                1    }+  , { "fsimplify",                    no_argument,       &__simplify,              1    }+  , { "fflush-cache",                 no_argument,       &__flush_cache,           1    }+  , { "fforce-recomp",                no_argument,       &__force_recomp,          1    }+  , { "ffast-math",                   no_argument,       &__fast_math,             1    }+  , { "fdebug",                       no_argument,       &__debug,                 1    }++  , { "fno-acc-sharing",              no_argument,       &__acc_sharing,           0    }+  , { "fno-exp-sharing",              no_argument,       &__exp_sharing,           0    }+  , { "fno-fusion",                   no_argument,       &__fusion,                0    }+  , { "fno-simplify",                 no_argument,       &__simplify,              0    }+  , { "fno-flush-cache",              no_argument,       &__flush_cache,           0    }+  , { "fno-force-recomp",             no_argument,       &__force_recomp,          0    }+  , { "fno-fast-math",                no_argument,       &__fast_math,             0    }+  , { "fno-debug",                    no_argument,       &__debug,                 0    }++  , { "funfolding-use-threshold=INT", required_argument, NULL,                     1000 }++  /* required sentinel */+  , { NULL, 0, NULL, 0 }+  };++#endif /* ACCELERATE_DEBUG */+++/* Parse the given vector of command line arguments and set the corresponding+ * flags. The vector should contain no non-option arguments (aside from the name+ * of the program as the first entry, which is required for getopt()).+ */+static void parse_options(int argc, char *argv[])+{+#if defined(ACCELERATE_DEBUG)++  const struct option* opt;+  char* this;+  int   did_show_banner;+  int   prefix;+  int   result;+  int   longindex;++  while (-1 != (result = getopt_long_only(argc, argv, shortopts, longopts, &longindex)))+  {+    switch(result)+    {+    /* the option flag was set */+    case 0:+      break;++    /* attempt to decode the argument to flags which require them */+    case 1000:+      if (1 != sscanf(optarg, "%d", &__unfolding_use_threshold)) {+        fprintf(stderr, "%s: option `-%s' requires an integer argument, but got: %s\n"+                      , basename(argv[0])+                      , longopts[longindex].name+                      , optarg+                      );+      }+      break;++    /* option was ambiguous or was missing a required argument+     *+     * TLM: longindex is not being updated correctly on my system for the case+     *      of an ambiguous argument, which makes it tricker to directly test+     *      whether we got here due to a missing argument or ambiguous option.+     */+    case ':':+    case '?':+      opt             = longopts;+      this            = argv[optind-1];+      did_show_banner = 0;++      /* drop the leading '-' from the input command line argument */+      while (*this) {+        if ('-' == *this) {+          ++this;+        } else {+          break;+        }+      }+      prefix = strlen(this);++      /* display any options which are a prefix match for the ambiguous option */+      while (opt->name) {+        if (0 == strncmp(opt->name, this, prefix)) {+          /* only here can we determine if this was a missing argument case */+          if (opt->has_arg == required_argument)+            break;++          /* only show the banner if there are possible matches */+          if (0 == did_show_banner) {+            did_show_banner = 1;+            fprintf(stderr, "Did you mean one of these?\n");+          }+          fprintf(stderr, "    -%s\n", opt->name);+        }+        ++opt;+      }+      break;++    default:+      fprintf(stderr, "failed to process command line options (%d)\n", result);+      abort();+    }+  }++#else++  fprintf(stderr, "Data.Array.Accelerate: Debugging options are disabled.\n");+  fprintf(stderr, "Reinstall package 'accelerate' with '-fdebug' to enable them.\n");++#endif+}+++/* This function will be run automatically before main() to process options sent+ * to the Accelerate runtime system.+ *+ * This processes both command line flags as well as those specified via the+ * environment variable "ACCELERATE_FLAGS" (with precedence to the former).+ *+ * The input 'argv' vector is mutated to remove the entries processed by this+ * module. This prevents the flags from interfering with the regular Haskell+ * program (in the same way as the RTS options). Note however that since we can+ * not update the 'argc' length of the vector, the removed entries are simply+ * set to NULL (and moved to the end of the vector).+ */+__attribute__((constructor)) void process_options(int argc, char *argv[])+{+  int i;++  /* Find the command line options which need to be processed. These will be+   * between +ACC ... [-ACC] (similar to the Haskell RTS options).+   *+   * Note that this only recognises a single +ACC ... -ACC group. Should we be+   * able to handle multiple (disjoint) groups of flags? To do this properly we+   * probably want to collect the arguments (from both sources) into a linked+   * list. This would not be particularly difficult, just tedious... \:+   */+  int cl_start;+  int cl_end;+  int num_cl_options = 0;++  for (cl_start = 1; cl_start < argc; ++cl_start) {+    if (0 == strncmp("+ACC", argv[cl_start], 4)) {+      break;+    }+  }++  for (cl_end = cl_start+1; cl_end < argc; ++cl_end) {+    if (0 == strncmp("-ACC", argv[cl_end], 4)) {+      break;+    }+  }+  num_cl_options = cl_end-cl_start-1;++  /* Gather options from the ACCELERATE_FLAGS environment variable. Note that we+   * must not modify this variable, otherwise subsequent invocations of getenv()+   * will get the modified version.+   */+  char *env            = getenv("ACCELERATE_FLAGS");+  int  num_env_options = 0;++  if (NULL != env) {+    /* copy the environment string, as we will mutate it during tokenisation */+    char *p = env = strdup(env);++    /* first count how many tokens there are, so that we can allocate memory for+     * the combined options vector+     */+    while (*p) {+      while (*p && isspace(*p)) ++p;++      if (*p) {+        ++num_env_options;+        while (*p && !isspace(*p)) ++p;+      }+    }+  }++  /* Create the combined options vector containing both the environment and+   * command line options for parsing. The command line options are placed at+   * the end, so that they may override environment options.+   */+  int    argc2 = num_cl_options + num_env_options + 1;+  char** argv2 = NULL;++  if (argc2 > 1) {+    char*  p = env;+    char** r = argv2 = malloc(argc2 * sizeof(char*));++    /* program name */+    *r++ = argv[0];++    /* environment variables */+    if (p) {+      while (*p) {+        while (*p && isspace(*p)) ++p;++        if (*p) {+          *r++ = p;+          while (*p && !isspace(*p)) ++p;++          if (isspace(*p)) {+            *p++ = '\0';+          }+        }+      }+    }++    /* command line flags */+    for (i = cl_start+1; i < cl_end; ++i)+      *r++ = argv[i];++    /* finally process command lines */+    parse_options(argc2, argv2);+  }++  /* Remove the Accelerate options from the command line arguments which will be+   * passed to main(). We can't do this in a sensible fashion by updating argc,+   * but we can pull a small sleight-of-hand by rewriting them to -RTS, so that+   * they will be deleted by the GHC RTS when it is initialised.+   *+   * In this method, we can also updated them in place, without permuting the+   * order of the options to place the (now unused) Accelerate flags at the end+   * of the vector. This does create a slight change in behaviour though, where+   * the application will become more lenient to the user not (correctly)+   * closing the RTS group, for example:+   *+   * > ./foo +RTS -... +ACC -... -ACC+   *+   * is rewritten to:+   *+   * > ./foo +RTS -... -RTS -... -RTS+   *+   * Previously, since the RTS group was not terminated correctly the GHC RTS+   * would complain that the trailing Accelerate options (+ACC -...) were+   * unknown RTS flags.+   */+  for (i = cl_start; i < cl_end+1 && i < argc; ++i) {+    if (strlen(argv[i]) >= 4) {+      strcpy(argv[i], "-RTS");+    } else {+      argv[i][0] = '\0';+    }+  }++  /* cleanup */+  if (argv2) free(argv2);+  if (env)   free(env);+}++// vim: filetype=c+
+ cbits/flags_debug.c view
@@ -0,0 +1,13 @@+/*+ * Module      : Data.Array.Accelerate.Debug.Flags+ * Copyright   : [2017] Trevor L. McDonell+ * License     : BSD3+ *+ * Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+ * Stability   : experimental+ * Portability : non-portable (GHC extensions)+ */++#define ACCELERATE_DEBUG+#include "flags.inc"+
+ cbits/monitoring.c view
@@ -0,0 +1,12 @@+/*+ * Module      : Data.Array.Accelerate.Debug.Monitoring+ * Copyright   : [2016..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)+ */++#include "monitoring.inc"+
+ cbits/monitoring.inc view
@@ -0,0 +1,141 @@+/*+ * Module      : Data.Array.Accelerate.Debug.Monitoring+ * Copyright   : [2016..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)+ *+ * Support for runtime system monitoring+ *+ * This is a hack to work around <https://github.com/haskell/cabal/issues/4937>+ */++#include <stdint.h>+#include <stdio.h>+++/* These monitoring counters are globals which will be accessed from the+ * Haskell side.+ */+int64_t __active_ns_llvm_native             = 0;+int64_t __active_ns_llvm_ptx                = 0;++int64_t __current_bytes_remote              = 0;+int64_t __current_bytes_nursery             = 0;++int64_t __total_bytes_allocated_local       = 0;+int64_t __total_bytes_allocated_remote      = 0;+int64_t __total_bytes_copied_to_remote      = 0;+int64_t __total_bytes_copied_from_remote    = 0;+int64_t __total_bytes_evicted_from_remote   = 0;+int64_t __num_remote_gcs                    = 0;+int64_t __num_evictions                     = 0;++extern int32_t __dump_gc;+extern int32_t __dump_gc_stats;++#if defined(ACCELERATE_DEBUG)++/* cbits/clock.c */+double clock_gettime_elapsed_seconds(void);++/*+ * Format a large number, using comma separators.+ */+static char* format_int64(char *buffer, int64_t x)+{+  char *s = buffer;++  if (x < 0)+  {+    *s++  = '-';+    x     = -x;+  }++  if (x < 1000)+  {+    sprintf(s, "%lld", x);+  }+  else if (x < 1000000)+  {+    sprintf(s, "%lld,%03lld", x/1000, x%1000);+  }+  else if (x < 1000000000)+  {+    sprintf(s, "%lld,%03lld,%03lld"+             ,  x/1000000+             , (x/1000)%1000+             ,  x%1000);+  }+  else if (x < 1000000000000)+  {+    sprintf(s, "%lld,%03lld,%03lld,%03lld"+             ,  x/1000000000+             , (x/1000000)%1000+             , (x/1000)%1000+             ,  x%1000);+  }+  else if (x < 1000000000000000)+  {+    sprintf(s, "%lld,%03lld,%03lld,%03lld,%03lld"+             ,  x/1000000000000+             , (x/1000000000)%1000+             , (x/1000000)%1000+             , (x/1000)%1000+             ,  x%1000);+  }+  else if (x < 1000000000000000000)+  {+    sprintf(s, "%lld,%03lld,%03lld,%03lld,%03lld,%03lld"+             ,  x/1000000000000000+             , (x/1000000000000)%1000+             , (x/1000000000)%1000+             , (x/1000000)%1000+             , (x/1000)%1000+             ,  x%1000);+  }+  else+  {+    sprintf(s, "%lld,%03lld,%03lld,%03lld,%03lld,%03lld,%03lld"+             ,  x/1000000000000000000+             , (x/1000000000000000)%1000+             , (x/1000000000000)%1000+             , (x/1000000000)%1000+             , (x/1000000)%1000+             , (x/1000)%1000+             ,  x%1000);+  }++  return buffer;+}++/*+ * This function runs after main(), and is used to print final GC and memory+ * statistics (if enabled). This is similar to the +RTS -s option.+ */+__attribute__((destructor)) void dump_gc_stats(void)+{+  if (__dump_gc_stats) {+    /*+     * int64 ranges from -9223372036854775807..9223372036854775807, so we need a+     * buffer size of at least 27 characters (including the terminating \0) to+     * format any numbers with commas.+     */+    char buffer[96];+    double timestamp = clock_gettime_elapsed_seconds();++    printf("\n");+    printf("[%8.3f] gc: %s bytes allocated locally\n", timestamp, format_int64(buffer, __total_bytes_allocated_local));+    printf("[%8.3f] gc: %s bytes allocated on the remote device\n", timestamp, format_int64(buffer, __total_bytes_allocated_remote));+    printf("[%8.3f] gc: %s bytes copied to the remote device\n", timestamp, format_int64(buffer, __total_bytes_copied_to_remote));+    printf("[%8.3f] gc: %s bytes copied from the remote device\n", timestamp, format_int64(buffer, __total_bytes_copied_from_remote));+    printf("[%8.3f] gc: %s bytes evicted from the remote (%s evictions, %s GCs)\n", timestamp, format_int64(&buffer[0], __total_bytes_evicted_from_remote), format_int64(&buffer[32], __num_evictions), format_int64(&buffer[64], __num_remote_gcs));+  }+}++#endif /* ACCELERATE_DEBUG */++// vim: filetype=c+
+ cbits/monitoring_debug.c view
@@ -0,0 +1,13 @@+/*+ * Module      : Data.Array.Accelerate.Debug.Monitoring+ * Copyright   : [2016..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)+ */++#define ACCELERATE_DEBUG+#include "monitoring.inc"+
+ images/fusion_example_1.png view

binary file changed (absent → 4716 bytes)

+ images/fusion_example_2.png view

binary file changed (absent → 8506 bytes)

+ images/fusion_example_3.png view

binary file changed (absent → 7735 bytes)

+ src/Data/Array/Accelerate.hs view
@@ -0,0 +1,570 @@+-- |+-- Module      : Data.Array.Accelerate+-- 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)+--+-- @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;+-- 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:/]+--+-- 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+--+-- * <http://hackage.haskell.org/package/accelerate-llvm-native accelerate-llvm-native>:+--   implementation supporting parallel execution on multicore CPUs (e.g. x86).+--+-- * <http://hackage.haskell.org/package/accelerate-llvm-ptx accelerate-llvm-ptx>:+--   implementation supporting parallel execution on CUDA-capable NVIDIA GPUs.+--+-- [/Examples:/]+--+-- * A short tutorial-style example for generating a <https://en.wikipedia.org/wiki/Mandelbrot_set Mandelbrot set>:+--   http://www.acceleratehs.org/examples/mandelbrot.html+--+-- * 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>>+--+-- [/Starting a new project:/]+--+-- Accelerate and its associated packages are available on both Hackage and+-- Stackage. A project template is available to help create a new projects using+-- the <https://docs.haskellstack.org/en/stable/README/ stack> build tool. To+-- create a new project using the template:+--+-- > stack new PROJECT_NAME https://github.com/AccelerateHS/accelerate/raw/stable/accelerate.hsfiles+--+-- [/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-blas accelerate-blas>: BLAS+-- and LAPACK operations, 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+  -- ** Embedded array computations+  Acc,++  -- *** Arrays+  Array, Arrays, Scalar, Vector, Matrix, Segments,++  -- *** Array elements+  Elt,++  -- *** Array shapes & indices+  -- $shapes_and_indices+  --+  Z(..), (:.)(..),+  DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9,+  Shape, Slice(..), All(..), Any(..),+  -- Split(..), Divide(..), Division(..),++  -- ** Array access+  -- *** Element indexing+  (!), (!!), the,++  -- *** Shape information+  null, length, shape, size, shapeSize,++  -- ** Construction+  -- *** Introduction+  use, unit,++  -- *** Initialisation+  generate, fill,++  -- *** Enumeration+  enumFromN, enumFromStepN,++  -- *** Concatenation+  (++), concatOn,++  -- ** Composition+  -- *** Flow control+  (?|), acond, awhile,+  IfThenElse(..),++  -- *** Controlling execution+  (>->),+  compute,++  -- ** Element-wise operations+  -- *** Indexing+  indexed,++  -- *** Mapping+  map, imap,++  -- *** Zipping+  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+  unzip, unzip3, unzip4, unzip5, unzip6, unzip7, unzip8, unzip9,++  -- ** Modifying Arrays+  -- *** Shape manipulation+  reshape, flatten,++  -- *** Replication+  replicate,++  -- *** Extracting sub-arrays+  slice,+  init, tail, take, drop, slit,+  initOn, tailOn, takeOn, dropOn, slitOn,++  -- *** Permutations+  -- **** Forward permutation (scatter)+  permute,+  ignore,+  scatter,++  -- **** Backward permutation (gather)+  backpermute,+  gather,++  -- **** Specialised permutations+  reverse, transpose,+  reverseOn, transposeOn,++  -- *** Filtering+  filter,++  -- ** Folding+  fold, fold1, foldAll, fold1All,++  -- *** Segmented reductions+  foldSeg, fold1Seg,++  -- *** Specialised reductions+  all, any, and, or, sum, product, minimum, maximum,++  -- ** Scans (prefix sums)+  scanl, scanl1, scanl', scanr, scanr1, scanr',+  prescanl, postscanl, prescanr, postscanr,++  -- *** Segmented scans+  scanlSeg, scanl1Seg, scanl'Seg, prescanlSeg, postscanlSeg,+  scanrSeg, scanr1Seg, scanr'Seg, prescanrSeg, postscanrSeg,++  -- ** Stencils+  stencil, stencil2,++  -- *** Stencil specification+  Stencil, Boundary,+  clamp, mirror, wrap, function,++  -- *** Common stencil patterns+  Stencil3, Stencil5, Stencil7, Stencil9,+  Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5,+  Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,+  Stencil3x5x5, Stencil5x5x5,++  -- -- ** 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+  Exp,++  -- ** Type classes+  -- *** Basic type classes+  Eq(..),+  Ord(..), Ordering(..),+  Enum, succ, pred,+  Bounded, minBound, maxBound,++  -- *** 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(..),++  -- *** Numeric conversion classes+  FromIntegral(..),+  ToFloating(..),++  -- ** Lifting and Unlifting+  -- $lifting_and_unlifting+  --+  Lift(..), Unlift(..),+  lift1, lift2, lift3,+  ilift1, ilift2, ilift3,++  -- ** Scalar operations+  -- *** Introduction+  constant,++  -- *** Tuples+  fst, afst, snd, asnd, curry, uncurry,++  -- *** Flow control+  (?), caseof, cond, while, iterate,++  -- *** Scalar reduction+  sfoldl,++  -- *** Logical operations+  (&&), (||), not,++  -- *** Numeric operations+  subtract, even, odd, gcd, lcm, (^), (^^),++  -- *** Shape manipulation+  index0, index1, unindex1, index2, unindex2, index3, unindex3,+  indexHead, indexTail,+  toIndex, fromIndex,+  intersect,++  -- *** Conversions+  ord, chr, boolToInt, bitcast,++  -- ---------------------------------------------------------------------------+  -- * Foreign Function Interface (FFI)+  foreignAcc,+  foreignExp,++  -- ---------------------------------------------------------------------------+  -- * Plain arrays+  -- ** Operations+  arrayRank, arrayShape, arraySize, arrayReshape,+  indexArray, linearIndexArray,++  -- ** Getting data in+  -- $getting_data_in++  -- *** Function+  fromFunction,+  fromFunctionM,++  -- *** Lists+  fromList, toList,++  -- ---------------------------------------------------------------------------+  -- * Prelude re-exports+  (.), ($), error, undefined, const,++  -- ---------------------------------------------------------------------------+  -- Types+  Int, Int8, Int16, Int32, Int64,+  Word, Word8, Word16, Word32, Word64,+  Half(..), 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.Array.Sugar                            hiding ( (!), (!!), rank, shape, reshape, 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++import Prelude                                                      ( (.), ($), undefined, error, const )++-- $setup+-- >>> :seti -XTypeOperators+-- >>> import Data.Array.Accelerate.Interpreter+-- >>> :{+--   let runExp :: Elt e => Exp e -> e+--       runExp e = indexArray (run (unit e)) Z+-- :}++-- 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.+--+indexArray :: Array sh e -> sh -> e+indexArray = (S.!)++-- | Linear array indexing in plain Haskell code.+--+linearIndexArray :: Array sh e -> Int -> e+linearIndexArray = (S.!!)++-- | Rank of an array.+--+arrayRank :: Shape sh => sh -> Int+arrayRank = S.rank++-- |Array shape in plain Haskell code.+--+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 :: Shape sh => sh -> Int+arraySize = S.size++-- | Change the shape of an array without altering its contents. The 'arraySize'+-- of the source and result arrays must be identical.+--+arrayReshape :: (Shape sh, Shape sh', Elt e) => sh -> Array sh' e -> Array sh e+arrayReshape = S.reshape+++-- Named documentation chunks+-- --------------------------++-- $shapes_and_indices+--+-- 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 xs = use $ fromList (Z:.10) [0..]   :: Acc (Vector Int)+-- >>> let ys = use $ fromList (Z:.3:.4) [0..] :: Acc (Matrix Int)+-- >>> let r  = (xs,ys)                        :: (Acc (Vector Int), Acc (Matrix Int))+-- >>> let r' = lift r                         :: Acc (Vector Int, Matrix 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+--+
+ src/Data/Array/Accelerate/AST.hs view
@@ -0,0 +1,1931 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.AST+-- 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  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- /Scalar versus collective operations/+--+-- The embedded array processing language is a two-level language.  It+-- combines a language of scalar expressions and functions with a language of+-- collective array operations.  Scalar expressions are used to compute+-- arguments for collective operations and scalar functions are used to+-- parametrise higher-order, collective array operations.  The two-level+-- structure, in particular, ensures that collective operations cannot be+-- parametrised with collective operations; hence, we are following a flat+-- data-parallel model.  The collective operations manipulate+-- multi-dimensional arrays whose shape is explicitly tracked in their types.+-- In fact, collective operations cannot produce any values other than+-- multi-dimensional arrays; when they yield a scalar, this is in the form of+-- a 0-dimensional, singleton array.  Similarly, scalar expression can -as+-- their name indicates- only produce tuples of scalar, but not arrays.+--+-- There are, however, two expression forms that take arrays as arguments.  As+-- a result scalar and array expressions are recursively dependent.  As we+-- cannot and don't want to compute arrays in the middle of scalar+-- computations, array computations will always be hoisted out of scalar+-- expressions.  So that this is always possible, these array expressions may+-- not contain any free scalar variables.  To express that condition in the+-- type structure, we use separate environments for scalar and array variables.+--+-- /Programs/+--+-- Collective array programs comprise closed expressions of array operations.+-- There is no explicit sharing in the initial AST form, but sharing is+-- introduced subsequently by common subexpression elimination and floating+-- of array computations.+--+-- /Functions/+--+-- The array expression language is first-order and only provides limited+-- control structures to ensure that it can be efficiently executed on+-- compute-acceleration hardware, such as GPUs.  To restrict functions to+-- first-order, we separate function abstraction from the main expression+-- type.  Functions are represented using de Bruijn indices.+--+-- /Parametric and ad-hoc polymorphism/+--+-- The array language features paramatric polymophism (e.g., pairing and+-- projections) as well as ad-hoc polymorphism (e.g., arithmetic operations).+-- All ad-hoc polymorphic constructs include reified dictionaries (c.f.,+-- module 'Types').  Reified dictionaries also ensure that constants+-- (constructor 'Const') are representable on compute acceleration hardware.+--+-- The AST contains both reified dictionaries and type class constraints.+-- Type classes are used for array-related functionality that is uniformly+-- available for all supported types.  In contrast, reified dictionaries are+-- used for functionality that is only available for certain types, such as+-- arithmetic operations.+--++module Data.Array.Accelerate.AST (++  -- * Typed de Bruijn indices+  Idx(..), idxToInt, tupleIdxToInt,++  -- * Valuation environment+  Val(..), ValElt(..), prj, prjElt,++  -- * Accelerated array expressions+  PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc,+  PreBoundary(..), Boundary, 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,+  rnfArrays,++  -- TemplateHaskell+  LiftAcc,+  liftIdx, liftTupleIdx, liftArrays,+  liftConst, liftSliceIndex, liftPrimConst, liftPrimFun,+  liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp,++  -- debugging+  showPreAccOp, showPreExpOp,++) where++--standard library+import Control.DeepSeq+import Data.List+import Data.Typeable+import Foreign.ForeignPtr+import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable+import System.IO.Unsafe+import GHC.Ptr                                                      ( Ptr(..) )+import Language.Haskell.TH                                          ( Q, TExp )+import qualified Language.Haskell.TH                                as TH+import qualified Language.Haskell.TH.Syntax                         as TH+#if __GLASGOW_HASKELL__ <= 708+import Instances.TH.Lift                                            () -- Int8, Int16...+#endif++-- friends+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Representation                   ( SliceIndex(..), size )+import Data.Array.Accelerate.Array.Sugar                            hiding ( size )+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Type+#if __GLASGOW_HASKELL__ < 800+import Data.Array.Accelerate.Error+#endif+++-- Typed de Bruijn indices+-- -----------------------++-- De Bruijn variable index projecting a specific type from a type+-- environment.  Type environments are nested pairs (..((), t1), t2, ..., tn).+--+data Idx env t where+  ZeroIdx ::              Idx (env, t) t+  SuccIdx :: Idx env t -> Idx (env, s) t++-- de Bruijn Index to Int conversion+--+idxToInt :: Idx env t -> Int+idxToInt ZeroIdx       = 0+idxToInt (SuccIdx idx) = 1 + idxToInt idx++tupleIdxToInt :: TupleIdx tup e -> Int+tupleIdxToInt ZeroTupIdx       = 0+tupleIdxToInt (SuccTupIdx idx) = 1 + tupleIdxToInt idx+++-- Environments+-- ------------++-- Valuation for an environment+--+data Val env where+  Empty :: Val ()+  Push  :: Val env -> t -> Val (env, t)++deriving instance Typeable Val++-- Valuation for an environment of array elements+--+data ValElt env where+  EmptyElt :: ValElt ()+  PushElt  :: Elt t+           => ValElt env -> EltRepr t -> ValElt (env, t)++-- Projection of a value from a valuation using a de Bruijn index+--+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) = toElt v+prjElt (SuccIdx idx) (PushElt val _) = prjElt idx val+#if __GLASGOW_HASKELL__ < 800+prjElt _             _               = $internalError "prjElt" "inconsistent valuation"+#endif++-- Array expressions+-- -----------------++-- |Function abstraction over parametrised array computations+--+data PreOpenAfun acc aenv t where+  Abody :: Arrays t => acc             aenv      t -> PreOpenAfun acc aenv t+  Alam  :: Arrays a => PreOpenAfun acc (aenv, a) t -> PreOpenAfun acc aenv (a -> t)++-- Function abstraction over vanilla open array computations+--+type OpenAfun = PreOpenAfun OpenAcc++-- |Parametrised array-computation function without free array variables+--+type PreAfun acc = PreOpenAfun acc ()++-- |Vanilla array-computation function without free array variables+--+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.+--+-- * Scalar functions and expressions embedded in well-formed array+--   computations cannot contain free scalar variable indices.  The latter+--   cannot be bound in array computations, and hence, cannot appear in any+--   well-formed program.+--+-- * The let-form is used to represent the sharing discovered by common+--   subexpression elimination as well as to control evaluation order.  (We+--   need to hoist array expressions out of scalar expressions - they occur in+--   scalar indexing and in determining an arrays shape.)+--+-- The data type is parameterised over the surface types (not the representation+-- type).+--+-- We use a non-recursive variant parametrised over the recursive closure, to facilitate attribute+-- calculation in the backend.+--+data PreOpenAcc acc aenv a where++  -- Local binding to represent sharing and demand explicitly; this is an+  -- eager(!) binding+  Alet        :: (Arrays bndArrs, Arrays bodyArrs)+              => acc            aenv            bndArrs         -- bound expression+              -> acc            (aenv, bndArrs) bodyArrs        -- the bound expression scope+              -> PreOpenAcc acc aenv            bodyArrs++  -- Variable bound by a 'Let', represented by a de Bruijn index+  Avar        :: Arrays arrs+              => Idx            aenv arrs+              -> PreOpenAcc acc aenv arrs++  -- Tuples of arrays+  Atuple      :: (Arrays arrs, IsAtuple arrs)+              => Atuple    (acc aenv) (TupleRepr arrs)+              -> PreOpenAcc acc aenv  arrs++  Aprj        :: (Arrays arrs, IsAtuple arrs, Arrays a)+              => TupleIdx (TupleRepr arrs) a+              ->            acc aenv arrs+              -> PreOpenAcc acc aenv a++  -- Array-function application.+  --+  -- The array function is not closed at the core level because we need access+  -- to free variables introduced by 'run1' style evaluators. See Issue#95.+  --+  Apply       :: (Arrays arrs1, Arrays arrs2)+              => PreOpenAfun acc aenv (arrs1 -> arrs2)+              -> acc             aenv arrs1+              -> PreOpenAcc  acc aenv arrs2++  -- 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 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+              => PreExp     acc aenv Bool+              -> acc            aenv arrs+              -> acc            aenv arrs+              -> PreOpenAcc acc aenv arrs++  -- Value-recursion for array-level computations+  Awhile      :: Arrays arrs+              => PreOpenAfun acc aenv (arrs -> Scalar Bool)     -- continue iteration while true+              -> PreOpenAfun acc aenv (arrs -> arrs)            -- function to iterate+              -> acc             aenv arrs                      -- initial value+              -> PreOpenAcc  acc aenv arrs+++  -- Array inlet (triggers async host->device transfer if necessary)+  Use         :: Arrays arrs+              => ArrRepr arrs+              -> PreOpenAcc acc aenv arrs++  -- Capture a scalar (or a tuple of scalars) in a singleton array+  Unit        :: Elt e+              => PreExp     acc aenv e+              -> PreOpenAcc acc aenv (Scalar e)++  -- Change the shape of an array without altering its contents+  -- > precondition: size dim == size dim'+  Reshape     :: (Shape sh, Shape sh', Elt e)+              => PreExp     acc aenv sh                         -- new shape+              -> acc            aenv (Array sh' e)              -- array to be reshaped+              -> PreOpenAcc acc aenv (Array sh e)++  -- Construct a new array by applying a function to each index.+  Generate    :: (Shape sh, Elt e)+              => PreExp     acc aenv sh                         -- output shape+              -> PreFun     acc aenv (sh -> e)                  -- representation function+              -> PreOpenAcc acc aenv (Array sh e)++  -- Hybrid map/backpermute, where we separate the index and value+  -- transformations.+  Transform   :: (Elt a, Elt b, Shape sh, Shape sh')+              => PreExp     acc aenv sh'                        -- dimension of the result+              -> PreFun     acc aenv (sh' -> sh)                -- index permutation function+              -> PreFun     acc aenv (a   -> b)                 -- function to apply at each element+              ->            acc aenv (Array sh  a)              -- source array+              -> PreOpenAcc acc aenv (Array sh' b)++  -- Replicate an array across one or more dimensions as given by the first+  -- argument+  Replicate   :: (Shape sh, Shape sl, Elt slix, Elt e)+              => SliceIndex (EltRepr slix)                      -- slice type specification+                            (EltRepr sl)+                            co+                            (EltRepr sh)+              -> PreExp     acc aenv slix                       -- slice value specification+              -> acc            aenv (Array sl e)               -- data to be replicated+              -> PreOpenAcc acc aenv (Array sh e)++  -- Index a sub-array out of an array; i.e., the dimensions not indexed are+  -- returned whole+  Slice       :: (Shape sh, Shape sl, Elt slix, Elt e)+              => SliceIndex (EltRepr slix)                      -- slice type specification+                            (EltRepr sl)+                            co+                            (EltRepr sh)+              -> acc            aenv (Array sh e)               -- array to be indexed+              -> PreExp     acc aenv slix                       -- slice value specification+              -> PreOpenAcc acc aenv (Array sl e)++  -- Apply the given unary function to all elements of the given array+  Map         :: (Shape sh, Elt e, Elt e')+              => PreFun     acc aenv (e -> e')+              -> acc            aenv (Array sh e)+              -> PreOpenAcc acc aenv (Array sh e')++  -- Apply a given binary function pairwise to all elements of the given arrays.+  -- The length of the result is the length of the shorter of the two argument+  -- arrays.+  ZipWith     :: (Shape sh, Elt e1, Elt e2, Elt e3)+              => PreFun     acc aenv (e1 -> e2 -> e3)+              -> acc            aenv (Array sh e1)+              -> acc            aenv (Array sh e2)+              -> PreOpenAcc acc aenv (Array sh e3)++  -- Fold along the innermost dimension of an array with a given /associative/ function.+  Fold        :: (Shape sh, Elt e)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> PreExp     acc aenv e                          -- default value+              -> acc            aenv (Array (sh:.Int) e)        -- folded array+              -> PreOpenAcc acc aenv (Array sh e)++  -- 'Fold' without a default value+  Fold1       :: (Shape sh, Elt e)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> acc            aenv (Array (sh:.Int) e)        -- folded array+              -> PreOpenAcc acc aenv (Array sh e)++  -- Segmented fold along the innermost dimension of an array with a given /associative/ function+  FoldSeg     :: (Shape sh, Elt e, Elt i, IsIntegral i)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> PreExp     acc aenv e                          -- default value+              -> acc            aenv (Array (sh:.Int) e)        -- folded array+              -> acc            aenv (Segments i)               -- segment descriptor+              -> PreOpenAcc acc aenv (Array (sh:.Int) e)++  -- 'FoldSeg' without a default value+  Fold1Seg    :: (Shape sh, Elt e, Elt i, IsIntegral i)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> acc            aenv (Array (sh:.Int) e)        -- folded array+              -> acc            aenv (Segments i)               -- segment descriptor+              -> PreOpenAcc acc aenv (Array (sh:.Int) e)++  -- 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       :: (Shape sh, Elt e)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> PreExp     acc aenv e                          -- initial value+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e)++  -- 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'      :: (Shape sh, Elt e)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> PreExp     acc aenv e                          -- initial value+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e, Array sh e)++  -- Haskell-style scan without an initial value+  Scanl1      :: (Shape sh, Elt e)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e)++  -- Right-to-left version of 'Scanl'+  Scanr       :: (Shape sh, Elt e)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> PreExp     acc aenv e                          -- initial value+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e)++  -- Right-to-left version of 'Scanl\''+  Scanr'      :: (Shape sh, Elt e)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> PreExp     acc aenv e                          -- initial value+              -> acc            aenv (Array (sh:.Int) e)+              -> PreOpenAcc acc aenv (Array (sh:.Int) e, Array sh e)++  -- Right-to-left version of 'Scanl1'+  Scanr1      :: (Shape sh, Elt e)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> 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+  -- the output. The permutation can be between arrays of varying shape and+  -- dimensionality.+  --+  -- Other characteristics of the permutation function 'f':+  --+  --   1. 'f' is a partial function: if it evaluates to the magic value 'ignore'+  --      (i.e. a tuple of -1 values) then those elements of the domain are+  --      dropped.+  --+  --   2. 'f' is not surjective: positions in the target array need not be+  --      picked up by the permutation function, so the target array must first+  --      be initialised from an array of default values.+  --+  --   3. 'f' is not injective: distinct elements of the domain may map to the+  --      same position in the target array. In this case the combination+  --      function is used to combine elements, which needs to be /associative/+  --      and /commutative/.+  --+  Permute     :: (Shape sh, Shape sh', Elt e)+              => PreFun     acc aenv (e -> e -> e)              -- combination function+              -> acc            aenv (Array sh' e)              -- default values+              -> PreFun     acc aenv (sh -> sh')                -- permutation function+              -> acc            aenv (Array sh e)               -- source array+              -> PreOpenAcc acc aenv (Array sh' e)++  -- Generalised multi-dimensional backwards permutation; the permutation can+  -- be between arrays of varying shape; the permutation function must be total+  Backpermute :: (Shape sh, Shape sh', Elt e)+              => PreExp     acc aenv sh'                        -- dimensions of the result+              -> PreFun     acc aenv (sh' -> sh)                -- permutation function+              -> acc            aenv (Array sh e)               -- source array+              -> PreOpenAcc acc aenv (Array sh' e)++  -- Map a stencil over an array.  In contrast to 'map', the domain of a stencil function is an+  -- entire /neighbourhood/ of each array element.+  Stencil     :: (Elt e, Elt e', Stencil sh e stencil)+              => PreFun      acc aenv (stencil -> e')           -- stencil function+              -> PreBoundary acc aenv (Array sh e)              -- boundary condition+              -> acc             aenv (Array sh e)              -- source array+              -> PreOpenAcc  acc aenv (Array sh e')++  -- Map a binary stencil over an array.+  Stencil2    :: (Elt a, Elt b, Elt c, Stencil sh a stencil1, Stencil sh b stencil2)+              => PreFun      acc aenv (stencil1 -> stencil2 -> c) -- stencil function+              -> PreBoundary acc aenv (Array sh a)                -- boundary condition #1+              -> acc             aenv (Array sh a)                -- source array #1+              -> PreBoundary acc aenv (Array sh b)                -- boundary condition #2+              -> acc             aenv (Array sh b)                -- source array #2+              -> PreOpenAcc acc  aenv (Array sh c)++  -- A sequence of operations.+  -- Collect     :: Arrays arrs+  --             => PreOpenSeq acc aenv () arrs+  --             -> PreOpenAcc acc aenv arrs++{--+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++  Consumer :: Arrays arrs+           => Consumer acc aenv senv arrs+           -> PreOpenSeq acc aenv senv arrs++  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 Seq = PreOpenSeq OpenAcc () ()+--}+++-- | Vanilla stencil boundary condition+--+type Boundary = PreBoundary OpenAcc++-- | Boundary condition specification for stencil operations+--+data PreBoundary (acc :: * -> * -> *) aenv t where+  -- Clamp coordinates to the extent of the array+  Clamp     :: PreBoundary acc aenv t++  -- Mirror coordinates beyond the array extent+  Mirror    :: PreBoundary acc aenv t++  -- Wrap coordinates around on each dimension+  Wrap      :: PreBoundary acc aenv t++  -- Use a constant value for outlying coordinates+  Constant  :: Elt e+            => EltRepr e+            -> PreBoundary acc aenv (Array sh e)++  -- Apply the given function to outlying coordinates+  Function  :: (Shape sh, Elt e)+            => PreFun acc aenv (sh -> e)+            -> PreBoundary acc aenv (Array sh e)+++-- | Operations on stencils+--+class (Shape sh, Elt e, IsTuple stencil, Elt stencil) => Stencil sh e stencil where+  stencil :: StencilR sh e stencil++-- | GADT reifying the 'Stencil' class+--+data StencilR sh e pat where+  StencilRunit3 :: Elt e => StencilR DIM1 e (e,e,e)+  StencilRunit5 :: Elt e => StencilR DIM1 e (e,e,e,e,e)+  StencilRunit7 :: Elt e => StencilR DIM1 e (e,e,e,e,e,e,e)+  StencilRunit9 :: Elt e => StencilR DIM1 e (e,e,e,e,e,e,e,e,e)++  StencilRtup3  :: (Shape sh, Elt e)+                => StencilR sh e pat1+                -> StencilR sh e pat2+                -> StencilR sh e pat3+                -> StencilR (sh:.Int) e (pat1,pat2,pat3)++  StencilRtup5  :: (Shape sh, Elt e)+                => StencilR sh e pat1+                -> StencilR sh e pat2+                -> StencilR sh e pat3+                -> StencilR sh e pat4+                -> StencilR sh e pat5+                -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5)++  StencilRtup7  :: (Shape sh, Elt e)+                => StencilR sh e pat1+                -> StencilR sh e pat2+                -> StencilR sh e pat3+                -> StencilR sh e pat4+                -> StencilR sh e pat5+                -> StencilR sh e pat6+                -> StencilR sh e pat7+                -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7)++  StencilRtup9  :: (Shape sh, Elt e)+                => StencilR sh e pat1+                -> StencilR sh e pat2+                -> StencilR sh e pat3+                -> StencilR sh e pat4+                -> StencilR sh e pat5+                -> StencilR sh e pat6+                -> StencilR sh e pat7+                -> StencilR sh e pat8+                -> StencilR sh e pat9+                -> StencilR (sh:.Int) e (pat1,pat2,pat3,pat4,pat5,pat6,pat7,pat8,pat9)+++-- Note: [Stencil reification class]+--+-- We cannot start with 'DIM0'.  The 'IsTuple stencil' superclass would at+-- 'DIM0' imply that the types of individual array elements are in 'IsTuple'.+-- (That would only possible if we could have (degenerate) 1-tuple, but we can't+-- as we can't distinguish between a 1-tuple of a pair and a simple pair.)+-- Hence, we need to start from 'DIM1' and use 'sh:.Int:.Int' in the recursive+-- case (to avoid overlapping instances).++-- DIM1+instance Elt e => Stencil DIM1 e (e, e, e) where+  stencil = StencilRunit3++instance Elt e => Stencil DIM1 e (e, e, e, e, e) where+  stencil = StencilRunit5++instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e) where+  stencil = StencilRunit7++instance Elt e => Stencil DIM1 e (e, e, e, e, e, e, e, e, e) where+  stencil = StencilRunit9++-- DIM(n+1), where n>1+instance (Stencil (sh:.Int) a row1,+          Stencil (sh:.Int) a row2,+          Stencil (sh:.Int) a row3) => Stencil (sh:.Int:.Int) a (row1, row2, row3) where+  stencil = StencilRtup3 stencil stencil stencil++instance (Stencil (sh:.Int) a row1,+          Stencil (sh:.Int) a row2,+          Stencil (sh:.Int) a row3,+          Stencil (sh:.Int) a row4,+          Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where+  stencil = StencilRtup5 stencil stencil stencil stencil stencil++instance (Stencil (sh:.Int) a row1,+          Stencil (sh:.Int) a row2,+          Stencil (sh:.Int) a row3,+          Stencil (sh:.Int) a row4,+          Stencil (sh:.Int) a row5,+          Stencil (sh:.Int) a row6,+          Stencil (sh:.Int) a row7)+  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where+  stencil = StencilRtup7 stencil stencil stencil stencil stencil stencil stencil++instance (Stencil (sh:.Int) a row1,+          Stencil (sh:.Int) a row2,+          Stencil (sh:.Int) a row3,+          Stencil (sh:.Int) a row4,+          Stencil (sh:.Int) a row5,+          Stencil (sh:.Int) a row6,+          Stencil (sh:.Int) a row7,+          Stencil (sh:.Int) a row8,+          Stencil (sh:.Int) a row9)+  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where+  stencil = StencilRtup9 stencil stencil stencil stencil stencil stencil stencil stencil stencil+++-- Embedded expressions+-- --------------------++-- |Parametrised open function abstraction+--+data PreOpenFun (acc :: * -> * -> *) env aenv t where+  Body :: Elt t => PreOpenExp acc env      aenv t -> PreOpenFun acc env aenv t+  Lam  :: Elt a => PreOpenFun acc (env, a) aenv t -> PreOpenFun acc env aenv (a -> t)++-- |Vanilla open function abstraction+--+type OpenFun = PreOpenFun OpenAcc++-- |Parametrised function without free scalar variables+--+type PreFun acc = PreOpenFun acc ()++-- |Vanilla function without free scalar variables+--+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.+--+-- The data type is parametrised over the surface types (not the representation type).+--+data PreOpenExp (acc :: * -> * -> *) env aenv t where++  -- Local binding of a scalar expression+  Let           :: (Elt bnd_t, Elt body_t)+                => PreOpenExp acc env          aenv bnd_t+                -> PreOpenExp acc (env, bnd_t) aenv body_t+                -> PreOpenExp acc env          aenv body_t++  -- Variable index, ranging only over tuples or scalars+  Var           :: Elt t+                => Idx env t+                -> PreOpenExp acc env aenv t++  -- Apply a backend-specific foreign function+  Foreign       :: (Foreign asm, Elt x, Elt y)+                => asm           (x -> y)           -- foreign function+                -> PreFun acc () (x -> y)           -- alternate implementation (for other backends)+                -> PreOpenExp acc env aenv x+                -> PreOpenExp acc env aenv y++  -- Tuples+  Tuple         :: (Elt t, IsTuple t)+                => Tuple (PreOpenExp acc env aenv) (TupleRepr t)+                -> PreOpenExp acc env aenv t++  Prj           :: (Elt t, IsTuple t, Elt e)+                => TupleIdx (TupleRepr t) e+                -> PreOpenExp acc env aenv t+                -> PreOpenExp acc env aenv e++  -- Array indices & shapes+  IndexNil      :: PreOpenExp acc env aenv Z++  IndexCons     :: (Slice sl, Elt a)+                => PreOpenExp acc env aenv sl+                -> PreOpenExp acc env aenv a+                -> PreOpenExp acc env aenv (sl:.a)++  IndexHead     :: (Slice sl, Elt a)+                => PreOpenExp acc env aenv (sl:.a)+                -> PreOpenExp acc env aenv a++  IndexTail     :: (Slice sl, Elt a)+                => PreOpenExp acc env aenv (sl:.a)+                -> PreOpenExp acc env aenv sl++  IndexAny      :: Shape sh+                => PreOpenExp acc env aenv (Any sh)++  IndexSlice    :: (Shape sh, Shape sl, Elt slix)+                => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+                -> PreOpenExp acc env aenv slix+                -> PreOpenExp acc env aenv sh+                -> PreOpenExp acc env aenv sl++  IndexFull     :: (Shape sh, Shape sl, Elt slix)+                => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+                -> PreOpenExp acc env aenv slix+                -> PreOpenExp acc env aenv sl+                -> PreOpenExp acc env aenv sh++  -- Shape and index conversion+  ToIndex       :: Shape sh+                => PreOpenExp acc env aenv sh           -- shape of the array+                -> PreOpenExp acc env aenv sh           -- index into the array+                -> PreOpenExp acc env aenv Int++  FromIndex     :: Shape sh+                => PreOpenExp acc env aenv sh           -- shape of the array+                -> PreOpenExp acc env aenv Int          -- index into linear representation+                -> PreOpenExp acc env aenv sh++  -- Conditional expression (non-strict in 2nd and 3rd argument)+  Cond          :: Elt t+                => PreOpenExp acc env aenv Bool+                -> PreOpenExp acc env aenv t+                -> PreOpenExp acc env aenv t+                -> PreOpenExp acc env aenv t++  -- Value recursion+  While         :: Elt a+                => PreOpenFun acc env aenv (a -> Bool)  -- continue while true+                -> PreOpenFun acc env aenv (a -> a)     -- function to iterate+                -> PreOpenExp acc env aenv a            -- initial value+                -> PreOpenExp acc env aenv a++  -- Constant values+  Const         :: Elt t+                => EltRepr t+                -> PreOpenExp acc env aenv t++  PrimConst     :: Elt t+                => PrimConst t+                -> PreOpenExp acc env aenv t++  -- Primitive scalar operations+  PrimApp       :: (Elt a, Elt r)+                => PrimFun (a -> r)+                -> PreOpenExp acc env aenv a+                -> PreOpenExp acc env aenv r++  -- Project a single scalar from an array.+  -- The array expression can not contain any free scalar variables.+  Index         :: (Shape dim, Elt t)+                => acc                aenv (Array dim t)+                -> PreOpenExp acc env aenv dim+                -> PreOpenExp acc env aenv t++  LinearIndex   :: (Shape dim, Elt t)+                => acc                aenv (Array dim t)+                -> PreOpenExp acc env aenv Int+                -> PreOpenExp acc env aenv t++  -- Array shape.+  -- The array expression can not contain any free scalar variables.+  Shape         :: (Shape dim, Elt e)+                => acc                aenv (Array dim e)+                -> PreOpenExp acc env aenv dim++  -- Number of elements of an array given its shape+  ShapeSize     :: Shape dim+                => PreOpenExp acc env aenv dim+                -> PreOpenExp acc env aenv Int++  -- Intersection of two shapes+  Intersect     :: Shape dim+                => PreOpenExp acc env aenv dim+                -> 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++  -- Unsafe operations (may fail or result in undefined behaviour)+  -- An unspecified bit pattern+  Undef         :: Elt t+                => PreOpenExp acc env aenv t++  -- Reinterpret the bits of a value as a different type+  Coerce        :: (Elt a, Elt b)+                => PreOpenExp acc env aenv a+                -> PreOpenExp acc env aenv b+++-- |Primitive constant values+--+data PrimConst ty where++  -- constants from Bounded+  PrimMinBound  :: BoundedType a -> PrimConst a+  PrimMaxBound  :: BoundedType a -> PrimConst a++  -- constant from Floating+  PrimPi        :: FloatingType a -> PrimConst a++-- |Primitive scalar operations+--+data PrimFun sig where++  -- operators from Num+  PrimAdd  :: NumType a -> PrimFun ((a, a) -> a)+  PrimSub  :: NumType a -> PrimFun ((a, a) -> a)+  PrimMul  :: NumType a -> PrimFun ((a, a) -> a)+  PrimNeg  :: NumType a -> PrimFun (a      -> a)+  PrimAbs  :: NumType a -> PrimFun (a      -> a)+  PrimSig  :: NumType a -> PrimFun (a      -> a)++  -- 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)+  PrimDivMod   :: IntegralType a -> PrimFun ((a, a)   -> (a, a))++  -- 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)+  PrimCos         :: FloatingType a -> PrimFun (a      -> a)+  PrimTan         :: FloatingType a -> PrimFun (a      -> a)+  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)+  PrimExpFloating :: FloatingType a -> PrimFun (a      -> a)+  PrimSqrt        :: FloatingType a -> PrimFun (a      -> a)+  PrimLog         :: FloatingType a -> PrimFun (a      -> a)+  PrimFPow        :: FloatingType a -> PrimFun ((a, a) -> a)+  PrimLogBase     :: FloatingType a -> PrimFun ((a, a) -> a)++  -- 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+  PrimAtan2          :: FloatingType a -> PrimFun ((a, a) -> a)+  PrimIsNaN          :: FloatingType a -> PrimFun (a -> Bool)+  PrimIsInfinite     :: FloatingType a -> PrimFun (a -> Bool)++  -- relational and equality operators+  PrimLt   :: SingleType a -> PrimFun ((a, a) -> Bool)+  PrimGt   :: SingleType a -> PrimFun ((a, a) -> Bool)+  PrimLtEq :: SingleType a -> PrimFun ((a, a) -> Bool)+  PrimGtEq :: SingleType a -> PrimFun ((a, a) -> Bool)+  PrimEq   :: SingleType a -> PrimFun ((a, a) -> Bool)+  PrimNEq  :: SingleType a -> PrimFun ((a, a) -> Bool)+  PrimMax  :: SingleType a -> PrimFun ((a, a) -> a   )+  PrimMin  :: SingleType a -> PrimFun ((a, a) -> a   )++  -- logical operators+  PrimLAnd :: PrimFun ((Bool, Bool) -> Bool)+  PrimLOr  :: PrimFun ((Bool, Bool) -> Bool)+  PrimLNot :: PrimFun (Bool         -> Bool)++  -- character conversions+  PrimOrd  :: PrimFun (Char -> Int)+  PrimChr  :: PrimFun (Int  -> Char)++  -- 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)+++-- 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 :: PreBoundary acc aenv' (Array sh e) -> ()+      rnfB = rnfBoundary rnfA+  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 b  `seq` rnfA a+    Stencil2 f b1 a1 b2 a2    -> rnfF f `seq` rnfB b1 `seq` rnfB 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 :: forall acc aenv sh e. NFDataAcc acc -> PreBoundary acc aenv (Array sh e) -> ()+rnfBoundary _    Clamp        = ()+rnfBoundary _    Mirror       = ()+rnfBoundary _    Wrap         = ()+rnfBoundary _    (Constant c) = rnfConst (eltType (undefined::e)) c+rnfBoundary rnfA (Function f) = rnfPreOpenFun rnfA f+++{--+-- 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+    Undef                     -> ()+    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+    Coerce e                  -> rnfE e++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 TypeRunit          ()    = ()+rnfConst (TypeRscalar t)    !_    = rnfScalarType t  -- scalars should have (nf == whnf)+rnfConst (TypeRpair 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 (PrimIsInfinite t)         = rnfFloatingType t+rnfPrimFun (PrimAtan2 t)              = rnfFloatingType t+rnfPrimFun (PrimLt t)                 = rnfSingleType t+rnfPrimFun (PrimGt t)                 = rnfSingleType t+rnfPrimFun (PrimLtEq t)               = rnfSingleType t+rnfPrimFun (PrimGtEq t)               = rnfSingleType t+rnfPrimFun (PrimEq t)                 = rnfSingleType t+rnfPrimFun (PrimNEq t)                = rnfSingleType t+rnfPrimFun (PrimMax t)                = rnfSingleType t+rnfPrimFun (PrimMin t)                = rnfSingleType 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++rnfSliceIndex :: SliceIndex ix slice co sh -> ()+rnfSliceIndex SliceNil        = ()+rnfSliceIndex (SliceAll sh)   = rnfSliceIndex sh+rnfSliceIndex (SliceFixed sh) = rnfSliceIndex sh++rnfScalarType :: ScalarType t -> ()+rnfScalarType (SingleScalarType t) = rnfSingleType t+rnfScalarType (VectorScalarType t) = rnfVectorType t++rnfSingleType :: SingleType t -> ()+rnfSingleType (NumSingleType t)    = rnfNumType t+rnfSingleType (NonNumSingleType t) = rnfNonNumType t++rnfVectorType :: VectorType t -> ()+rnfVectorType (Vector2Type t)  = rnfSingleType t+rnfVectorType (Vector3Type t)  = rnfSingleType t+rnfVectorType (Vector4Type t)  = rnfSingleType t+rnfVectorType (Vector8Type t)  = rnfSingleType t+rnfVectorType (Vector16Type t) = rnfSingleType 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 (TypeHalf    FloatingDict) = ()+rnfFloatingType (TypeFloat   FloatingDict) = ()+rnfFloatingType (TypeDouble  FloatingDict) = ()+rnfFloatingType (TypeCFloat  FloatingDict) = ()+rnfFloatingType (TypeCDouble FloatingDict) = ()+++-- Template Haskell+-- ================++type LiftAcc acc = forall aenv a. acc aenv a -> Q (TExp (acc aenv a))++liftIdx :: Idx env t -> Q (TExp (Idx env t))+liftIdx ZeroIdx      = [|| ZeroIdx ||]+liftIdx (SuccIdx ix) = [|| SuccIdx $$(liftIdx ix) ||]++liftTupleIdx :: TupleIdx t e -> Q (TExp (TupleIdx t e))+liftTupleIdx ZeroTupIdx       = [|| ZeroTupIdx ||]+liftTupleIdx (SuccTupIdx tix) = [|| SuccTupIdx $$(liftTupleIdx tix) ||]+++liftPreOpenAfun :: LiftAcc acc -> PreOpenAfun acc aenv t -> Q (TExp (PreOpenAfun acc aenv t))+liftPreOpenAfun liftA (Alam f)  = [|| Alam  $$(liftPreOpenAfun liftA f) ||]+liftPreOpenAfun liftA (Abody b) = [|| Abody $$(liftA b) ||]++liftPreOpenAcc+    :: forall acc aenv a.+       LiftAcc acc+    -> PreOpenAcc acc aenv a+    -> Q (TExp (PreOpenAcc acc aenv a))+liftPreOpenAcc liftA pacc =+  let+      liftE :: PreOpenExp acc env aenv t -> Q (TExp (PreOpenExp acc env aenv t))+      liftE = liftPreOpenExp liftA++      liftF :: PreOpenFun acc env aenv t -> Q (TExp (PreOpenFun acc env aenv t))+      liftF = liftPreOpenFun liftA++      liftAF :: PreOpenAfun acc aenv f -> Q (TExp (PreOpenAfun acc aenv f))+      liftAF = liftPreOpenAfun liftA++      liftB :: PreBoundary acc aenv (Array sh e) -> Q (TExp (PreBoundary acc aenv (Array sh e)))+      liftB = liftBoundary liftA++      liftAtuple :: Atuple (acc aenv) t -> Q (TExp (Atuple (acc aenv) t))+      liftAtuple NilAtup          = [|| NilAtup ||]+      liftAtuple (SnocAtup tup a) = [|| SnocAtup $$(liftAtuple tup) $$(liftA a) ||]+  in+  case pacc of+    Alet bnd body             -> [|| Alet $$(liftA bnd) $$(liftA body) ||]+    Avar ix                   -> [|| Avar $$(liftIdx ix) ||]+    Atuple tup                -> [|| Atuple $$(liftAtuple tup) ||]+    Aprj tix a                -> [|| Aprj $$(liftTupleIdx tix) $$(liftA a) ||]+    Apply f a                 -> [|| Apply $$(liftAF f) $$(liftA a) ||]+    Aforeign asm f a          -> [|| Aforeign $$(liftForeign asm) $$(liftPreOpenAfun liftA f) $$(liftA a) ||]+    Acond p t e               -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||]+    Awhile p f a              -> [|| Awhile $$(liftAF p) $$(liftAF f) $$(liftA a) ||]+    Use a                     -> [|| Use $$(liftArrays (arrays (undefined::a)) a) ||]+    Unit e                    -> [|| Unit $$(liftE e) ||]+    Reshape sh a              -> [|| Reshape $$(liftE sh) $$(liftA a) ||]+    Generate sh f             -> [|| Generate $$(liftE sh) $$(liftF f) ||]+    Transform sh p f a        -> [|| Transform $$(liftE sh) $$(liftF p) $$(liftF f) $$(liftA a) ||]+    Replicate slix sl a       -> [|| Replicate $$(liftSliceIndex slix) $$(liftE sl) $$(liftA a) ||]+    Slice slix a sh           -> [|| Slice $$(liftSliceIndex slix) $$(liftA a) $$(liftE sh) ||]+    Map f a                   -> [|| Map $$(liftF f) $$(liftA a) ||]+    ZipWith f a b             -> [|| ZipWith $$(liftF f) $$(liftA a) $$(liftA b) ||]+    Fold f z a                -> [|| Fold $$(liftF f) $$(liftE z) $$(liftA a) ||]+    Fold1 f a                 -> [|| Fold1 $$(liftF f) $$(liftA a) ||]+    FoldSeg f z a s           -> [|| FoldSeg $$(liftF f) $$(liftE z) $$(liftA a) $$(liftA s) ||]+    Fold1Seg f a s            -> [|| Fold1Seg $$(liftF f) $$(liftA a) $$(liftA s) ||]+    Scanl f z a               -> [|| Scanl $$(liftF f) $$(liftE z) $$(liftA a) ||]+    Scanl1 f a                -> [|| Scanl1 $$(liftF f) $$(liftA a) ||]+    Scanl' f z a              -> [|| Scanl' $$(liftF f) $$(liftE z) $$(liftA a) ||]+    Scanr f z a               -> [|| Scanr $$(liftF f) $$(liftE z) $$(liftA a) ||]+    Scanr1 f a                -> [|| Scanr1 $$(liftF f) $$(liftA a) ||]+    Scanr' f z a              -> [|| Scanr' $$(liftF f) $$(liftE z) $$(liftA a) ||]+    Permute f d p a           -> [|| Permute $$(liftF f) $$(liftA d) $$(liftF p) $$(liftA a) ||]+    Backpermute sh p a        -> [|| Backpermute $$(liftE sh) $$(liftF p) $$(liftA a) ||]+    Stencil f b a             -> [|| Stencil $$(liftF f) $$(liftB b) $$(liftA a) ||]+    Stencil2 f b1 a1 b2 a2    -> [|| Stencil2 $$(liftF f) $$(liftB b1) $$(liftA a1) $$(liftB b2) $$(liftA a2) ||]+++liftPreOpenFun+    :: LiftAcc acc+    -> PreOpenFun acc env aenv t+    -> Q (TExp (PreOpenFun acc env aenv t))+liftPreOpenFun liftA (Lam f)  = [|| Lam  $$(liftPreOpenFun liftA f) ||]+liftPreOpenFun liftA (Body b) = [|| Body $$(liftPreOpenExp liftA b) ||]++liftPreOpenExp+    :: forall acc env aenv t.+       LiftAcc acc+    -> PreOpenExp acc env aenv t+    -> Q (TExp (PreOpenExp acc env aenv t))+liftPreOpenExp liftA pexp =+  let+      liftE :: PreOpenExp acc env aenv e -> Q (TExp (PreOpenExp acc env aenv e))+      liftE = liftPreOpenExp liftA++      liftF :: PreOpenFun acc env aenv f -> Q (TExp (PreOpenFun acc env aenv f))+      liftF = liftPreOpenFun liftA++      liftT :: Tuple (PreOpenExp acc env aenv) e -> Q (TExp (Tuple (PreOpenExp acc env aenv) e))+      liftT NilTup          = [|| NilTup ||]+      liftT (SnocTup tup e) = [|| SnocTup $$(liftT tup) $$(liftE e) ||]+  in+  case pexp of+    Let bnd body              -> [|| Let $$(liftPreOpenExp liftA bnd) $$(liftPreOpenExp liftA body) ||]+    Var ix                    -> [|| Var $$(liftIdx ix) ||]+    Foreign asm f x           -> [|| Foreign $$(liftForeign asm) $$(liftPreOpenFun liftA f) $$(liftE x) ||]+    Const c                   -> [|| Const $$(liftConst (eltType (undefined::t)) c) ||]+    Undef                     -> [|| Undef ||]+    Tuple tup                 -> [|| Tuple $$(liftT tup) ||]+    Prj tix e                 -> [|| Prj $$(liftTupleIdx tix) $$(liftE e) ||]+    IndexNil                  -> [|| IndexNil ||]+    IndexCons sh sz           -> [|| IndexCons $$(liftE sh) $$(liftE sz) ||]+    IndexHead sh              -> [|| IndexHead $$(liftE sh) ||]+    IndexTail sh              -> [|| IndexTail $$(liftE sh) ||]+    IndexAny                  -> [|| IndexAny ||]+    IndexSlice slice slix sh  -> [|| IndexSlice $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sh) ||]+    IndexFull slice slix sl   -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||]+    ToIndex sh ix             -> [|| ToIndex $$(liftE sh) $$(liftE ix) ||]+    FromIndex sh ix           -> [|| FromIndex $$(liftE sh) $$(liftE ix) ||]+    Cond p t e                -> [|| Cond $$(liftE p) $$(liftE t) $$(liftE e) ||]+    While p f x               -> [|| While $$(liftF p) $$(liftF f) $$(liftE x) ||]+    PrimConst t               -> [|| PrimConst $$(liftPrimConst t) ||]+    PrimApp f x               -> [|| PrimApp $$(liftPrimFun f) $$(liftE x) ||]+    Index a ix                -> [|| Index $$(liftA a) $$(liftE ix) ||]+    LinearIndex a ix          -> [|| LinearIndex $$(liftA a) $$(liftE ix) ||]+    Shape a                   -> [|| Shape $$(liftA a) ||]+    ShapeSize ix              -> [|| ShapeSize $$(liftE ix) ||]+    Intersect sh1 sh2         -> [|| Intersect $$(liftE sh1) $$(liftE sh2) ||]+    Union sh1 sh2             -> [|| Union $$(liftE sh1) $$(liftE sh2) ||]+    Coerce e                  -> [|| Coerce $$(liftE e) ||]+++liftArrays :: ArraysR arr -> arr -> Q (TExp arr)+liftArrays ArraysRunit ()              = [|| () ||]+liftArrays ArraysRarray arr            = [|| $$(liftArray arr) ||]+liftArrays (ArraysRpair r1 r2) (a1,a2) = [|| ($$(liftArrays r1 a1), $$(liftArrays r2 a2)) ||]++liftArray :: forall sh e. Array sh e -> Q (TExp (Array sh e))+liftArray (Array sh adata) =+  [|| Array $$(liftConst (eltType (undefined::sh)) sh) $$(go arrayElt adata) ||] `sigE` typeRepToType (typeOf (undefined::Array sh e))+  where+    sz :: Int+    sz = size sh++    sigE :: Q (TExp t) -> Q TH.Type -> Q (TExp t)+    sigE e t = TH.unsafeTExpCoerce $ TH.sigE (TH.unTypeQ e) t++    typeRepToType :: TypeRep -> Q TH.Type+    typeRepToType trep = do+      let (con, args)     = splitTyConApp trep+          name            = TH.Name (TH.OccName (tyConName con)) (TH.NameG TH.TcClsName (TH.PkgName (tyConPackage con)) (TH.ModName (tyConModule con)))+          --+          appsT x []      = x+          appsT x (y:xs)  = appsT (TH.AppT x y) xs+          --+      resultArgs <- mapM typeRepToType args+      return (appsT (TH.ConT name) resultArgs)++    -- TODO: make sure that the resulting array is 16-byte aligned...+    arr :: forall a. (ArrayElt a, Storable a) => UniqueArray a -> Q (TExp (UniqueArray a))+    arr ua = do+      bytes <- TH.runIO $ peekArray (sizeOf (undefined::a) * sz) (castPtr (unsafeUniqueArrayPtr ua) :: Ptr Word8)+      [|| unsafePerformIO $ do+           fp  <- newForeignPtr_ $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |] )+           ua' <- newUniqueArray (castForeignPtr fp)+           return ua'+       ||]++    go :: ArrayEltR e' -> ArrayData e' -> Q (TExp (ArrayData e'))+    go ArrayEltRunit         AD_Unit         = [|| AD_Unit ||]+    go ArrayEltRint          (AD_Int ua)     = [|| AD_Int $$(arr ua) ||]+    go ArrayEltRint8         (AD_Int8 ua)    = [|| AD_Int8 $$(arr ua) ||]+    go ArrayEltRint16        (AD_Int16 ua)   = [|| AD_Int16 $$(arr ua) ||]+    go ArrayEltRint32        (AD_Int32 ua)   = [|| AD_Int32 $$(arr ua) ||]+    go ArrayEltRint64        (AD_Int64 ua)   = [|| AD_Int64 $$(arr ua) ||]+    go ArrayEltRword         (AD_Word ua)    = [|| AD_Word $$(arr ua) ||]+    go ArrayEltRword8        (AD_Word8 ua)   = [|| AD_Word8 $$(arr ua) ||]+    go ArrayEltRword16       (AD_Word16 ua)  = [|| AD_Word16 $$(arr ua) ||]+    go ArrayEltRword32       (AD_Word32 ua)  = [|| AD_Word32 $$(arr ua) ||]+    go ArrayEltRword64       (AD_Word64 ua)  = [|| AD_Word64 $$(arr ua) ||]+    go ArrayEltRcshort       (AD_CShort ua)  = [|| AD_CShort $$(arr ua) ||]+    go ArrayEltRcushort      (AD_CUShort ua) = [|| AD_CUShort $$(arr ua) ||]+    go ArrayEltRcint         (AD_CInt ua)    = [|| AD_CInt $$(arr ua) ||]+    go ArrayEltRcuint        (AD_CUInt ua)   = [|| AD_CUInt $$(arr ua) ||]+    go ArrayEltRclong        (AD_CLong ua)   = [|| AD_CLong $$(arr ua) ||]+    go ArrayEltRculong       (AD_CULong ua)  = [|| AD_CULong $$(arr ua) ||]+    go ArrayEltRcllong       (AD_CLLong ua)  = [|| AD_CLLong $$(arr ua) ||]+    go ArrayEltRcullong      (AD_CULLong ua) = [|| AD_CULLong $$(arr ua) ||]+    go ArrayEltRhalf         (AD_Half ua)    = [|| AD_Half $$(arr ua) ||]+    go ArrayEltRfloat        (AD_Float ua)   = [|| AD_Float $$(arr ua) ||]+    go ArrayEltRdouble       (AD_Double ua)  = [|| AD_Double $$(arr ua) ||]+    go ArrayEltRcfloat       (AD_CFloat ua)  = [|| AD_CFloat $$(arr ua) ||]+    go ArrayEltRcdouble      (AD_CDouble ua) = [|| AD_CDouble $$(arr ua) ||]+    go ArrayEltRbool         (AD_Bool ua)    = [|| AD_Bool $$(arr ua) ||]+    go ArrayEltRchar         (AD_Char ua)    = [|| AD_Char $$(arr ua) ||]+    go ArrayEltRcchar        (AD_CChar ua)   = [|| AD_CChar $$(arr ua) ||]+    go ArrayEltRcschar       (AD_CSChar ua)  = [|| AD_CSChar $$(arr ua) ||]+    go ArrayEltRcuchar       (AD_CUChar ua)  = [|| AD_CUChar $$(arr ua) ||]+    go (ArrayEltRvec2 r)     (AD_V2 a)       = [|| AD_V2 $$(go r a) ||]+    go (ArrayEltRvec3 r)     (AD_V3 a)       = [|| AD_V3 $$(go r a) ||]+    go (ArrayEltRvec4 r)     (AD_V4 a)       = [|| AD_V4 $$(go r a) ||]+    go (ArrayEltRvec8 r)     (AD_V8 a)       = [|| AD_V8 $$(go r a) ||]+    go (ArrayEltRvec16 r)    (AD_V16 a)      = [|| AD_V16 $$(go r a) ||]+    go (ArrayEltRpair r1 r2) (AD_Pair a1 a2) = [|| AD_Pair $$(go r1 a1) $$(go r2 a2) ||]+++liftBoundary+    :: forall acc aenv sh e.+       LiftAcc acc+    -> PreBoundary acc aenv (Array sh e)+    -> Q (TExp (PreBoundary acc aenv (Array sh e)))+liftBoundary _     Clamp        = [|| Clamp ||]+liftBoundary _     Mirror       = [|| Mirror ||]+liftBoundary _     Wrap         = [|| Wrap ||]+liftBoundary _     (Constant v) = [|| Constant $$(liftConst (eltType (undefined::e)) v) ||]+liftBoundary liftA (Function f) = [|| Function $$(liftPreOpenFun liftA f) ||]++liftSliceIndex :: SliceIndex ix slice coSlice sliceDim -> Q (TExp (SliceIndex ix slice coSlice sliceDim))+liftSliceIndex SliceNil          = [|| SliceNil ||]+liftSliceIndex (SliceAll rest)   = [|| SliceAll $$(liftSliceIndex rest) ||]+liftSliceIndex (SliceFixed rest) = [|| SliceFixed $$(liftSliceIndex rest) ||]++liftPrimConst :: PrimConst c -> Q (TExp (PrimConst c))+liftPrimConst (PrimMinBound t) = [|| PrimMinBound $$(liftBoundedType t) ||]+liftPrimConst (PrimMaxBound t) = [|| PrimMaxBound $$(liftBoundedType t) ||]+liftPrimConst (PrimPi t)       = [|| PrimPi $$(liftFloatingType t) ||]++liftPrimFun :: PrimFun f -> Q (TExp (PrimFun f))+liftPrimFun (PrimAdd t)                = [|| PrimAdd $$(liftNumType t) ||]+liftPrimFun (PrimSub t)                = [|| PrimSub $$(liftNumType t) ||]+liftPrimFun (PrimMul t)                = [|| PrimMul $$(liftNumType t) ||]+liftPrimFun (PrimNeg t)                = [|| PrimNeg $$(liftNumType t) ||]+liftPrimFun (PrimAbs t)                = [|| PrimAbs $$(liftNumType t) ||]+liftPrimFun (PrimSig t)                = [|| PrimSig $$(liftNumType t) ||]+liftPrimFun (PrimQuot t)               = [|| PrimQuot $$(liftIntegralType t) ||]+liftPrimFun (PrimRem t)                = [|| PrimRem $$(liftIntegralType t) ||]+liftPrimFun (PrimQuotRem t)            = [|| PrimQuotRem $$(liftIntegralType t) ||]+liftPrimFun (PrimIDiv t)               = [|| PrimIDiv $$(liftIntegralType t) ||]+liftPrimFun (PrimMod t)                = [|| PrimMod $$(liftIntegralType t) ||]+liftPrimFun (PrimDivMod t)             = [|| PrimDivMod $$(liftIntegralType t) ||]+liftPrimFun (PrimBAnd t)               = [|| PrimBAnd $$(liftIntegralType t) ||]+liftPrimFun (PrimBOr t)                = [|| PrimBOr $$(liftIntegralType t) ||]+liftPrimFun (PrimBXor t)               = [|| PrimBXor $$(liftIntegralType t) ||]+liftPrimFun (PrimBNot t)               = [|| PrimBNot $$(liftIntegralType t) ||]+liftPrimFun (PrimBShiftL t)            = [|| PrimBShiftL $$(liftIntegralType t) ||]+liftPrimFun (PrimBShiftR t)            = [|| PrimBShiftR $$(liftIntegralType t) ||]+liftPrimFun (PrimBRotateL t)           = [|| PrimBRotateL $$(liftIntegralType t) ||]+liftPrimFun (PrimBRotateR t)           = [|| PrimBRotateR $$(liftIntegralType t) ||]+liftPrimFun (PrimPopCount t)           = [|| PrimPopCount $$(liftIntegralType t) ||]+liftPrimFun (PrimCountLeadingZeros t)  = [|| PrimCountLeadingZeros $$(liftIntegralType t) ||]+liftPrimFun (PrimCountTrailingZeros t) = [|| PrimCountTrailingZeros $$(liftIntegralType t) ||]+liftPrimFun (PrimFDiv t)               = [|| PrimFDiv $$(liftFloatingType t) ||]+liftPrimFun (PrimRecip t)              = [|| PrimRecip $$(liftFloatingType t) ||]+liftPrimFun (PrimSin t)                = [|| PrimSin $$(liftFloatingType t) ||]+liftPrimFun (PrimCos t)                = [|| PrimCos $$(liftFloatingType t) ||]+liftPrimFun (PrimTan t)                = [|| PrimTan $$(liftFloatingType t) ||]+liftPrimFun (PrimAsin t)               = [|| PrimAsin $$(liftFloatingType t) ||]+liftPrimFun (PrimAcos t)               = [|| PrimAcos $$(liftFloatingType t) ||]+liftPrimFun (PrimAtan t)               = [|| PrimAtan $$(liftFloatingType t) ||]+liftPrimFun (PrimSinh t)               = [|| PrimSinh $$(liftFloatingType t) ||]+liftPrimFun (PrimCosh t)               = [|| PrimCosh $$(liftFloatingType t) ||]+liftPrimFun (PrimTanh t)               = [|| PrimTanh $$(liftFloatingType t) ||]+liftPrimFun (PrimAsinh t)              = [|| PrimAsinh $$(liftFloatingType t) ||]+liftPrimFun (PrimAcosh t)              = [|| PrimAcosh $$(liftFloatingType t) ||]+liftPrimFun (PrimAtanh t)              = [|| PrimAtanh $$(liftFloatingType t) ||]+liftPrimFun (PrimExpFloating t)        = [|| PrimExpFloating $$(liftFloatingType t) ||]+liftPrimFun (PrimSqrt t)               = [|| PrimSqrt $$(liftFloatingType t) ||]+liftPrimFun (PrimLog t)                = [|| PrimLog $$(liftFloatingType t) ||]+liftPrimFun (PrimFPow t)               = [|| PrimFPow $$(liftFloatingType t) ||]+liftPrimFun (PrimLogBase t)            = [|| PrimLogBase $$(liftFloatingType t) ||]+liftPrimFun (PrimTruncate ta tb)       = [|| PrimTruncate $$(liftFloatingType ta) $$(liftIntegralType tb) ||]+liftPrimFun (PrimRound ta tb)          = [|| PrimRound $$(liftFloatingType ta) $$(liftIntegralType tb) ||]+liftPrimFun (PrimFloor ta tb)          = [|| PrimFloor $$(liftFloatingType ta) $$(liftIntegralType tb) ||]+liftPrimFun (PrimCeiling ta tb)        = [|| PrimCeiling $$(liftFloatingType ta) $$(liftIntegralType tb) ||]+liftPrimFun (PrimIsNaN t)              = [|| PrimIsNaN $$(liftFloatingType t) ||]+liftPrimFun (PrimIsInfinite t)         = [|| PrimIsInfinite $$(liftFloatingType t) ||]+liftPrimFun (PrimAtan2 t)              = [|| PrimAtan2 $$(liftFloatingType t) ||]+liftPrimFun (PrimLt t)                 = [|| PrimLt $$(liftSingleType t) ||]+liftPrimFun (PrimGt t)                 = [|| PrimGt $$(liftSingleType t) ||]+liftPrimFun (PrimLtEq t)               = [|| PrimLtEq $$(liftSingleType t) ||]+liftPrimFun (PrimGtEq t)               = [|| PrimGtEq $$(liftSingleType t) ||]+liftPrimFun (PrimEq t)                 = [|| PrimEq $$(liftSingleType t) ||]+liftPrimFun (PrimNEq t)                = [|| PrimNEq $$(liftSingleType t) ||]+liftPrimFun (PrimMax t)                = [|| PrimMax $$(liftSingleType t) ||]+liftPrimFun (PrimMin t)                = [|| PrimMin $$(liftSingleType t) ||]+liftPrimFun PrimLAnd                   = [|| PrimLAnd ||]+liftPrimFun PrimLOr                    = [|| PrimLOr ||]+liftPrimFun PrimLNot                   = [|| PrimLNot ||]+liftPrimFun PrimOrd                    = [|| PrimOrd ||]+liftPrimFun PrimChr                    = [|| PrimChr ||]+liftPrimFun PrimBoolToInt              = [|| PrimBoolToInt ||]+liftPrimFun (PrimFromIntegral ta tb)   = [|| PrimFromIntegral $$(liftIntegralType ta) $$(liftNumType tb) ||]+liftPrimFun (PrimToFloating ta tb)     = [|| PrimToFloating $$(liftNumType ta) $$(liftFloatingType tb) ||]+++liftConst :: TupleType t -> t -> Q (TExp t)+liftConst TypeRunit         ()    = [|| () ||]+liftConst (TypeRscalar t)   x     = [|| $$(liftScalar t x) ||]+liftConst (TypeRpair ta tb) (a,b) = [|| ($$(liftConst ta a), $$(liftConst tb b)) ||]++liftScalar :: ScalarType t -> t -> Q (TExp t)+liftScalar (SingleScalarType t) x = liftSingle t x+liftScalar (VectorScalarType t) x = liftVector t x++liftSingle :: SingleType t -> t -> Q (TExp t)+liftSingle (NumSingleType t)    x = liftNum t x+liftSingle (NonNumSingleType t) x = liftNonNum t x++liftVector :: VectorType v -> v -> Q (TExp v)+liftVector (Vector2Type t) (V2 a b)     = [|| V2 $$(liftSingle t a) $$(liftSingle t b) ||]+liftVector (Vector3Type t) (V3 a b c)   = [|| V3 $$(liftSingle t a) $$(liftSingle t b) $$(liftSingle t c) ||]+liftVector (Vector4Type t) (V4 a b c d) = [|| V4 $$(liftSingle t a) $$(liftSingle t b) $$(liftSingle t c) $$(liftSingle t d) ||]+liftVector (Vector8Type t) (V8 a b c d e f g h) =+  [|| V8 $$(liftSingle t a) $$(liftSingle t b) $$(liftSingle t c) $$(liftSingle t d)+         $$(liftSingle t e) $$(liftSingle t f) $$(liftSingle t g) $$(liftSingle t h) ||]+liftVector (Vector16Type t) (V16 a b c d e f g h i j k l m n o p) =+  [|| V16 $$(liftSingle t a) $$(liftSingle t b) $$(liftSingle t c) $$(liftSingle t d)+          $$(liftSingle t e) $$(liftSingle t f) $$(liftSingle t g) $$(liftSingle t h)+          $$(liftSingle t i) $$(liftSingle t j) $$(liftSingle t k) $$(liftSingle t l)+          $$(liftSingle t m) $$(liftSingle t n) $$(liftSingle t o) $$(liftSingle t p) ||]++liftNum :: NumType t -> t -> Q (TExp t)+liftNum (IntegralNumType t) x = liftIntegral t x+liftNum (FloatingNumType t) x = liftFloating t x++liftNonNum :: NonNumType t -> t -> Q (TExp t)+liftNonNum TypeBool{}   x = [|| x ||]+liftNonNum TypeChar{}   x = [|| x ||]+liftNonNum TypeCChar{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+liftNonNum TypeCSChar{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+liftNonNum TypeCUChar{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))++liftIntegral :: IntegralType t -> t -> Q (TExp t)+liftIntegral TypeInt{}     x = [|| x ||]+liftIntegral TypeInt8{}    x = [|| x ||]+liftIntegral TypeInt16{}   x = [|| x ||]+liftIntegral TypeInt32{}   x = [|| x ||]+liftIntegral TypeInt64{}   x = [|| x ||]+#if __GLASGOW_HASKELL__ >= 710+liftIntegral TypeWord{}    x = [|| x ||]+#else+liftIntegral TypeWord{}    x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+#endif+liftIntegral TypeWord8{}   x = [|| x ||]+liftIntegral TypeWord16{}  x = [|| x ||]+liftIntegral TypeWord32{}  x = [|| x ||]+liftIntegral TypeWord64{}  x = [|| x ||]+liftIntegral TypeCShort{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+liftIntegral TypeCUShort{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+liftIntegral TypeCInt{}    x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+liftIntegral TypeCUInt{}   x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+liftIntegral TypeCLong{}   x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+liftIntegral TypeCULong{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+liftIntegral TypeCLLong{}  x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))+liftIntegral TypeCULLong{} x = return (TH.TExp (TH.LitE (TH.IntegerL (toInteger x))))++liftFloating :: FloatingType t -> t -> Q (TExp t)+liftFloating TypeHalf{}    x = [|| Half $$( liftIntegral integralType (getHalf x)) ||]+liftFloating TypeFloat{}   x = [|| x ||]+liftFloating TypeDouble{}  x = [|| x ||]+liftFloating TypeCFloat{}  x = return (TH.TExp (TH.LitE (TH.RationalL (toRational x))))+liftFloating TypeCDouble{} x = return (TH.TExp (TH.LitE (TH.RationalL (toRational x))))+++liftIntegralType :: IntegralType t -> Q (TExp (IntegralType t))+liftIntegralType TypeInt{}     = [|| TypeInt IntegralDict ||]+liftIntegralType TypeInt8{}    = [|| TypeInt8 IntegralDict ||]+liftIntegralType TypeInt16{}   = [|| TypeInt16 IntegralDict ||]+liftIntegralType TypeInt32{}   = [|| TypeInt32 IntegralDict ||]+liftIntegralType TypeInt64{}   = [|| TypeInt64 IntegralDict ||]+liftIntegralType TypeWord{}    = [|| TypeWord IntegralDict ||]+liftIntegralType TypeWord8{}   = [|| TypeWord8 IntegralDict ||]+liftIntegralType TypeWord16{}  = [|| TypeWord16 IntegralDict ||]+liftIntegralType TypeWord32{}  = [|| TypeWord32 IntegralDict ||]+liftIntegralType TypeWord64{}  = [|| TypeWord64 IntegralDict ||]+liftIntegralType TypeCShort{}  = [|| TypeCShort IntegralDict ||]+liftIntegralType TypeCUShort{} = [|| TypeCUShort IntegralDict ||]+liftIntegralType TypeCInt{}    = [|| TypeCInt IntegralDict ||]+liftIntegralType TypeCUInt{}   = [|| TypeCUInt IntegralDict ||]+liftIntegralType TypeCLong{}   = [|| TypeCLong IntegralDict ||]+liftIntegralType TypeCULong{}  = [|| TypeCULong IntegralDict ||]+liftIntegralType TypeCLLong{}  = [|| TypeCLLong IntegralDict ||]+liftIntegralType TypeCULLong{} = [|| TypeCULLong IntegralDict ||]++liftFloatingType :: FloatingType t -> Q (TExp (FloatingType t))+liftFloatingType TypeHalf{}    = [|| TypeHalf FloatingDict ||]+liftFloatingType TypeFloat{}   = [|| TypeFloat FloatingDict ||]+liftFloatingType TypeDouble{}  = [|| TypeDouble FloatingDict ||]+liftFloatingType TypeCFloat{}  = [|| TypeCFloat FloatingDict ||]+liftFloatingType TypeCDouble{} = [|| TypeCDouble FloatingDict ||]++liftNonNumType :: NonNumType t -> Q (TExp (NonNumType t))+liftNonNumType TypeBool{}   = [|| TypeBool NonNumDict ||]+liftNonNumType TypeChar{}   = [|| TypeChar NonNumDict ||]+liftNonNumType TypeCChar{}  = [|| TypeCChar NonNumDict ||]+liftNonNumType TypeCSChar{} = [|| TypeCSChar NonNumDict ||]+liftNonNumType TypeCUChar{} = [|| TypeCUChar NonNumDict ||]++liftNumType :: NumType t -> Q (TExp (NumType t))+liftNumType (IntegralNumType t) = [|| IntegralNumType $$(liftIntegralType t) ||]+liftNumType (FloatingNumType t) = [|| FloatingNumType $$(liftFloatingType t) ||]++liftBoundedType :: BoundedType t -> Q (TExp (BoundedType t))+liftBoundedType (IntegralBoundedType t) = [|| IntegralBoundedType $$(liftIntegralType t) ||]+liftBoundedType (NonNumBoundedType t)   = [|| NonNumBoundedType $$(liftNonNumType t) ||]++-- liftScalarType :: ScalarType t -> Q (TExp (ScalarType t))+-- liftScalarType (SingleScalarType t) = [|| SingleScalarType $$(liftSingleType t) ||]+-- liftScalarType (VectorScalarType t) = [|| VectorScalarType $$(liftVectorType t) ||]++liftSingleType :: SingleType t -> Q (TExp (SingleType t))+liftSingleType (NumSingleType t)    = [|| NumSingleType $$(liftNumType t) ||]+liftSingleType (NonNumSingleType t) = [|| NonNumSingleType $$(liftNonNumType t) ||]++-- liftVectorType :: VectorType t -> Q (TExp (VectorType t))+-- liftVectorType (Vector2Type t)  = [|| Vector2Type $$(liftSingleType t) ||]+-- liftVectorType (Vector3Type t)  = [|| Vector3Type $$(liftSingleType t) ||]+-- liftVectorType (Vector4Type t)  = [|| Vector4Type $$(liftSingleType t) ||]+-- liftVectorType (Vector8Type t)  = [|| Vector8Type $$(liftSingleType t) ||]+-- liftVectorType (Vector16Type t) = [|| Vector16Type $$(liftSingleType t) ||]+++-- Debugging+-- =========++showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String+showPreAccOp Alet{}             = "Alet"+showPreAccOp (Avar ix)          = "Avar a" ++ show (idxToInt ix)+showPreAccOp (Use a)            = "Use "  ++ showArrays (toArr a :: arrs)+showPreAccOp Apply{}            = "Apply"+showPreAccOp Aforeign{}         = "Aforeign"+showPreAccOp Acond{}            = "Acond"+showPreAccOp Awhile{}           = "Awhile"+showPreAccOp Atuple{}           = "Atuple"+showPreAccOp Aprj{}             = "Aprj"+showPreAccOp Unit{}             = "Unit"+showPreAccOp Generate{}         = "Generate"+showPreAccOp Transform{}        = "Transform"+showPreAccOp Reshape{}          = "Reshape"+showPreAccOp Replicate{}        = "Replicate"+showPreAccOp Slice{}            = "Slice"+showPreAccOp Map{}              = "Map"+showPreAccOp ZipWith{}          = "ZipWith"+showPreAccOp Fold{}             = "Fold"+showPreAccOp Fold1{}            = "Fold1"+showPreAccOp FoldSeg{}          = "FoldSeg"+showPreAccOp Fold1Seg{}         = "Fold1Seg"+showPreAccOp Scanl{}            = "Scanl"+showPreAccOp Scanl'{}           = "Scanl'"+showPreAccOp Scanl1{}           = "Scanl1"+showPreAccOp Scanr{}            = "Scanr"+showPreAccOp Scanr'{}           = "Scanr'"+showPreAccOp Scanr1{}           = "Scanr1"+showPreAccOp Permute{}          = "Permute"+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+  where+    collect :: ArraysR a -> a -> [String]+    collect ArraysRunit         _        = []+    collect ArraysRarray        arr      = [showShortendArr arr]+    collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2+    --+    display []  = []+    display [x] = x+    display xs  = "(" ++ intercalate ", " xs ++ ")"+++showShortendArr :: Elt e => Array sh e -> String+showShortendArr arr+  = show (take cutoff l) ++ if length l > cutoff then ".." else ""+  where+    l      = toList arr+    cutoff = 5+++showPreExpOp :: forall acc env aenv t. PreOpenExp acc env aenv t -> String+showPreExpOp Let{}              = "Let"+showPreExpOp (Var ix)           = "Var x" ++ show (idxToInt ix)+showPreExpOp (Const c)          = "Const " ++ show (toElt c :: t)+showPreExpOp Undef              = "Undef"+showPreExpOp Foreign{}          = "Foreign"+showPreExpOp Tuple{}            = "Tuple"+showPreExpOp Prj{}              = "Prj"+showPreExpOp IndexNil           = "IndexNil"+showPreExpOp IndexCons{}        = "IndexCons"+showPreExpOp IndexHead{}        = "IndexHead"+showPreExpOp IndexTail{}        = "IndexTail"+showPreExpOp IndexAny           = "IndexAny"+showPreExpOp IndexSlice{}       = "IndexSlice"+showPreExpOp IndexFull{}        = "IndexFull"+showPreExpOp ToIndex{}          = "ToIndex"+showPreExpOp FromIndex{}        = "FromIndex"+showPreExpOp Cond{}             = "Cond"+showPreExpOp While{}            = "While"+showPreExpOp PrimConst{}        = "PrimConst"+showPreExpOp PrimApp{}          = "PrimApp"+showPreExpOp Index{}            = "Index"+showPreExpOp LinearIndex{}      = "LinearIndex"+showPreExpOp Shape{}            = "Shape"+showPreExpOp ShapeSize{}        = "ShapeSize"+showPreExpOp Intersect{}        = "Intersect"+showPreExpOp Union{}            = "Union"+showPreExpOp Coerce{}           = "Coerce"+
+ src/Data/Array/Accelerate/Analysis/Hash.hs view
@@ -0,0 +1,553 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Analysis.Hash+-- Copyright   : [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.Hash (++  -- hashing expressions+  Hash,+  hashPreOpenAcc,+  hashPreOpenFun,+  hashPreOpenExp,++  -- auxiliary+  EncodeAcc,+  encodePreOpenAcc, encodeOpenAcc,+  encodePreOpenExp, encodeOpenExp,+  encodePreOpenFun,+  hashQ,++) where++import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Analysis.Hash.TH+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Array.Representation                   ( SliceIndex(..) )+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Type++import Crypto.Hash+import Data.Bits+import Data.ByteString.Builder+import Data.ByteString.Builder.Extra+import Data.Monoid+import Foreign.C.Types+import System.IO.Unsafe                                             ( unsafePerformIO )+import System.Mem.StableName                                        ( hashStableName, makeStableName )+import Prelude                                                      hiding ( exp )+++-- Hashing+-- -------++type Hash = Digest SHA3_256++hashPreOpenAcc :: EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash+hashPreOpenAcc encodeAcc = hashlazy . toLazyByteString . encodePreOpenAcc encodeAcc++hashPreOpenFun :: EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash+hashPreOpenFun encodeAcc = hashlazy . toLazyByteString . encodePreOpenFun encodeAcc++hashPreOpenExp :: EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash+hashPreOpenExp encodeAcc = hashlazy . toLazyByteString . encodePreOpenExp encodeAcc+++-- Array computations+-- ------------------++type EncodeAcc acc = forall aenv a. acc aenv a -> Builder++{-# INLINE encodeOpenAcc #-}+encodeOpenAcc :: OpenAcc aenv arrs -> Builder+encodeOpenAcc (OpenAcc pacc) = encodePreOpenAcc encodeOpenAcc pacc++{-# INLINE encodePreOpenAcc #-}+encodePreOpenAcc+    :: forall acc aenv arrs.+       EncodeAcc acc+    -> PreOpenAcc acc aenv arrs+    -> Builder+encodePreOpenAcc encodeAcc pacc =+  let+      {-# INLINE travA #-}+      travA :: forall aenv' a. Arrays a => acc aenv' a -> Builder+      travA a = encodeArraysType (arrays (undefined::a)) <> encodeAcc a++      {-# INLINE travE #-}+      travE :: PreOpenExp acc env' aenv' e -> Builder+      travE = encodePreOpenExp encodeAcc++      {-# INLINE travF #-}+      travF :: PreOpenFun acc env' aenv' f -> Builder+      travF = encodePreOpenFun encodeAcc++      {-# INLINE travB #-}+      travB :: PreBoundary acc aenv' (Array sh e) -> Builder+      travB = encodePreBoundary encodeAcc++      {-# INLINE nacl #-}+      nacl :: Arrays arrs => Builder+      nacl = encodeArraysType (arrays (undefined::arrs))+  in+  case pacc of+    Alet bnd body               -> intHost $(hashQ "Alet")        <> travA bnd <> travA body+    Avar v                      -> intHost $(hashQ "Avar")        <> nacl <> encodeIdx v+    Atuple t                    -> intHost $(hashQ "Atuple")      <> nacl <> encodeAtuple encodeAcc t+    Aprj ix a                   -> intHost $(hashQ "Aprj")        <> nacl <> encodeTupleIdx ix <> travA a+    Apply f a                   -> intHost $(hashQ "Apply")       <> nacl <> encodePreOpenAfun encodeAcc f <> travA a+    Aforeign _ f a              -> intHost $(hashQ "Aforeign")    <> nacl <> encodePreOpenAfun encodeAcc f <> travA a+    Use a                       -> intHost $(hashQ "Use")         <> encodeArrays (arrays (undefined::arrs)) a+    Awhile p f a                -> intHost $(hashQ "Awhile")      <> encodePreOpenAfun encodeAcc f <> encodePreOpenAfun encodeAcc p <> travA a+    Unit e                      -> intHost $(hashQ "Unit")        <> travE e+    Generate e f                -> intHost $(hashQ "Generate")    <> travE e  <> travF f+    Acond e a1 a2               -> intHost $(hashQ "Acond")       <> travE e  <> travA a1 <> travA a2+    Reshape sh a                -> intHost $(hashQ "Reshape")     <> travE sh <> travA a+    Transform sh f1 f2 a        -> intHost $(hashQ "Transform")   <> travE sh <> travF f1 <> travF f2 <> travA a+    Replicate spec ix a         -> intHost $(hashQ "Replicate")   <> travE ix <> travA a  <> encodeSliceIndex spec+    Slice spec a ix             -> intHost $(hashQ "Slice")       <> travE ix <> travA a  <> encodeSliceIndex spec+    Map f a                     -> intHost $(hashQ "Map")         <> travF f  <> travA a+    ZipWith f a1 a2             -> intHost $(hashQ "ZipWith")     <> travF f  <> travA a1 <> travA a2+    Fold f e a                  -> intHost $(hashQ "Fold")        <> travF f  <> travE e  <> travA a+    Fold1 f a                   -> intHost $(hashQ "Fold1")       <> travF f  <> travA a+    FoldSeg f e a s             -> intHost $(hashQ "FoldSeg")     <> travF f  <> travE e  <> travA a  <> travA s+    Fold1Seg f a s              -> intHost $(hashQ "Fold1Seg")    <> travF f  <> travA a  <> travA s+    Scanl f e a                 -> intHost $(hashQ "Scanl")       <> travF f  <> travE e  <> travA a+    Scanl' f e a                -> intHost $(hashQ "Scanl'")      <> travF f  <> travE e  <> travA a+    Scanl1 f a                  -> intHost $(hashQ "Scanl1")      <> travF f  <> travA a+    Scanr f e a                 -> intHost $(hashQ "Scanr")       <> travF f  <> travE e  <> travA a+    Scanr' f e a                -> intHost $(hashQ "Scanr'")      <> travF f  <> travE e  <> travA a+    Scanr1 f a                  -> intHost $(hashQ "Scanr1")      <> travF f  <> travA a+    Backpermute sh f a          -> intHost $(hashQ "Backpermute") <> travF f  <> travE sh <> travA a+    Permute f1 a1 f2 a2         -> intHost $(hashQ "Permute")     <> travF f1 <> travA a1 <> travF f2 <> travA a2+    Stencil f b a               -> intHost $(hashQ "Stencil")     <> travF f  <> travB b  <> travA a+    Stencil2 f b1 a1 b2 a2      -> intHost $(hashQ "Stencil2")    <> travF f  <> travB b1 <> travA a1 <> travB b2 <> travA a2++{--+encodePreOpenSeq :: forall acc aenv senv arrs. EncodeAcc acc -> PreOpenSeq acc aenv senv arrs -> Int+encodePreOpenSeq encodeAcc s =+  let+      travA :: acc aenv' a -> Builder+      travA = encodeAcc -- XXX: plus type information?++      travE :: PreOpenExp acc env' aenv' e -> Builder+      travE = encodePreOpenExp encodeAcc++      travAF :: PreOpenAfun acc aenv' f -> Builder+      travAF = encodePreOpenAfun encodeAcc++      travF :: PreOpenFun acc env' aenv' f -> Builder+      travF = encodePreOpenFun encodeAcc++      travS :: PreOpenSeq acc aenv senv' arrs' -> Builder+      travS = encodePreOpenSeq encodeAcc++      travV :: forall a. Arrays a => Idx senv' a -> Builder+      travV v = encodeArraysType (arrays (undefined::a)) <> encodeIdx v++      travP :: Producer acc aenv senv a -> Builder+      travP p =+        case p of+          StreamIn arrs       -> intHost . unsafePerformIO $! hashStableName `fmap` makeStableName arrs+          ToSeq spec _ acc    -> intHost $(hashQ "ToSeq")         <> travA  acc <> stringUtf8 (show spec)+          MapSeq f x          -> intHost $(hashQ "MapSeq")        <> travAF f   <> travV x+          ChunkedMapSeq f x   -> intHost $(hashQ "ChunkedMapSeq") <> travAF f   <> travV x+          ZipWithSeq f x y    -> intHost $(hashQ "ZipWithSeq")    <> travAF f   <> travV x <> travV y+          ScanSeq f e x       -> intHost $(hashQ "ScanSeq")       <> travF  f   <> travE e <> travV x++      travC :: Consumer acc aenv senv' a -> Builder+      travC c =+        case c of+          FoldSeq f e x          -> intHost $(hashQ "FoldSeq")        <> travF  f <> travE e   <> travV x+          FoldSeqFlatten f acc x -> intHost $(hashQ "FoldSeqFlatten") <> travAF f <> travA acc <> travV x+          Stuple t               -> intHost $(hashQ "Stuple")         <> encodeAtuple travC t+  in+  case s of+    Producer p s' -> intHost $(hashQ "Producer")   <> travP p <> travS s'+    Consumer c    -> intHost $(hashQ "Consumer")   <> travC c+    Reify ix      -> intHost $(hashQ "Reify")      <> travV ix+--}++{-# INLINE encodeIdx #-}+encodeIdx :: Idx env t -> Builder+encodeIdx = intHost . idxToInt++{-# INLINE encodeTupleIdx #-}+encodeTupleIdx :: TupleIdx tup e -> Builder+encodeTupleIdx = intHost . tupleIdxToInt++{-# INLINE encodeArrays #-}+encodeArrays :: ArraysR a -> a -> Builder+encodeArrays ArraysRunit         ()       = mempty+encodeArrays (ArraysRpair r1 r2) (a1, a2) = encodeArrays r1 a1 <> encodeArrays r2 a2+encodeArrays ArraysRarray        ad       = intHost . unsafePerformIO $! hashStableName `fmap` makeStableName ad++{-# INLINE encodeArraysType #-}+encodeArraysType :: forall a. ArraysR a -> Builder+encodeArraysType ArraysRunit         = intHost $(hashQ "ArraysRunit")+encodeArraysType (ArraysRpair r1 r2) = intHost $(hashQ "ArraysRpair")  <> encodeArraysType r1 <> encodeArraysType r2+encodeArraysType ArraysRarray        = intHost $(hashQ "ArraysRarray") <> encodeArrayType (undefined::a)+  where+    {-# INLINE encodeArrayType #-}+    encodeArrayType :: forall sh e. (Shape sh, Elt e) => Array sh e -> Builder+    encodeArrayType _ = encodeTupleType (eltType (undefined::sh)) <> encodeTupleType (eltType (undefined::e))++{-# INLINE encodeAtuple #-}+encodeAtuple :: EncodeAcc acc -> Atuple (acc aenv) a -> Builder+encodeAtuple _     NilAtup        = intHost $(hashQ "NilAtup")+encodeAtuple travA (SnocAtup t a) = intHost $(hashQ "SnocAtup") <> encodeAtuple travA t <> travA a++{-# INLINE encodePreOpenAfun #-}+encodePreOpenAfun :: forall acc aenv f. EncodeAcc acc -> PreOpenAfun acc aenv f -> Builder+encodePreOpenAfun travA afun =+  let+      {-# INLINE travB #-}+      travB :: forall aenv' a. Arrays a => acc aenv' a -> Builder+      travB b = encodeArraysType (arrays (undefined::a)) <> travA b++      {-# INLINE travL #-}+      travL :: forall aenv' a b. Arrays a => PreOpenAfun acc (aenv',a) b -> Builder+      travL l = encodeArraysType (arrays (undefined::a)) <> encodePreOpenAfun travA l+  in+  case afun of+    Abody b -> intHost $(hashQ "Abody") <> travB b+    Alam  l -> intHost $(hashQ "Alam")  <> travL l+++{-# INLINE encodePreBoundary #-}+encodePreBoundary :: forall acc aenv sh e. EncodeAcc acc -> PreBoundary acc aenv (Array sh e) -> Builder+encodePreBoundary _ Wrap          = intHost $(hashQ "Wrap")+encodePreBoundary _ Clamp         = intHost $(hashQ "Clamp")+encodePreBoundary _ Mirror        = intHost $(hashQ "Mirror")+encodePreBoundary _ (Constant c)  = intHost $(hashQ "Constant") <> encodeConst (eltType (undefined::e)) c+encodePreBoundary h (Function f)  = intHost $(hashQ "Function") <> encodePreOpenFun h f++{-# INLINE encodeSliceIndex #-}+encodeSliceIndex :: SliceIndex slix sl co sh -> Builder+encodeSliceIndex SliceNil         = intHost $(hashQ "SliceNil")+encodeSliceIndex (SliceAll r)     = intHost $(hashQ "SliceAll")   <> encodeSliceIndex r+encodeSliceIndex (SliceFixed r)   = intHost $(hashQ "sliceFixed") <> encodeSliceIndex r+++-- Scalar expressions+-- ------------------++{-# INLINE encodeOpenExp #-}+encodeOpenExp :: OpenExp env aenv exp -> Builder+encodeOpenExp = encodePreOpenExp encodeOpenAcc++{-# INLINE encodePreOpenExp #-}+encodePreOpenExp :: forall acc env aenv exp. EncodeAcc acc -> PreOpenExp acc env aenv exp -> Builder+encodePreOpenExp travA exp =+  let+      {-# INLINE travE #-}+      travE :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder+      travE e =  encodeTupleType (eltType (undefined::e)) <> encodePreOpenExp travA e++      {-# INLINE travF #-}+      travF :: PreOpenFun acc env' aenv' f -> Builder+      travF = encodePreOpenFun travA++      {-# INLINE nacl #-}+      nacl :: Elt exp => Builder+      nacl = encodeTupleType (eltType (undefined::exp))+  in+  case exp of+    Let bnd body                -> intHost $(hashQ "Let")         <> travE bnd <> travE body+    Var ix                      -> intHost $(hashQ "Var")         <> nacl <> encodeIdx ix+    Tuple t                     -> intHost $(hashQ "Tuple")       <> nacl <> encodeTuple travA t+    Prj i e                     -> intHost $(hashQ "Prj")         <> nacl <> encodeTupleIdx i <> travE e -- XXX: here multiplied nacl by hashTupleIdx+    Const c                     -> intHost $(hashQ "Const")       <> encodeConst (eltType (undefined::exp)) c+    Undef                       -> intHost $(hashQ "Undef")+    IndexAny                    -> intHost $(hashQ "IndexAny")    <> nacl+    IndexNil                    -> intHost $(hashQ "IndexNil")+    IndexCons sh sz             -> intHost $(hashQ "IndexCons")   <> travE sh <> travE sz+    IndexHead sl                -> intHost $(hashQ "IndexHead")   <> travE sl+    IndexTail sl                -> intHost $(hashQ "IndexTail")   <> travE sl+    IndexSlice spec ix sh       -> intHost $(hashQ "IndexSlice")  <> travE ix <> travE sh <> encodeSliceIndex spec+    IndexFull  spec ix sl       -> intHost $(hashQ "IndexFull")   <> travE ix <> travE sl <> encodeSliceIndex spec+    ToIndex sh i                -> intHost $(hashQ "ToIndex")     <> travE sh <> travE i+    FromIndex sh i              -> intHost $(hashQ "FromIndex")   <> travE sh <> travE i+    Cond c t e                  -> intHost $(hashQ "Cond")        <> travE c  <> travE t  <> travE e+    While p f x                 -> intHost $(hashQ "While")       <> travF p  <> travF f  <> travE x+    PrimApp f x                 -> intHost $(hashQ "PrimApp")     <> encodePrimFun f <> travE x+    PrimConst c                 -> intHost $(hashQ "PrimConst")   <> encodePrimConst c+    Index a ix                  -> intHost $(hashQ "Index")       <> travA a  <> travE ix+    LinearIndex a ix            -> intHost $(hashQ "LinearIndex") <> travA a  <> travE ix+    Shape a                     -> intHost $(hashQ "Shape")       <> travA a+    ShapeSize sh                -> intHost $(hashQ "ShapeSize")   <> travE sh+    Intersect sa sb             -> intHost $(hashQ "Intersect")   <> travE sa <> travE sb+    Union sa sb                 -> intHost $(hashQ "Union")       <> travE sa <> travE sb+    Foreign _ f e               -> intHost $(hashQ "Foreign")     <> travF f  <> travE e+    Coerce e                    -> intHost $(hashQ "Coerce")      <> travE e+++{-# INLINE encodePreOpenFun #-}+encodePreOpenFun :: forall acc env aenv f. EncodeAcc acc -> PreOpenFun acc env aenv f -> Builder+encodePreOpenFun travA fun =+  let+      travB :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder+      travB b = encodeTupleType (eltType (undefined::e)) <> encodePreOpenExp travA b++      travL :: forall env' aenv' a b. Elt a => PreOpenFun acc (env',a) aenv' b -> Builder+      travL l = encodeTupleType (eltType (undefined::a)) <> encodePreOpenFun travA l+  in+  case fun of+    Body b -> intHost $(hashQ "Body") <> travB b+    Lam l  -> intHost $(hashQ "Lam")  <> travL l++{-# INLINE encodeTuple #-}+encodeTuple :: EncodeAcc acc -> Tuple (PreOpenExp acc env aenv) e -> Builder+encodeTuple _ NilTup        = intHost $(hashQ "NilTup")+encodeTuple h (SnocTup t e) = intHost $(hashQ "SnocTup") <> encodeTuple h t <> encodePreOpenExp h e+++{-# INLINE encodeConst #-}+encodeConst :: TupleType t -> t -> Builder+encodeConst TypeRunit         ()    = mempty+encodeConst (TypeRscalar t)   c     = encodeScalarConst t c+encodeConst (TypeRpair ta tb) (a,b) = encodeConst ta a <> encodeConst tb b++{-# INLINE encodeScalarConst #-}+encodeScalarConst :: ScalarType t -> t -> Builder+encodeScalarConst (SingleScalarType t) = encodeSingleConst t+encodeScalarConst (VectorScalarType t) = encodeVectorConst t++{-# INLINE encodeSingleConst #-}+encodeSingleConst :: SingleType t -> t -> Builder+encodeSingleConst (NumSingleType t)    = encodeNumConst t+encodeSingleConst (NonNumSingleType t) = encodeNonNumConst t++{-# INLINE encodeVectorConst #-}+encodeVectorConst :: VectorType t -> t -> Builder+encodeVectorConst (Vector2Type t) (V2 a b)     = intHost $(hashQ "V2") <> encodeSingleConst t a <> encodeSingleConst t b+encodeVectorConst (Vector3Type t) (V3 a b c)   = intHost $(hashQ "V3") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c+encodeVectorConst (Vector4Type t) (V4 a b c d) = intHost $(hashQ "V4") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c <> encodeSingleConst t d+encodeVectorConst (Vector8Type t) (V8 a b c d e f g h) =+  intHost $(hashQ "V8") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c <> encodeSingleConst t d+                        <> encodeSingleConst t e <> encodeSingleConst t f <> encodeSingleConst t g <> encodeSingleConst t h+encodeVectorConst (Vector16Type t) (V16 a b c d e f g h i j k l m n o p) =+  intHost $(hashQ "V16") <> encodeSingleConst t a <> encodeSingleConst t b <> encodeSingleConst t c <> encodeSingleConst t d+                         <> encodeSingleConst t e <> encodeSingleConst t f <> encodeSingleConst t g <> encodeSingleConst t h+                         <> encodeSingleConst t i <> encodeSingleConst t j <> encodeSingleConst t k <> encodeSingleConst t l+                         <> encodeSingleConst t m <> encodeSingleConst t n <> encodeSingleConst t o <> encodeSingleConst t p++{-# INLINE encodeNonNumConst #-}+encodeNonNumConst :: NonNumType t -> t -> Builder+encodeNonNumConst TypeBool{}   x          = intHost $(hashQ "Bool")   <> word8 (fromBool x)+encodeNonNumConst TypeChar{}   x          = intHost $(hashQ "Char")   <> charUtf8 x+encodeNonNumConst TypeCSChar{} (CSChar x) = intHost $(hashQ "CSChar") <> int8 x+encodeNonNumConst TypeCUChar{} (CUChar x) = intHost $(hashQ "CUChar") <> word8 x+encodeNonNumConst TypeCChar{}  (CChar  x) = intHost $(hashQ "CChar")  <> $( case isSigned (undefined::CChar) of+                                                                              True  -> [e| int8  |]+                                                                              False -> [e| word8 |] ) x++{-# INLINE fromBool #-}+fromBool :: Bool -> Word8+fromBool True  = 1+fromBool False = 0++{-# INLINE encodeNumConst #-}+encodeNumConst :: NumType t -> t -> Builder+encodeNumConst (IntegralNumType t) = encodeIntegralConst t+encodeNumConst (FloatingNumType t) = encodeFloatingConst t++{-# INLINE encodeIntegralConst #-}+encodeIntegralConst :: IntegralType t -> t -> Builder+encodeIntegralConst TypeInt{}     x           = intHost $(hashQ "Int")     <> intHost x+encodeIntegralConst TypeInt8{}    x           = intHost $(hashQ "Int8")    <> int8 x+encodeIntegralConst TypeInt16{}   x           = intHost $(hashQ "Int16")   <> int16Host x+encodeIntegralConst TypeInt32{}   x           = intHost $(hashQ "Int32")   <> int32Host x+encodeIntegralConst TypeInt64{}   x           = intHost $(hashQ "Int64")   <> int64Host x+encodeIntegralConst TypeWord{}    x           = intHost $(hashQ "Word")    <> wordHost x+encodeIntegralConst TypeWord8{}   x           = intHost $(hashQ "Word8")   <> word8 x+encodeIntegralConst TypeWord16{}  x           = intHost $(hashQ "Word16")  <> word16Host x+encodeIntegralConst TypeWord32{}  x           = intHost $(hashQ "Word32")  <> word32Host x+encodeIntegralConst TypeWord64{}  x           = intHost $(hashQ "Word64")  <> word64Host x+encodeIntegralConst TypeCShort{}  (CShort x)  = intHost $(hashQ "CShort")  <> int16Host x+encodeIntegralConst TypeCUShort{} (CUShort x) = intHost $(hashQ "CUShort") <> word16Host x+encodeIntegralConst TypeCInt{}    (CInt x)    = intHost $(hashQ "CInt")    <> int32Host x+encodeIntegralConst TypeCUInt{}   (CUInt x)   = intHost $(hashQ "CUInt")   <> word32Host x+encodeIntegralConst TypeCLLong{}  (CLLong x)  = intHost $(hashQ "CLLong")  <> int64Host x+encodeIntegralConst TypeCULLong{} (CULLong x) = intHost $(hashQ "CULLong") <> word64Host x+encodeIntegralConst TypeCLong{}   (CLong x)   = intHost $(hashQ "CLong")   <> $( case finiteBitSize (undefined::CLong) of+                                                                                   32 -> [e| int32Host |]+                                                                                   64 -> [e| int64Host |]+                                                                                   _  -> error "I don't know what architecture I am" ) x+encodeIntegralConst TypeCULong{}  (CULong x)  = intHost $(hashQ "CULong")  <> $( case finiteBitSize (undefined::CULong) of+                                                                                   32 -> [e| word32Host |]+                                                                                   64 -> [e| word64Host |]+                                                                                   _  -> error "I don't know what architecture I am" ) x++{-# INLINE encodeFloatingConst #-}+encodeFloatingConst :: FloatingType t -> t -> Builder+encodeFloatingConst TypeHalf{}    (Half (CUShort x)) = intHost $(hashQ "Half")    <> word16Host x+encodeFloatingConst TypeFloat{}   x                  = intHost $(hashQ "Float")   <> floatHost x+encodeFloatingConst TypeDouble{}  x                  = intHost $(hashQ "Double")  <> doubleHost x+encodeFloatingConst TypeCFloat{}  (CFloat x)         = intHost $(hashQ "CFloat")  <> floatHost x+encodeFloatingConst TypeCDouble{} (CDouble x)        = intHost $(hashQ "CDouble") <> doubleHost x++{-# INLINE encodePrimConst #-}+encodePrimConst :: PrimConst c -> Builder+encodePrimConst (PrimMinBound t)  = intHost $(hashQ "PrimMinBound") <> encodeBoundedType t+encodePrimConst (PrimMaxBound t)  = intHost $(hashQ "PrimMaxBound") <> encodeBoundedType t+encodePrimConst (PrimPi t)        = intHost $(hashQ "PrimPi")       <> encodeFloatingType t++{-# INLINE encodePrimFun #-}+encodePrimFun :: PrimFun f -> Builder+encodePrimFun (PrimAdd a)                = intHost $(hashQ "PrimAdd")                <> encodeNumType a+encodePrimFun (PrimSub a)                = intHost $(hashQ "PrimSub")                <> encodeNumType a+encodePrimFun (PrimMul a)                = intHost $(hashQ "PrimMul")                <> encodeNumType a+encodePrimFun (PrimNeg a)                = intHost $(hashQ "PrimNeg")                <> encodeNumType a+encodePrimFun (PrimAbs a)                = intHost $(hashQ "PrimAbs")                <> encodeNumType a+encodePrimFun (PrimSig a)                = intHost $(hashQ "PrimSig")                <> encodeNumType a+encodePrimFun (PrimQuot a)               = intHost $(hashQ "PrimQuot")               <> encodeIntegralType a+encodePrimFun (PrimRem a)                = intHost $(hashQ "PrimRem")                <> encodeIntegralType a+encodePrimFun (PrimQuotRem a)            = intHost $(hashQ "PrimQuotRem")            <> encodeIntegralType a+encodePrimFun (PrimIDiv a)               = intHost $(hashQ "PrimIDiv")               <> encodeIntegralType a+encodePrimFun (PrimMod a)                = intHost $(hashQ "PrimMod")                <> encodeIntegralType a+encodePrimFun (PrimDivMod a)             = intHost $(hashQ "PrimDivMod")             <> encodeIntegralType a+encodePrimFun (PrimBAnd a)               = intHost $(hashQ "PrimBAnd")               <> encodeIntegralType a+encodePrimFun (PrimBOr a)                = intHost $(hashQ "PrimBOr")                <> encodeIntegralType a+encodePrimFun (PrimBXor a)               = intHost $(hashQ "PrimBXor")               <> encodeIntegralType a+encodePrimFun (PrimBNot a)               = intHost $(hashQ "PrimBNot")               <> encodeIntegralType a+encodePrimFun (PrimBShiftL a)            = intHost $(hashQ "PrimBShiftL")            <> encodeIntegralType a+encodePrimFun (PrimBShiftR a)            = intHost $(hashQ "PrimBShiftR")            <> encodeIntegralType a+encodePrimFun (PrimBRotateL a)           = intHost $(hashQ "PrimBRotateL")           <> encodeIntegralType a+encodePrimFun (PrimBRotateR a)           = intHost $(hashQ "PrimBRotateR")           <> encodeIntegralType a+encodePrimFun (PrimPopCount a)           = intHost $(hashQ "PrimPopCount")           <> encodeIntegralType a+encodePrimFun (PrimCountLeadingZeros a)  = intHost $(hashQ "PrimCountLeadingZeros")  <> encodeIntegralType a+encodePrimFun (PrimCountTrailingZeros a) = intHost $(hashQ "PrimCountTrailingZeros") <> encodeIntegralType a+encodePrimFun (PrimFDiv a)               = intHost $(hashQ "PrimFDiv")               <> encodeFloatingType a+encodePrimFun (PrimRecip a)              = intHost $(hashQ "PrimRecip")              <> encodeFloatingType a+encodePrimFun (PrimSin a)                = intHost $(hashQ "PrimSin")                <> encodeFloatingType a+encodePrimFun (PrimCos a)                = intHost $(hashQ "PrimCos")                <> encodeFloatingType a+encodePrimFun (PrimTan a)                = intHost $(hashQ "PrimTan")                <> encodeFloatingType a+encodePrimFun (PrimAsin a)               = intHost $(hashQ "PrimAsin")               <> encodeFloatingType a+encodePrimFun (PrimAcos a)               = intHost $(hashQ "PrimAcos")               <> encodeFloatingType a+encodePrimFun (PrimAtan a)               = intHost $(hashQ "PrimAtan")               <> encodeFloatingType a+encodePrimFun (PrimSinh a)               = intHost $(hashQ "PrimSinh")               <> encodeFloatingType a+encodePrimFun (PrimCosh a)               = intHost $(hashQ "PrimCosh")               <> encodeFloatingType a+encodePrimFun (PrimTanh a)               = intHost $(hashQ "PrimTanh")               <> encodeFloatingType a+encodePrimFun (PrimAsinh a)              = intHost $(hashQ "PrimAsinh")              <> encodeFloatingType a+encodePrimFun (PrimAcosh a)              = intHost $(hashQ "PrimAcosh")              <> encodeFloatingType a+encodePrimFun (PrimAtanh a)              = intHost $(hashQ "PrimAtanh")              <> encodeFloatingType a+encodePrimFun (PrimExpFloating a)        = intHost $(hashQ "PrimExpFloating")        <> encodeFloatingType a+encodePrimFun (PrimSqrt a)               = intHost $(hashQ "PrimSqrt")               <> encodeFloatingType a+encodePrimFun (PrimLog a)                = intHost $(hashQ "PrimLog")                <> encodeFloatingType a+encodePrimFun (PrimFPow a)               = intHost $(hashQ "PrimFPow")               <> encodeFloatingType a+encodePrimFun (PrimLogBase a)            = intHost $(hashQ "PrimLogBase")            <> encodeFloatingType a+encodePrimFun (PrimAtan2 a)              = intHost $(hashQ "PrimAtan2")              <> encodeFloatingType a+encodePrimFun (PrimTruncate a b)         = intHost $(hashQ "PrimTruncate")           <> encodeFloatingType a <> encodeIntegralType b+encodePrimFun (PrimRound a b)            = intHost $(hashQ "PrimRound")              <> encodeFloatingType a <> encodeIntegralType b+encodePrimFun (PrimFloor a b)            = intHost $(hashQ "PrimFloor")              <> encodeFloatingType a <> encodeIntegralType b+encodePrimFun (PrimCeiling a b)          = intHost $(hashQ "PrimCeiling")            <> encodeFloatingType a <> encodeIntegralType b+encodePrimFun (PrimIsNaN a)              = intHost $(hashQ "PrimIsNaN")              <> encodeFloatingType a+encodePrimFun (PrimIsInfinite a)         = intHost $(hashQ "PrimIsInfinite")         <> encodeFloatingType a+encodePrimFun (PrimLt a)                 = intHost $(hashQ "PrimLt")                 <> encodeSingleType a+encodePrimFun (PrimGt a)                 = intHost $(hashQ "PrimGt")                 <> encodeSingleType a+encodePrimFun (PrimLtEq a)               = intHost $(hashQ "PrimLtEq")               <> encodeSingleType a+encodePrimFun (PrimGtEq a)               = intHost $(hashQ "PrimGtEq")               <> encodeSingleType a+encodePrimFun (PrimEq a)                 = intHost $(hashQ "PrimEq")                 <> encodeSingleType a+encodePrimFun (PrimNEq a)                = intHost $(hashQ "PrimNEq")                <> encodeSingleType a+encodePrimFun (PrimMax a)                = intHost $(hashQ "PrimMax")                <> encodeSingleType a+encodePrimFun (PrimMin a)                = intHost $(hashQ "PrimMin")                <> encodeSingleType a+encodePrimFun (PrimFromIntegral a b)     = intHost $(hashQ "PrimFromIntegral")       <> encodeIntegralType a <> encodeNumType b+encodePrimFun (PrimToFloating a b)       = intHost $(hashQ "PrimToFloating")         <> encodeNumType a      <> encodeFloatingType b+encodePrimFun PrimLAnd                   = intHost $(hashQ "PrimLAnd")+encodePrimFun PrimLOr                    = intHost $(hashQ "PrimLOr")+encodePrimFun PrimLNot                   = intHost $(hashQ "PrimLNot")+encodePrimFun PrimOrd                    = intHost $(hashQ "PrimOrd")+encodePrimFun PrimChr                    = intHost $(hashQ "PrimChr")+encodePrimFun PrimBoolToInt              = intHost $(hashQ "PrimBoolToInt")+++{-# INLINE encodeTupleType #-}+encodeTupleType :: TupleType t -> Builder+encodeTupleType TypeRunit       = intHost $(hashQ "TypeRunit")+encodeTupleType (TypeRscalar t) = intHost $(hashQ "TypeRscalar") <> encodeScalarType t+encodeTupleType (TypeRpair a b) = intHost $(hashQ "TypeRpair")   <> encodeTupleType a <> intHost (depthTypeR a)+                                                                 <> encodeTupleType b <> intHost (depthTypeR b)++{-# INLINE depthTypeR #-}+depthTypeR :: TupleType t -> Int+depthTypeR TypeRunit       = 0+depthTypeR TypeRscalar{}   = 1+depthTypeR (TypeRpair a b) = depthTypeR a + depthTypeR b++{-# INLINE encodeScalarType #-}+encodeScalarType :: ScalarType t -> Builder+encodeScalarType (SingleScalarType t) = intHost $(hashQ "SingleScalarType") <> encodeSingleType t+encodeScalarType (VectorScalarType t) = intHost $(hashQ "VectorScalarType") <> encodeVectorType t++{-# INLINE encodeSingleType #-}+encodeSingleType :: SingleType t -> Builder+encodeSingleType (NumSingleType t)    = intHost $(hashQ "NumSingleType")    <> encodeNumType t+encodeSingleType (NonNumSingleType t) = intHost $(hashQ "NonNumSingleType") <> encodeNonNumType t++{-# INLINE encodeVectorType #-}+encodeVectorType :: VectorType t -> Builder+encodeVectorType (Vector2Type t)  = intHost $(hashQ "Vector2Type") <> encodeSingleType t+encodeVectorType (Vector3Type t)  = intHost $(hashQ "Vector3Type") <> encodeSingleType t+encodeVectorType (Vector4Type t)  = intHost $(hashQ "Vector4Type") <> encodeSingleType t+encodeVectorType (Vector8Type t)  = intHost $(hashQ "Vector8Type") <> encodeSingleType t+encodeVectorType (Vector16Type t) = intHost $(hashQ "Vector16Type") <> encodeSingleType t++{-# INLINE encodeBoundedType #-}+encodeBoundedType :: BoundedType t -> Builder+encodeBoundedType (IntegralBoundedType t) = intHost $(hashQ "IntegralBoundedType") <> encodeIntegralType t+encodeBoundedType (NonNumBoundedType t)   = intHost $(hashQ "NonNumBoundedType")   <> encodeNonNumType t++{-# INLINE encodeNonNumType #-}+encodeNonNumType :: NonNumType t -> Builder+encodeNonNumType TypeBool{}   = intHost $(hashQ "Bool")+encodeNonNumType TypeChar{}   = intHost $(hashQ "Char")+encodeNonNumType TypeCChar{}  = intHost $(hashQ "CChar")+encodeNonNumType TypeCSChar{} = intHost $(hashQ "CSChar")+encodeNonNumType TypeCUChar{} = intHost $(hashQ "CUChar")++{-# INLINE encodeNumType #-}+encodeNumType :: NumType t -> Builder+encodeNumType (IntegralNumType t) = intHost $(hashQ "IntegralNumType") <> encodeIntegralType t+encodeNumType (FloatingNumType t) = intHost $(hashQ "FloatingNumType") <> encodeFloatingType t++{-# INLINE encodeIntegralType #-}+encodeIntegralType :: IntegralType t -> Builder+encodeIntegralType TypeInt{}     = intHost $(hashQ "Int")+encodeIntegralType TypeInt8{}    = intHost $(hashQ "Int8")+encodeIntegralType TypeInt16{}   = intHost $(hashQ "Int16")+encodeIntegralType TypeInt32{}   = intHost $(hashQ "Int32")+encodeIntegralType TypeInt64{}   = intHost $(hashQ "Int64")+encodeIntegralType TypeWord{}    = intHost $(hashQ "Word")+encodeIntegralType TypeWord8{}   = intHost $(hashQ "Word8")+encodeIntegralType TypeWord16{}  = intHost $(hashQ "Word16")+encodeIntegralType TypeWord32{}  = intHost $(hashQ "Word32")+encodeIntegralType TypeWord64{}  = intHost $(hashQ "Word64")+encodeIntegralType TypeCShort{}  = intHost $(hashQ "CShort")+encodeIntegralType TypeCUShort{} = intHost $(hashQ "CUShort")+encodeIntegralType TypeCInt{}    = intHost $(hashQ "CInt")+encodeIntegralType TypeCUInt{}   = intHost $(hashQ "CUInt")+encodeIntegralType TypeCLong{}   = intHost $(hashQ "CLong")+encodeIntegralType TypeCULong{}  = intHost $(hashQ "CULong")+encodeIntegralType TypeCLLong{}  = intHost $(hashQ "CLLong")+encodeIntegralType TypeCULLong{} = intHost $(hashQ "CULLong")++{-# INLINE encodeFloatingType #-}+encodeFloatingType :: FloatingType t -> Builder+encodeFloatingType TypeHalf{}    = intHost $(hashQ "Half")+encodeFloatingType TypeFloat{}   = intHost $(hashQ "Float")+encodeFloatingType TypeDouble{}  = intHost $(hashQ "Double")+encodeFloatingType TypeCFloat{}  = intHost $(hashQ "CFloat")+encodeFloatingType TypeCDouble{} = intHost $(hashQ "CDouble")+
+ src/Data/Array/Accelerate/Analysis/Hash/TH.hs view
@@ -0,0 +1,30 @@+-- |+-- Module      : Data.Array.Accelerate.Analysis.Hash.TH+-- Copyright   : [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.Hash.TH (++  hashQ,+  hashWithSaltQ,++) where++import Data.Hashable+import Language.Haskell.TH+++hashQ :: Hashable a => a -> ExpQ+hashQ = intE . hash++hashWithSaltQ :: Hashable a => Int -> a -> ExpQ+hashWithSaltQ s x = intE (hashWithSalt s x)++intE :: Int -> ExpQ+intE = litE . integerL . fromIntegral+
+ src/Data/Array/Accelerate/Analysis/Match.hs view
@@ -0,0 +1,1025 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Analysis.Match+-- 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,+  (:~:)(..),+  matchPreOpenAcc,+  matchPreOpenAfun,+  matchPreOpenExp,+  matchPreOpenFun,+  matchPrimFun,  matchPrimFun',++  -- auxiliary+  matchIdx, matchTupleType,+  matchIntegralType, matchFloatingType, matchNumType, matchScalarType,++) where++-- standard library+import Data.Maybe+import Data.Typeable+import System.IO.Unsafe                                 ( unsafePerformIO )+import System.Mem.StableName+import Prelude                                          hiding ( exp )++-- friends+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Analysis.Hash+import Data.Array.Accelerate.Array.Representation       ( SliceIndex(..) )+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Type+++-- 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 matchPreOpenAcc #-}+matchPreOpenAcc+    :: forall acc aenv s t.+       MatchAcc  acc+    -> EncodeAcc acc+    -> PreOpenAcc acc aenv s+    -> PreOpenAcc acc aenv t+    -> Maybe (s :~: t)+matchPreOpenAcc matchAcc encodeAcc = match+  where+    matchFun :: PreOpenFun acc env' aenv' u -> PreOpenFun acc env' aenv' v -> Maybe (u :~: v)+    matchFun = matchPreOpenFun matchAcc encodeAcc++    matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :~: v)+    matchExp = matchPreOpenExp matchAcc encodeAcc++    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) (Stencil f2 b2 a2)+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a2+      , matchBoundary matchAcc encodeAcc b1 b2+      = Just Refl++    match (Stencil2 f1 b1  a1  b2  a2) (Stencil2 f2 b1' a1' b2' a2')+      | Just Refl <- matchFun f1 f2+      , Just Refl <- matchAcc a1 a1'+      , Just Refl <- matchAcc a2 a2'+      , matchBoundary matchAcc encodeAcc b1 b1'+      , matchBoundary matchAcc encodeAcc b2 b2'+      = Just Refl++    -- match (Collect s1) (Collect s2)+    --   = matchSeq matchAcc encodeAcc s1 s2++    match _ _+      = Nothing+++-- Array tuples+--+{-# INLINEABLE matchAtuple #-}+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+--+{-# INLINEABLE matchPreOpenAfun #-}+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+--+{-# INLINEABLE matchBoundary #-}+matchBoundary+    :: forall acc aenv sh t. Elt t+    => MatchAcc  acc+    -> EncodeAcc acc+    -> PreBoundary acc aenv (Array sh t)+    -> PreBoundary acc aenv (Array sh t)+    -> Bool+matchBoundary _ _ Clamp        Clamp        = True+matchBoundary _ _ Mirror       Mirror       = True+matchBoundary _ _ Wrap         Wrap         = True+matchBoundary _ _ (Constant s) (Constant t) = matchConst (eltType (undefined::t)) s t+matchBoundary m h (Function f) (Function g)+  | Just Refl <- matchPreOpenFun m h f g+  = True+matchBoundary _ _ _ _+  = False+++{--+-- Match sequences+--+{-# INLINEABLE matchSeq #-}+matchSeq+    :: forall acc aenv senv s t.+       MatchAcc  acc+    -> EncodeAcc 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.+--+{-# INLINEABLE matchArrays #-}+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.+--+{-# INLINEABLE matchPreOpenExp #-}+matchPreOpenExp+    :: forall acc env aenv s t.+       MatchAcc  acc+    -> EncodeAcc acc+    -> PreOpenExp acc env aenv s+    -> PreOpenExp acc env aenv t+    -> Maybe (s :~: t)+matchPreOpenExp matchAcc encodeAcc = 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 Undef Undef+      | Just Refl <- matchTupleType (eltType (undefined::s')) (eltType (undefined::t'))+      = gcast Refl++    match (Coerce e1) (Coerce e2)+      | Just Refl <- matchTupleType (eltType (undefined::s')) (eltType (undefined::t'))+      , Just Refl <- match e1 e2+      = gcast Refl++    match (Tuple t1) (Tuple t2)+      | Just Refl <- matchTuple matchAcc encodeAcc 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 encodeAcc p1 p2+      , Just Refl <- matchPreOpenFun matchAcc encodeAcc f1 f2+      = Just Refl++    match (PrimConst c1) (PrimConst c2)+      = matchPrimConst c1 c2++    match (PrimApp f1 x1) (PrimApp f2 x2)+      | Just x1'  <- commutes encodeAcc f1 x1+      , Just x2'  <- commutes encodeAcc 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+--+{-# INLINEABLE matchPreOpenFun #-}+matchPreOpenFun+    :: MatchAcc  acc+    -> EncodeAcc 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+--+{-# INLINEABLE matchConst #-}+matchConst :: TupleType a -> a -> a -> Bool+matchConst TypeRunit         ()      ()      = True+matchConst (TypeRscalar ty)  a       b       = evalEq ty (a,b)+matchConst (TypeRpair ta tb) (a1,b1) (a2,b2) = matchConst ta a1 a2 && matchConst tb b1 b2++evalEq :: ScalarType a -> (a, a) -> Bool+evalEq (SingleScalarType t) = evalEqSingle t+evalEq (VectorScalarType t) = evalEqVector t++evalEqSingle :: SingleType a -> (a, a) -> Bool+evalEqSingle (NumSingleType t)                                  = evalEqNum t+evalEqSingle (NonNumSingleType t) | NonNumDict <- nonNumDict t  = uncurry (==)++evalEqVector :: VectorType a -> (a, a) -> Bool+evalEqVector (Vector2Type t) (V2 a1 b1, V2 a2 b2)             = evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2)+evalEqVector (Vector3Type t) (V3 a1 b1 c1, V3 a2 b2 c2)       = evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2) && evalEqSingle t (c1,c2)+evalEqVector (Vector4Type t) (V4 a1 b1 c1 d1, V4 a2 b2 c2 d2) = evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2) && evalEqSingle t (c1,c2) && evalEqSingle t (d1,d2)+evalEqVector (Vector8Type t) ( V8 a1 b1 c1 d1 e1 f1 g1 h1+                             , V8 a2 b2 c2 d2 e2 f2 g2 h2 ) =+  evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2) && evalEqSingle t (c1,c2) && evalEqSingle t (d1,d2) &&+  evalEqSingle t (e1,e2) && evalEqSingle t (f1,f2) && evalEqSingle t (g1,g2) && evalEqSingle t (h1,h2)+evalEqVector (Vector16Type t) ( V16 a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1 o1 p1+                              , V16 a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 o2 p2 ) =+  evalEqSingle t (a1,a2) && evalEqSingle t (b1,b2) && evalEqSingle t (c1,c2) && evalEqSingle t (d1,d2) &&+  evalEqSingle t (e1,e2) && evalEqSingle t (f1,f2) && evalEqSingle t (g1,g2) && evalEqSingle t (h1,h2) &&+  evalEqSingle t (i1,i2) && evalEqSingle t (j1,j2) && evalEqSingle t (k1,k2) && evalEqSingle t (l1,l2) &&+  evalEqSingle t (m1,m2) && evalEqSingle t (n1,n2) && evalEqSingle t (o1,o2) && evalEqSingle t (p1,p2)++evalEqNum :: NumType a -> (a, a) -> Bool+evalEqNum (IntegralNumType t) | IntegralDict <- integralDict t  = uncurry (==)+evalEqNum (FloatingNumType t) | FloatingDict <- floatingDict t  = uncurry (==)+++-- Environment projection indices+--+{-# INLINEABLE matchIdx #-}+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.+--+{-# INLINEABLE matchTupleIdx #-}+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+--+{-# INLINEABLE matchTuple #-}+matchTuple+    :: MatchAcc  acc+    -> EncodeAcc 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+--+{-# INLINEABLE matchSliceRestrict #-}+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+++{-# INLINEABLE matchSliceExtend #-}+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+--+{-# INLINEABLE matchPrimConst #-}+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+--+{-# INLINEABLE matchPrimFun #-}+matchPrimFun :: (Typeable s, Typeable 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 (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 (PrimIsInfinite _)         (PrimIsInfinite _)         = 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 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+--+{-# INLINEABLE matchPrimFun' #-}+matchPrimFun' :: (Typeable s, Typeable 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' (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' (PrimIsInfinite s)         (PrimIsInfinite 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' 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 <- matchSingleType s t+  = Just Refl++matchPrimFun' (PrimGt s) (PrimGt t)+  | Just Refl <- matchSingleType s t+  = Just Refl++matchPrimFun' (PrimLtEq s) (PrimLtEq t)+  | Just Refl <- matchSingleType s t+  = Just Refl++matchPrimFun' (PrimGtEq s) (PrimGtEq t)+  | Just Refl <- matchSingleType s t+  = Just Refl++matchPrimFun' (PrimEq s) (PrimEq t)+  | Just Refl <- matchSingleType s t+  = Just Refl++matchPrimFun' (PrimNEq s) (PrimNEq t)+  | Just Refl <- matchSingleType s t+  = Just Refl++matchPrimFun' _ _+  = Nothing+++-- Match reified types+--+{-# INLINEABLE matchTupleType #-}+matchTupleType :: TupleType s -> TupleType t -> Maybe (s :~: t)+matchTupleType TypeRunit         TypeRunit         = Just Refl+matchTupleType (TypeRscalar s)   (TypeRscalar t)   = matchScalarType s t+matchTupleType (TypeRpair s1 s2) (TypeRpair t1 t2)+  | Just Refl <- matchTupleType s1 t1+  , Just Refl <- matchTupleType s2 t2+  = Just Refl++matchTupleType _ _+  = Nothing+++-- Match reified type dictionaries+--+{-# INLINEABLE matchScalarType #-}+matchScalarType :: ScalarType s -> ScalarType t -> Maybe (s :~: t)+matchScalarType (SingleScalarType s) (SingleScalarType t) = matchSingleType s t+matchScalarType (VectorScalarType s) (VectorScalarType t) = matchVectorType s t+matchScalarType _                    _                    = Nothing++{-# INLINEABLE matchSingleType #-}+matchSingleType :: SingleType s -> SingleType t -> Maybe (s :~: t)+matchSingleType (NumSingleType s)    (NumSingleType t)    = matchNumType s t+matchSingleType (NonNumSingleType s) (NonNumSingleType t) = matchNonNumType s t+matchSingleType _                    _                    = Nothing++{-# INLINEABLE matchVectorType #-}+matchVectorType :: VectorType s -> VectorType t -> Maybe (s :~: t)+matchVectorType (Vector2Type s) (Vector2Type t)+  | Just Refl <- matchSingleType s t+  = Just Refl+matchVectorType (Vector3Type s) (Vector3Type t)+  | Just Refl <- matchSingleType s t+  = Just Refl+matchVectorType (Vector4Type s) (Vector4Type t)+  | Just Refl <- matchSingleType s t+  = Just Refl+matchVectorType (Vector8Type s) (Vector8Type t)+  | Just Refl <- matchSingleType s t+  = Just Refl+matchVectorType (Vector16Type s) (Vector16Type t)+  | Just Refl <- matchSingleType s t+  = Just Refl+matchVectorType _ _+  = Nothing++{-# INLINEABLE matchNumType #-}+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++{-# INLINEABLE matchBoundedType #-}+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++{-# INLINEABLE matchIntegralType #-}+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++{-# INLINEABLE matchFloatingType #-}+matchFloatingType :: FloatingType s -> FloatingType t -> Maybe (s :~: t)+matchFloatingType TypeHalf{}    TypeHalf{}    = Just Refl+matchFloatingType TypeFloat{}   TypeFloat{}   = Just Refl+matchFloatingType TypeDouble{}  TypeDouble{}  = Just Refl+matchFloatingType TypeCFloat{}  TypeCFloat{}  = Just Refl+matchFloatingType TypeCDouble{} TypeCDouble{} = Just Refl+matchFloatingType _             _             = Nothing++{-# INLINEABLE matchNonNumType #-}+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+++-- Auxiliary+-- ---------++-- 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.+       EncodeAcc 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+
+ src/Data/Array/Accelerate/Analysis/Shape.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Analysis.Shape+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] 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.Shape (++  -- * query AST dimensionality+  AccDim, accDim, delayedDim, preAccDim,+  expDim,++) where++import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Trafo.Base+import Data.Array.Accelerate.Array.Sugar+++type AccDim acc  = forall aenv sh e. acc aenv (Array sh e) -> Int++-- |Reify the dimensionality of the result type of an array computation+--+accDim :: AccDim OpenAcc+accDim (OpenAcc acc) = preAccDim accDim acc++delayedDim :: AccDim DelayedOpenAcc+delayedDim (Manifest acc)   = preAccDim delayedDim acc+delayedDim (Delayed sh _ _) = expDim sh+++-- |Reify dimensionality of a computation parameterised over a recursive closure+--+preAccDim :: forall acc aenv sh e. AccDim acc -> PreOpenAcc acc aenv (Array sh e) -> Int+preAccDim k pacc =+  case pacc of+    Alet  _ acc          -> k acc+    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+                              ArraysRarray -> ndim (eltType (undefined::sh))+#if __GLASGOW_HASKELL__ < 800+                              _            -> error "umm, hello"+#endif++    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+                              ArraysRarray -> ndim (eltType (undefined::sh))+#if __GLASGOW_HASKELL__ < 800+                              _            -> error "can we keep him?"+#endif++    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))+    Unit _               -> 0+    Generate _ _         -> ndim (eltType (undefined::sh))+    Transform _ _ _ _    -> ndim (eltType (undefined::sh))+    Reshape _ _          -> ndim (eltType (undefined::sh))+    Replicate _ _ _      -> ndim (eltType (undefined::sh))+    Slice _ _ _          -> ndim (eltType (undefined::sh))+    Map _ acc            -> k acc+    ZipWith _ _ acc      -> k acc+    Fold _ _ acc         -> k acc - 1+    Fold1 _ acc          -> k acc - 1+    FoldSeg _ _ acc _    -> k acc+    Fold1Seg _ acc _     -> k acc+    Scanl _ _ acc        -> k acc+    Scanl1 _ acc         -> k acc+    Scanr _ _ acc        -> k acc+    Scanr1 _ acc         -> k acc+    Permute _ acc _ _    -> k acc+    Backpermute _ _ _    -> ndim (eltType (undefined::sh))+    Stencil _ _ acc      -> k acc+    Stencil2 _ _ acc _ _ -> k acc+++-- |Reify dimensionality of a scalar expression yielding a shape+--+expDim :: forall acc env aenv sh. Elt sh => PreOpenExp acc env aenv sh -> Int+expDim _ = ndim (eltType (undefined :: sh))+++-- Count the number of components to a tuple type+--+ndim :: TupleType a -> Int+ndim TypeRunit       = 0+ndim TypeRscalar{}   = 1+ndim (TypeRpair a b) = ndim a + ndim b+
+ src/Data/Array/Accelerate/Analysis/Stencil.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Analysis.Stencil+-- Copyright   : [2010..2011] Ben Lever+--               [2010..2017] 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.Stencil (offsets, offsets2) where++import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Array.Sugar+++-- |Calculate the offset coordinates for each stencil element relative to the+-- focal point. The coordinates are returned as a flattened list from the+-- bottom-left element to the top-right. This ordering matches the Var indexing+-- order.+--+offsets :: forall a b sh aenv stencil. Stencil sh a stencil+        => {- dummy -} Fun aenv (stencil -> b)+        -> {- dummy -} OpenAcc aenv (Array sh a)+        -> [sh]+offsets _ _ = positionsR (stencil :: StencilR sh a stencil)++offsets2 :: forall a b c sh aenv stencil1 stencil2. (Stencil sh a stencil1, Stencil sh b stencil2)+         => {- dummy -} Fun aenv (stencil1 -> stencil2 -> c)+         -> {- dummy -} OpenAcc aenv (Array sh a)+         -> {- dummy -} OpenAcc aenv (Array sh b)+         -> ([sh], [sh])+offsets2 _ _ _ =+  ( positionsR (stencil :: StencilR sh a stencil1)+  , positionsR (stencil :: StencilR sh b stencil2) )+++-- |Position calculation on reified stencil values.+--+positionsR :: StencilR sh e pat -> [sh]+positionsR StencilRunit3 = map (Z:.) [         -1, 0, 1          ]+positionsR StencilRunit5 = map (Z:.) [      -2,-1, 0, 1, 2       ]+positionsR StencilRunit7 = map (Z:.) [   -3,-2,-1, 0, 1, 2, 3    ]+positionsR StencilRunit9 = map (Z:.) [-4,-3,-2,-1, 0, 1, 2, 3, 4 ]++positionsR (StencilRtup3 c b a) = concat+  [ map (innermost (:. -1)) $ positionsR c+  , map (innermost (:.  0)) $ positionsR b+  , map (innermost (:.  1)) $ positionsR a ]++positionsR (StencilRtup5 e d c b a) = concat+  [ map (innermost (:. -2)) $ positionsR e+  , map (innermost (:. -1)) $ positionsR d+  , map (innermost (:.  0)) $ positionsR c+  , map (innermost (:.  1)) $ positionsR b+  , map (innermost (:.  2)) $ positionsR a ]++positionsR (StencilRtup7 g f e d c b a) = concat+  [ map (innermost (:. -3)) $ positionsR g+  , map (innermost (:. -2)) $ positionsR f+  , map (innermost (:. -1)) $ positionsR e+  , map (innermost (:.  0)) $ positionsR d+  , map (innermost (:.  1)) $ positionsR c+  , map (innermost (:.  2)) $ positionsR b+  , map (innermost (:.  3)) $ positionsR a ]++positionsR (StencilRtup9 i h g f e d c b a) = concat+  [ map (innermost (:. -4)) $ positionsR i+  , map (innermost (:. -3)) $ positionsR h+  , map (innermost (:. -2)) $ positionsR g+  , map (innermost (:. -1)) $ positionsR f+  , map (innermost (:.  0)) $ positionsR e+  , map (innermost (:.  1)) $ positionsR d+  , map (innermost (:.  2)) $ positionsR c+  , map (innermost (:.  3)) $ positionsR b+  , map (innermost (:.  4)) $ positionsR a ]+++-- Inject a dimension component inner-most+--+innermost :: Shape sh => (sh -> sh :. Int) -> sh -> sh :. Int+innermost f = invertShape . f . invertShape++invertShape :: Shape sh => sh -> sh+invertShape =  listToShape . reverse . shapeToList+
+ src/Data/Array/Accelerate/Analysis/Type.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Analysis.Type+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- The Accelerate AST does not explicitly store much type information.  Most of+-- it is only indirectly through type class constraints -especially, 'Elt'+-- constraints- available. This module provides functions that reify that type+-- information in the form of a 'TupleType value. This is, for example, needed+-- to emit type information in a backend.+--++module Data.Array.Accelerate.Analysis.Type (++  -- * Query AST types+  AccType, arrayType, sizeOf,+  accType, expType, delayedAccType, delayedExpType,+  preAccType, preExpType++) where++-- friends+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Trafo.Base+import Data.Array.Accelerate.Type++-- standard library+import qualified Foreign.Storable as F+++-- |Determine an array type+-- ------------------------++-- |Reify the element type of an array.+--+arrayType :: forall sh e. Array sh e -> TupleType (EltRepr e)+arrayType (Array _ _) = eltType (undefined::e)+++-- |Determine the type of an expressions+-- -------------------------------------++type AccType  acc = forall aenv sh e. acc aenv (Array sh e) -> TupleType (EltRepr e)++-- |Reify the element type of the result of an array computation.+--+accType :: AccType OpenAcc+accType (OpenAcc acc) = preAccType accType acc++delayedAccType :: AccType DelayedOpenAcc+delayedAccType (Manifest acc) = preAccType delayedAccType acc+delayedAccType (Delayed _ f _)+  | Lam (Body e) <- f   = delayedExpType e+  | otherwise           = error "my favourite place in the world is wherever you happen to be"+++-- |Reify the element type of the result of an array computation using the array computation AST+-- before tying the knot.+--+preAccType :: forall acc aenv sh e.+              AccType acc+           -> PreOpenAcc acc aenv (Array sh e)+           -> TupleType (EltRepr e)+preAccType k pacc =+  case pacc of+    Alet  _ acc         -> k acc++    -- The following all contain impossible pattern matches, but GHC's type+    -- checker does no grok that+    --+    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+                             ArraysRarray -> eltType (undefined::e)+#if __GLASGOW_HASKELL__ < 800+                             _            -> error "TRUE STORY."+#endif++    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+                             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+                             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+    Unit _              -> eltType (undefined::e)+    Generate _ _        -> eltType (undefined::e)+    Transform _ _ _ _   -> eltType (undefined::e)+    Reshape _ acc       -> k acc+    Replicate _ _ acc   -> k acc+    Slice _ acc _       -> k acc+    Map _ _             -> eltType (undefined::e)+    ZipWith _ _ _       -> eltType (undefined::e)+    Fold _ _ acc        -> k acc+    FoldSeg _ _ acc _   -> k acc+    Fold1 _ acc         -> k acc+    Fold1Seg _ acc _    -> k acc+    Scanl _ _ acc       -> k acc+    Scanl1 _ acc        -> k acc+    Scanr _ _ acc       -> k acc+    Scanr1 _ acc        -> k acc+    Permute _ _ _ acc   -> k acc+    Backpermute _ _ acc -> k acc+    Stencil _ _ _       -> eltType (undefined::e)+    Stencil2 _ _ _ _ _  -> eltType (undefined::e)+++-- |Reify the result type of a scalar expression.+--+expType :: OpenExp env aenv t -> TupleType (EltRepr t)+expType = preExpType accType++delayedExpType :: DelayedOpenExp env aenv t -> TupleType (EltRepr t)+delayedExpType = preExpType delayedAccType++-- |Reify the result types of of a scalar expression using the expression AST before tying the+-- knot.+--+preExpType :: forall acc aenv env t.+              AccType acc+           -> PreOpenExp acc aenv env t+           -> TupleType (EltRepr t)+preExpType k e =+  case e of+    Let _ _           -> eltType (undefined::t)+    Var _             -> eltType (undefined::t)+    Const _           -> eltType (undefined::t)+    Undef             -> eltType (undefined::t)+    Tuple _           -> eltType (undefined::t)+    Prj _ _           -> eltType (undefined::t)+    IndexNil          -> eltType (undefined::t)+    IndexCons _ _     -> eltType (undefined::t)+    IndexHead _       -> eltType (undefined::t)+    IndexTail _       -> eltType (undefined::t)+    IndexAny          -> eltType (undefined::t)+    IndexSlice _ _ _  -> eltType (undefined::t)+    IndexFull _ _ _   -> eltType (undefined::t)+    ToIndex _ _       -> eltType (undefined::t)+    FromIndex _ _     -> eltType (undefined::t)+    Cond _ t _        -> preExpType k t+    While _ _ _       -> eltType (undefined::t)+    PrimConst _       -> eltType (undefined::t)+    PrimApp _ _       -> eltType (undefined::t)+    Index acc _       -> k acc+    LinearIndex acc _ -> k acc+    Shape _           -> eltType (undefined::t)+    ShapeSize _       -> eltType (undefined::t)+    Intersect _ _     -> eltType (undefined::t)+    Union _ _         -> eltType (undefined::t)+    Foreign _ _ _     -> eltType (undefined::t)+    Coerce _          -> eltType (undefined::t)+++-- |Size of a tuple type, in bytes+--+sizeOf :: TupleType a -> Int+sizeOf TypeRunit       = 0+sizeOf (TypeRpair a b) = sizeOf a + sizeOf b+sizeOf (TypeRscalar t) = sizeOfScalarType t++sizeOfScalarType :: ScalarType t -> Int+sizeOfScalarType (SingleScalarType t) = sizeOfSingleType t+sizeOfScalarType (VectorScalarType t) = sizeOfVectorType t++sizeOfSingleType :: SingleType t -> Int+sizeOfSingleType (NumSingleType t)    = sizeOfNumType t+sizeOfSingleType (NonNumSingleType t) = sizeOfNonNumType t++sizeOfVectorType :: VectorType t -> Int+sizeOfVectorType (Vector2Type t)  = 2 * sizeOfSingleType t+sizeOfVectorType (Vector3Type t)  = 3 * sizeOfSingleType t+sizeOfVectorType (Vector4Type t)  = 4 * sizeOfSingleType t+sizeOfVectorType (Vector8Type t)  = 8 * sizeOfSingleType t+sizeOfVectorType (Vector16Type t) = 16 * sizeOfSingleType t++sizeOfNumType :: forall t. NumType t -> Int+sizeOfNumType (IntegralNumType t) | IntegralDict <- integralDict t = F.sizeOf (undefined::t)+sizeOfNumType (FloatingNumType t) | FloatingDict <- floatingDict t = F.sizeOf (undefined::t)++sizeOfNonNumType :: forall t. NonNumType t -> Int+sizeOfNonNumType TypeBool{} = 1 -- stored as Word8+sizeOfNonNumType t | NonNumDict <- nonNumDict t = F.sizeOf (undefined::t)+
+ src/Data/Array/Accelerate/Array/Data.hs view
@@ -0,0 +1,1036 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE UnboxedTuples       #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Data+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module fixes the concrete representation of Accelerate arrays.  We+-- allocate all arrays using pinned memory to enable safe direct-access by+-- non-Haskell code in multi-threaded code.  In particular, we can safely pass+-- pointers to an array's payload to foreign code.+--++module Data.Array.Accelerate.Array.Data (++  -- * Array operations and representations+  ArrayElt(..), ArrayData, MutableArrayData, runArrayData,+  ArrayEltR(..), GArrayData(..),++  -- * Array tuple operations+  fstArrayData, sndArrayData, pairArrayData,++  -- * 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.Monitoring+import Data.Array.Accelerate.Debug.Trace++-- standard libraries+import Control.Applicative+import Control.Monad+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++import GHC.Base                                                     ( Int(..), IO(..), unsafeCoerce#, newAlignedPinnedByteArray#, byteArrayContents# )+import GHC.ForeignPtr                                               ( ForeignPtr(..), ForeignPtrContents(..) )+++-- Determine the underlying type of a Haskell CLong or CULong.+--+$( runQ [d| type HTYPE_INT = $(+              case finiteBitSize (undefined::Int) of+                32 -> [t| Int32 |]+                64 -> [t| Int64 |]+                _  -> error "I don't know what architecture I am" ) |] )++$( runQ [d| type HTYPE_WORD = $(+              case finiteBitSize (undefined::Word) of+                32 -> [t| Word32 |]+                64 -> [t| Word64 |]+                _  -> error "I don't know what architecture I am" ) |] )++$( runQ [d| type HTYPE_LONG = $(+              case finiteBitSize (undefined::CLong) of+                32 -> [t| Int32 |]+                64 -> [t| Int64 |]+                _  -> error "I don't know what architecture I am" ) |] )++$( runQ [d| type HTYPE_UNSIGNED_LONG = $(+              case finiteBitSize (undefined::CULong) of+                32 -> [t| Word32 |]+                64 -> [t| Word64 |]+                _  -> error "I don't know what architecture I am" ) |] )++$( runQ [d| type HTYPE_CCHAR = $(+              case isSigned (undefined::CChar) of+                True  -> [t| Int8  |]+                False -> [t| Word8 |] ) |] )+++-- Array representation+-- --------------------++-- |Immutable array representation+--+type ArrayData e = MutableArrayData e++-- |Mutable array representation+--+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)+--+data family GArrayData :: (* -> *) -> * -> *+data instance GArrayData ba ()      = AD_Unit+data instance GArrayData ba Int     = AD_Int     (ba Int)+data instance GArrayData ba Int8    = AD_Int8    (ba Int8)+data instance GArrayData ba Int16   = AD_Int16   (ba Int16)+data instance GArrayData ba Int32   = AD_Int32   (ba Int32)+data instance GArrayData ba Int64   = AD_Int64   (ba Int64)+data instance GArrayData ba Word    = AD_Word    (ba Word)+data instance GArrayData ba Word8   = AD_Word8   (ba Word8)+data instance GArrayData ba Word16  = AD_Word16  (ba Word16)+data instance GArrayData ba Word32  = AD_Word32  (ba Word32)+data instance GArrayData ba Word64  = AD_Word64  (ba Word64)+data instance GArrayData ba CShort  = AD_CShort  (ba Int16)+data instance GArrayData ba CUShort = AD_CUShort (ba Word16)+data instance GArrayData ba CInt    = AD_CInt    (ba Int32)+data instance GArrayData ba CUInt   = AD_CUInt   (ba Word32)+data instance GArrayData ba CLong   = AD_CLong   (ba HTYPE_LONG)+data instance GArrayData ba CULong  = AD_CULong  (ba HTYPE_UNSIGNED_LONG)+data instance GArrayData ba CLLong  = AD_CLLong  (ba Int64)+data instance GArrayData ba CULLong = AD_CULLong (ba Word64)+data instance GArrayData ba Half    = AD_Half    (ba Half)+data instance GArrayData ba Float   = AD_Float   (ba Float)+data instance GArrayData ba Double  = AD_Double  (ba Double)+data instance GArrayData ba CFloat  = AD_CFloat  (ba Float)+data instance GArrayData ba CDouble = AD_CDouble (ba Double)+data instance GArrayData ba Bool    = AD_Bool    (ba Word8)+data instance GArrayData ba Char    = AD_Char    (ba Char)+data instance GArrayData ba CChar   = AD_CChar   (ba HTYPE_CCHAR)+data instance GArrayData ba CSChar  = AD_CSChar  (ba Int8)+data instance GArrayData ba CUChar  = AD_CUChar  (ba Word8)+data instance GArrayData ba (V2 a)  = AD_V2   (GArrayData ba a)+data instance GArrayData ba (V3 a)  = AD_V3   (GArrayData ba a)+data instance GArrayData ba (V4 a)  = AD_V4   (GArrayData ba a)+data instance GArrayData ba (V8 a)  = AD_V8   (GArrayData ba a)+data instance GArrayData ba (V16 a) = AD_V16  (GArrayData ba a)+data instance GArrayData ba (a, b)  = AD_Pair (GArrayData ba a)+                                              (GArrayData ba b)++deriving instance Typeable GArrayData+++-- | GADT to reify the 'ArrayElt' class.+--+data ArrayEltR a where+  ArrayEltRunit    :: ArrayEltR ()+  ArrayEltRint     :: ArrayEltR Int+  ArrayEltRint8    :: ArrayEltR Int8+  ArrayEltRint16   :: ArrayEltR Int16+  ArrayEltRint32   :: ArrayEltR Int32+  ArrayEltRint64   :: ArrayEltR Int64+  ArrayEltRword    :: ArrayEltR Word+  ArrayEltRword8   :: ArrayEltR Word8+  ArrayEltRword16  :: ArrayEltR Word16+  ArrayEltRword32  :: ArrayEltR Word32+  ArrayEltRword64  :: ArrayEltR Word64+  ArrayEltRcshort  :: ArrayEltR CShort+  ArrayEltRcushort :: ArrayEltR CUShort+  ArrayEltRcint    :: ArrayEltR CInt+  ArrayEltRcuint   :: ArrayEltR CUInt+  ArrayEltRclong   :: ArrayEltR CLong+  ArrayEltRculong  :: ArrayEltR CULong+  ArrayEltRcllong  :: ArrayEltR CLLong+  ArrayEltRcullong :: ArrayEltR CULLong+  ArrayEltRhalf    :: ArrayEltR Half+  ArrayEltRfloat   :: ArrayEltR Float+  ArrayEltRdouble  :: ArrayEltR Double+  ArrayEltRcfloat  :: ArrayEltR CFloat+  ArrayEltRcdouble :: ArrayEltR CDouble+  ArrayEltRbool    :: ArrayEltR Bool+  ArrayEltRchar    :: ArrayEltR Char+  ArrayEltRcchar   :: ArrayEltR CChar+  ArrayEltRcschar  :: ArrayEltR CSChar+  ArrayEltRcuchar  :: ArrayEltR CUChar+  ArrayEltRvec2    :: ArrayEltR a -> ArrayEltR (V2 a)+  ArrayEltRvec3    :: ArrayEltR a -> ArrayEltR (V3 a)+  ArrayEltRvec4    :: ArrayEltR a -> ArrayEltR (V4 a)+  ArrayEltRvec8    :: ArrayEltR a -> ArrayEltR (V8 a)+  ArrayEltRvec16   :: ArrayEltR a -> ArrayEltR (V16 a)+  ArrayEltRpair    :: (ArrayElt a, ArrayElt b)+                   => ArrayEltR a -> ArrayEltR b -> ArrayEltR (a,b)++-- Array operations+-- ----------------+--+-- TLM: do we need to INLINE these functions to get good performance interfacing+--      to external libraries, especially Repa?++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)+  ptrsOfMutableArrayData :: MutableArrayData e -> IO (ArrayPtrs e)+  --+  {-# INLINE unsafeFreezeArrayData  #-}+  {-# INLINE ptrsOfMutableArrayData #-}+  unsafeFreezeArrayData  = return+  ptrsOfMutableArrayData = return . ptrsOfArrayData++instance ArrayElt () where+  type ArrayPtrs () = ()+  arrayElt          = ArrayEltRunit+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData !_                    = return AD_Unit+  ptrsOfArrayData      AD_Unit       = ()+  touchArrayData       AD_Unit       = return ()+  unsafeIndexArrayData AD_Unit !_    = ()+  unsafeReadArrayData  AD_Unit !_    = return ()+  unsafeWriteArrayData AD_Unit !_ () = return ()++instance ArrayElt Int where+  type ArrayPtrs Int = Ptr Int+  arrayElt           = ArrayEltRint+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                    = AD_Int <$> newArrayData' size+  ptrsOfArrayData      (AD_Int ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Int ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Int ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Int ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Int ba) i e = unsafeWriteArray ba i e++instance ArrayElt Int8 where+  type ArrayPtrs Int8 = Ptr Int8+  arrayElt            = ArrayEltRint8+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                     = AD_Int8 <$> newArrayData' size+  ptrsOfArrayData      (AD_Int8 ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Int8 ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Int8 ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Int8 ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Int8 ba) i e = unsafeWriteArray ba i e++instance ArrayElt Int16 where+  type ArrayPtrs Int16 = Ptr Int16+  arrayElt             = ArrayEltRint16+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                      = AD_Int16 <$> newArrayData' size+  ptrsOfArrayData      (AD_Int16 ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Int16 ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Int16 ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Int16 ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Int16 ba) i e = unsafeWriteArray ba i e++instance ArrayElt Int32 where+  type ArrayPtrs Int32 = Ptr Int32+  arrayElt             = ArrayEltRint32+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                      = AD_Int32 <$> newArrayData' size+  ptrsOfArrayData      (AD_Int32 ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Int32 ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Int32 ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Int32 ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Int32 ba) i e = unsafeWriteArray ba i e++instance ArrayElt Int64 where+  type ArrayPtrs Int64 = Ptr Int64+  arrayElt             = ArrayEltRint64+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                      = AD_Int64 <$> newArrayData' size+  ptrsOfArrayData      (AD_Int64 ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Int64 ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Int64 ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Int64 ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Int64 ba) i e = unsafeWriteArray ba i e++instance ArrayElt Word where+  type ArrayPtrs Word = Ptr Word+  arrayElt            = ArrayEltRword+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                     = AD_Word <$> newArrayData' size+  ptrsOfArrayData      (AD_Word ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Word ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Word ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Word ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Word ba) i e = unsafeWriteArray ba i e++instance ArrayElt Word8 where+  type ArrayPtrs Word8 = Ptr Word8+  arrayElt             = ArrayEltRword8+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                      = AD_Word8 <$> newArrayData' size+  ptrsOfArrayData      (AD_Word8 ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Word8 ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Word8 ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Word8 ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Word8 ba) i e = unsafeWriteArray ba i e++instance ArrayElt Word16 where+  type ArrayPtrs Word16 = Ptr Word16+  arrayElt              = ArrayEltRword16+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                       = AD_Word16 <$> newArrayData' size+  unsafeIndexArrayData (AD_Word16 ba) i   = unsafeIndexArray ba i+  ptrsOfArrayData      (AD_Word16 ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Word16 ba)     = touchUniqueArray ba+  unsafeReadArrayData  (AD_Word16 ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Word16 ba) i e = unsafeWriteArray ba i e++instance ArrayElt Word32 where+  type ArrayPtrs Word32 = Ptr Word32+  arrayElt              = ArrayEltRword32+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                       = AD_Word32 <$> newArrayData' size+  ptrsOfArrayData      (AD_Word32 ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Word32 ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Word32 ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Word32 ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Word32 ba) i e = unsafeWriteArray ba i e++instance ArrayElt Word64 where+  type ArrayPtrs Word64 = Ptr Word64+  arrayElt              = ArrayEltRword64+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                       = AD_Word64 <$> newArrayData' size+  ptrsOfArrayData      (AD_Word64 ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Word64 ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Word64 ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Word64 ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Word64 ba) i e = unsafeWriteArray ba i e++instance ArrayElt CShort where+  type ArrayPtrs CShort = Ptr Int16+  arrayElt              = ArrayEltRcshort+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                                = AD_CShort <$> newArrayData' size+  ptrsOfArrayData      (AD_CShort ba)              = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CShort ba)              = touchUniqueArray ba+  unsafeIndexArrayData (AD_CShort ba) i            = CShort  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CShort ba) i            = CShort <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CShort ba) i (CShort e) = unsafeWriteArray ba i e++instance ArrayElt CUShort where+  type ArrayPtrs CUShort = Ptr Word16+  arrayElt               = ArrayEltRcushort+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                                  = AD_CUShort <$> newArrayData' size+  ptrsOfArrayData      (AD_CUShort ba)               = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CUShort ba)               = touchUniqueArray ba+  unsafeIndexArrayData (AD_CUShort ba) i             = CUShort  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CUShort ba) i             = CUShort <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CUShort ba) i (CUShort e) = unsafeWriteArray ba i e++instance ArrayElt CInt where+  type ArrayPtrs CInt = Ptr Int32+  arrayElt            = ArrayEltRcint+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                            = AD_CInt <$> newArrayData' size+  ptrsOfArrayData      (AD_CInt ba)            = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CInt ba)            = touchUniqueArray ba+  unsafeIndexArrayData (AD_CInt ba) i          = CInt  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CInt ba) i          = CInt <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CInt ba) i (CInt e) = unsafeWriteArray ba i e++instance ArrayElt CUInt where+  type ArrayPtrs CUInt = Ptr Word32+  arrayElt             = ArrayEltRcuint+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                              = AD_CUInt <$> newArrayData' size+  ptrsOfArrayData      (AD_CUInt ba)             = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CUInt ba)             = touchUniqueArray ba+  unsafeIndexArrayData (AD_CUInt ba) i           = CUInt  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CUInt ba) i           = CUInt <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CUInt ba) i (CUInt e) = unsafeWriteArray ba i e++instance ArrayElt CLong where+  type ArrayPtrs CLong = Ptr HTYPE_LONG+  arrayElt             = ArrayEltRclong+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                              = AD_CLong <$> newArrayData' size+  ptrsOfArrayData      (AD_CLong ba)             = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CLong ba)             = touchUniqueArray ba+  unsafeIndexArrayData (AD_CLong ba) i           = CLong  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CLong ba) i           = CLong <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CLong ba) i (CLong e) = unsafeWriteArray ba i e++instance ArrayElt CULong where+  type ArrayPtrs CULong = Ptr HTYPE_UNSIGNED_LONG+  arrayElt              = ArrayEltRculong+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                                = AD_CULong <$> newArrayData' size+  ptrsOfArrayData      (AD_CULong ba)              = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CULong ba)              = touchUniqueArray ba+  unsafeIndexArrayData (AD_CULong ba) i            = CULong  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CULong ba) i            = CULong <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CULong ba) i (CULong e) = unsafeWriteArray ba i e++instance ArrayElt CLLong where+  type ArrayPtrs CLLong = Ptr Int64+  arrayElt              = ArrayEltRcllong+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE ptrsOfArrayData #-}+  {-# INLINE touchArrayData #-}+  {-# INLINE newArrayData #-}+  {-# INLINE unsafeReadArrayData #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                                = AD_CLLong <$> newArrayData' size+  ptrsOfArrayData      (AD_CLLong ba)              = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CLLong ba)              = touchUniqueArray ba+  unsafeIndexArrayData (AD_CLLong ba) i            = CLLong  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CLLong ba) i            = CLLong <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CLLong ba) i (CLLong e) = unsafeWriteArray ba i e++instance ArrayElt CULLong where+  type ArrayPtrs CULLong = Ptr Word64+  arrayElt               = ArrayEltRcullong+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                                  = AD_CULLong <$> newArrayData' size+  ptrsOfArrayData      (AD_CULLong ba)               = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CULLong ba)               = touchUniqueArray ba+  unsafeIndexArrayData (AD_CULLong ba) i             = CULLong  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CULLong ba) i             = CULLong <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CULLong ba) i (CULLong e) = unsafeWriteArray ba i e++instance ArrayElt Half where+  type ArrayPtrs Half = Ptr Half+  arrayElt            = ArrayEltRhalf+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                     = AD_Half <$> newArrayData' size+  ptrsOfArrayData      (AD_Half ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Half ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Half ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Half ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Half ba) i e = unsafeWriteArray ba i e++instance ArrayElt Float where+  type ArrayPtrs Float = Ptr Float+  arrayElt             = ArrayEltRfloat+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                      = AD_Float <$> newArrayData' size+  ptrsOfArrayData      (AD_Float ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Float ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Float ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Float ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Float ba) i e = unsafeWriteArray ba i e++instance ArrayElt Double where+  type ArrayPtrs Double = Ptr Double+  arrayElt              = ArrayEltRdouble+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE ptrsOfArrayData #-}+  {-# INLINE touchArrayData #-}+  {-# INLINE newArrayData #-}+  {-# INLINE unsafeReadArrayData #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                       = AD_Double <$> newArrayData' size+  ptrsOfArrayData      (AD_Double ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Double ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Double ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Double ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Double ba) i e = unsafeWriteArray ba i e++instance ArrayElt CFloat where+  type ArrayPtrs CFloat = Ptr Float+  arrayElt              = ArrayEltRcfloat+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                                = AD_CFloat <$> newArrayData' size+  ptrsOfArrayData      (AD_CFloat ba)              = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CFloat ba)              = touchUniqueArray ba+  unsafeIndexArrayData (AD_CFloat ba) i            = CFloat  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CFloat ba) i            = CFloat <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CFloat ba) i (CFloat e) = unsafeWriteArray ba i e++instance ArrayElt CDouble where+  type ArrayPtrs CDouble = Ptr Double+  arrayElt               = ArrayEltRcdouble+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                                  = AD_CDouble <$> newArrayData' size+  ptrsOfArrayData      (AD_CDouble ba)               = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CDouble ba)               = touchUniqueArray ba+  unsafeIndexArrayData (AD_CDouble ba) i             = CDouble  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CDouble ba) i             = CDouble <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CDouble ba) i (CDouble e) = unsafeWriteArray ba i e++-- Bool arrays are stored as arrays of bytes. While this is memory inefficient,+-- it is better suited to parallel backends than a packed bit-vector+-- representation.+--+instance ArrayElt Bool where+  type ArrayPtrs Bool = Ptr Word8+  arrayElt            = ArrayEltRbool+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                     = AD_Bool <$> newArrayData' size+  ptrsOfArrayData      (AD_Bool ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Bool ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Bool ba) i   = toBool  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Bool ba) i   = toBool <$> unsafeReadArray ba i+  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+  arrayElt            = ArrayEltRchar+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                     = AD_Char <$> newArrayData' size+  ptrsOfArrayData      (AD_Char ba)     = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_Char ba)     = touchUniqueArray ba+  unsafeIndexArrayData (AD_Char ba) i   = unsafeIndexArray ba i+  unsafeReadArrayData  (AD_Char ba) i   = unsafeReadArray ba i+  unsafeWriteArrayData (AD_Char ba) i e = unsafeWriteArray ba i e++instance ArrayElt CChar where+  type ArrayPtrs CChar = Ptr HTYPE_CCHAR+  arrayElt             = ArrayEltRcchar+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                              = AD_CChar <$> newArrayData' size+  ptrsOfArrayData      (AD_CChar ba)             = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CChar ba)             = touchUniqueArray ba+  unsafeIndexArrayData (AD_CChar ba) i           = CChar  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CChar ba) i           = CChar <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CChar ba) i (CChar e) = unsafeWriteArray ba i e++instance ArrayElt CSChar where+  type ArrayPtrs CSChar = Ptr Int8+  arrayElt              = ArrayEltRcschar+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                                = AD_CSChar <$> newArrayData' size+  ptrsOfArrayData      (AD_CSChar ba)              = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CSChar ba)              = touchUniqueArray ba+  unsafeIndexArrayData (AD_CSChar ba) i            = CSChar  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CSChar ba) i            = CSChar <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CSChar ba) i (CSChar e) = unsafeWriteArray ba i e++instance ArrayElt CUChar where+  type ArrayPtrs CUChar = Ptr Word8+  arrayElt              = ArrayEltRcuchar+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  newArrayData size                                = AD_CUChar <$> newArrayData' size+  ptrsOfArrayData      (AD_CUChar ba)              = unsafeUniqueArrayPtr ba+  touchArrayData       (AD_CUChar ba)              = touchUniqueArray ba+  unsafeIndexArrayData (AD_CUChar ba) i            = CUChar  $! unsafeIndexArray ba i+  unsafeReadArrayData  (AD_CUChar ba) i            = CUChar <$> unsafeReadArray ba i+  unsafeWriteArrayData (AD_CUChar ba) i (CUChar e) = unsafeWriteArray ba i e++instance ArrayElt a => ArrayElt (V2 a) where+  type ArrayPtrs (V2 a) = ArrayPtrs a+  arrayElt              = ArrayEltRvec2 arrayElt+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  ptrsOfArrayData (AD_V2 ba) = ptrsOfArrayData ba+  touchArrayData  (AD_V2 ba) = touchArrayData ba+  newArrayData size          = AD_V2 <$> newArrayData (2 * size)++  unsafeIndexArrayData (AD_V2 ba) ix =+    let ix' = 2*ix+    in  V2 (unsafeIndexArrayData ba ix')+           (unsafeIndexArrayData ba (ix'+1))++  unsafeReadArrayData (AD_V2 ba) ix =+    let ix' = 2*ix+    in  V2 <$> unsafeReadArrayData ba ix'+           <*> unsafeReadArrayData ba (ix'+1)++  unsafeWriteArrayData (AD_V2 ba) ix (V2 a b) =+    let ix' = 2*ix+    in do unsafeWriteArrayData ba ix'     a+          unsafeWriteArrayData ba (ix'+1) b++instance ArrayElt a => ArrayElt (V3 a) where+  type ArrayPtrs (V3 a) = ArrayPtrs a+  arrayElt              = ArrayEltRvec3 arrayElt+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  ptrsOfArrayData (AD_V3 ba) = ptrsOfArrayData ba+  touchArrayData  (AD_V3 ba) = touchArrayData ba+  newArrayData size          = AD_V3 <$> newArrayData (3 * size)++  unsafeIndexArrayData (AD_V3 ba) ix =+    let ix' = 3*ix+    in  V3 (unsafeIndexArrayData ba ix')+           (unsafeIndexArrayData ba (ix'+1))+           (unsafeIndexArrayData ba (ix'+2))++  unsafeReadArrayData (AD_V3 ba) ix =+    let ix' = 3*ix+    in  V3 <$> unsafeReadArrayData ba ix'+           <*> unsafeReadArrayData ba (ix'+1)+           <*> unsafeReadArrayData ba (ix'+2)++  unsafeWriteArrayData (AD_V3 ba) ix (V3 a b c) =+    let ix' = 3*ix+    in do unsafeWriteArrayData ba ix'     a+          unsafeWriteArrayData ba (ix'+1) b+          unsafeWriteArrayData ba (ix'+3) c++instance ArrayElt a => ArrayElt (V4 a) where+  type ArrayPtrs (V4 a) = ArrayPtrs a+  arrayElt              = ArrayEltRvec4 arrayElt+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  ptrsOfArrayData (AD_V4 ba) = ptrsOfArrayData ba+  touchArrayData  (AD_V4 ba) = touchArrayData ba+  newArrayData size          = AD_V4 <$> newArrayData (4 * size)++  unsafeIndexArrayData (AD_V4 ba) ix =+    let ix' = 4*ix+    in  V4 (unsafeIndexArrayData ba ix')+           (unsafeIndexArrayData ba (ix'+1))+           (unsafeIndexArrayData ba (ix'+2))+           (unsafeIndexArrayData ba (ix'+3))++  unsafeReadArrayData (AD_V4 ba) ix =+    let ix' = 4*ix+    in  V4 <$> unsafeReadArrayData ba ix'+           <*> unsafeReadArrayData ba (ix'+1)+           <*> unsafeReadArrayData ba (ix'+2)+           <*> unsafeReadArrayData ba (ix'+3)++  unsafeWriteArrayData (AD_V4 ba) ix (V4 a b c d) =+    let ix' = 4*ix+    in do unsafeWriteArrayData ba ix'     a+          unsafeWriteArrayData ba (ix'+1) b+          unsafeWriteArrayData ba (ix'+2) c+          unsafeWriteArrayData ba (ix'+3) d++instance ArrayElt a => ArrayElt (V8 a) where+  type ArrayPtrs (V8 a) = ArrayPtrs a+  arrayElt              = ArrayEltRvec8 arrayElt+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  ptrsOfArrayData (AD_V8 ba) = ptrsOfArrayData ba+  touchArrayData  (AD_V8 ba) = touchArrayData ba+  newArrayData size          = AD_V8 <$> newArrayData (8 * size)++  unsafeIndexArrayData (AD_V8 ba) ix =+    let ix' = 8*ix+    in  V8 (unsafeIndexArrayData ba ix')+           (unsafeIndexArrayData ba (ix'+1))+           (unsafeIndexArrayData ba (ix'+2))+           (unsafeIndexArrayData ba (ix'+3))+           (unsafeIndexArrayData ba (ix'+4))+           (unsafeIndexArrayData ba (ix'+5))+           (unsafeIndexArrayData ba (ix'+6))+           (unsafeIndexArrayData ba (ix'+7))++  unsafeReadArrayData (AD_V8 ba) ix =+    let ix' = 8*ix+    in  V8 <$> unsafeReadArrayData ba ix'+           <*> unsafeReadArrayData ba (ix'+1)+           <*> unsafeReadArrayData ba (ix'+2)+           <*> unsafeReadArrayData ba (ix'+3)+           <*> unsafeReadArrayData ba (ix'+4)+           <*> unsafeReadArrayData ba (ix'+5)+           <*> unsafeReadArrayData ba (ix'+6)+           <*> unsafeReadArrayData ba (ix'+7)++  unsafeWriteArrayData (AD_V8 ba) ix (V8 a b c d e f g h) =+    let ix' = 8*ix+    in do unsafeWriteArrayData ba ix'     a+          unsafeWriteArrayData ba (ix'+1) b+          unsafeWriteArrayData ba (ix'+2) c+          unsafeWriteArrayData ba (ix'+3) d+          unsafeWriteArrayData ba (ix'+4) e+          unsafeWriteArrayData ba (ix'+5) f+          unsafeWriteArrayData ba (ix'+6) g+          unsafeWriteArrayData ba (ix'+7) h++instance ArrayElt a => ArrayElt (V16 a) where+  type ArrayPtrs (V16 a) = ArrayPtrs a+  arrayElt               = ArrayEltRvec16 arrayElt+  {-# INLINE newArrayData         #-}+  {-# INLINE ptrsOfArrayData      #-}+  {-# INLINE touchArrayData       #-}+  {-# INLINE unsafeIndexArrayData #-}+  {-# INLINE unsafeReadArrayData  #-}+  {-# INLINE unsafeWriteArrayData #-}+  ptrsOfArrayData (AD_V16 ba) = ptrsOfArrayData ba+  touchArrayData  (AD_V16 ba) = touchArrayData ba+  newArrayData size           = AD_V16 <$> newArrayData (16 * size)++  unsafeIndexArrayData (AD_V16 ba) ix =+    let ix' = 16*ix+    in  V16 (unsafeIndexArrayData ba ix')+            (unsafeIndexArrayData ba (ix'+1))+            (unsafeIndexArrayData ba (ix'+2))+            (unsafeIndexArrayData ba (ix'+3))+            (unsafeIndexArrayData ba (ix'+4))+            (unsafeIndexArrayData ba (ix'+5))+            (unsafeIndexArrayData ba (ix'+6))+            (unsafeIndexArrayData ba (ix'+7))+            (unsafeIndexArrayData ba (ix'+8))+            (unsafeIndexArrayData ba (ix'+9))+            (unsafeIndexArrayData ba (ix'+10))+            (unsafeIndexArrayData ba (ix'+11))+            (unsafeIndexArrayData ba (ix'+12))+            (unsafeIndexArrayData ba (ix'+13))+            (unsafeIndexArrayData ba (ix'+14))+            (unsafeIndexArrayData ba (ix'+15))++  unsafeReadArrayData (AD_V16 ba) ix =+    let ix' = 16*ix+    in  V16 <$> unsafeReadArrayData ba ix'+            <*> unsafeReadArrayData ba (ix'+1)+            <*> unsafeReadArrayData ba (ix'+2)+            <*> unsafeReadArrayData ba (ix'+3)+            <*> unsafeReadArrayData ba (ix'+4)+            <*> unsafeReadArrayData ba (ix'+5)+            <*> unsafeReadArrayData ba (ix'+6)+            <*> unsafeReadArrayData ba (ix'+7)+            <*> unsafeReadArrayData ba (ix'+8)+            <*> unsafeReadArrayData ba (ix'+9)+            <*> unsafeReadArrayData ba (ix'+10)+            <*> unsafeReadArrayData ba (ix'+11)+            <*> unsafeReadArrayData ba (ix'+12)+            <*> unsafeReadArrayData ba (ix'+13)+            <*> unsafeReadArrayData ba (ix'+14)+            <*> unsafeReadArrayData ba (ix'+15)++  unsafeWriteArrayData (AD_V16 ba) ix (V16 a b c d e f g h i j k l m n o p) =+    let ix' = 16*ix+    in do unsafeWriteArrayData ba ix'     a+          unsafeWriteArrayData ba (ix'+1) b+          unsafeWriteArrayData ba (ix'+2) c+          unsafeWriteArrayData ba (ix'+3) d+          unsafeWriteArrayData ba (ix'+4) e+          unsafeWriteArrayData ba (ix'+5) f+          unsafeWriteArrayData ba (ix'+6) g+          unsafeWriteArrayData ba (ix'+7) h+          unsafeWriteArrayData ba (ix'+8) i+          unsafeWriteArrayData ba (ix'+9) j+          unsafeWriteArrayData ba (ix'+10) k+          unsafeWriteArrayData ba (ix'+11) l+          unsafeWriteArrayData ba (ix'+12) m+          unsafeWriteArrayData ba (ix'+13) n+          unsafeWriteArrayData ba (ix'+14) o+          unsafeWriteArrayData ba (ix'+15) p++instance (ArrayElt a, ArrayElt b) => ArrayElt (a, b) where+  type ArrayPtrs (a, b) = (ArrayPtrs a, ArrayPtrs b)+  arrayElt              = ArrayEltRpair arrayElt arrayElt+  {-# INLINE newArrayData           #-}+  {-# INLINE ptrsOfArrayData        #-}+  {-# INLINE ptrsOfMutableArrayData #-}+  {-# INLINE touchArrayData         #-}+  {-# INLINE unsafeFreezeArrayData  #-}+  {-# INLINE unsafeIndexArrayData   #-}+  {-# INLINE unsafeReadArrayData    #-}+  {-# INLINE unsafeWriteArrayData   #-}+  newArrayData size                             = AD_Pair <$> newArrayData size <*> newArrayData size+  touchArrayData         (AD_Pair a b)          = touchArrayData a >> touchArrayData b+  ptrsOfArrayData        (AD_Pair a b)          = (ptrsOfArrayData a, ptrsOfArrayData b)+  ptrsOfMutableArrayData (AD_Pair a b)          = (,) <$> ptrsOfMutableArrayData a <*> ptrsOfMutableArrayData b+  unsafeReadArrayData    (AD_Pair a b) i        = (,) <$> unsafeReadArrayData a i <*> unsafeReadArrayData b i+  unsafeIndexArrayData   (AD_Pair a b) i        = (unsafeIndexArrayData a i, unsafeIndexArrayData b i)+  unsafeWriteArrayData   (AD_Pair a b) i (x, y) = unsafeWriteArrayData a i x >> unsafeWriteArrayData b i y+  unsafeFreezeArrayData  (AD_Pair a b)          = AD_Pair <$> unsafeFreezeArrayData a <*> unsafeFreezeArrayData b+++-- 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+-- -------------------++{-# 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.+--+{-# 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 :: Storable e => UniqueArray e -> Int -> e+unsafeIndexArray ua i =+  unsafePerformIO $! unsafeReadArray ua i++-- Read an element from a mutable array at the given index. This does no bounds+-- checking.+--+{-# INLINE unsafeReadArray #-}+unsafeReadArray :: Storable e => UniqueArray e -> Int -> IO e+unsafeReadArray ua i =+  withUniqueArrayPtr ua $ \ptr -> peekElemOff ptr i++-- Write an element into a mutable array at the given index. This does no bounds+-- checking.+--+{-# INLINE unsafeWriteArray #-}+unsafeWriteArray :: Storable e => UniqueArray e -> Int -> e -> IO ()+unsafeWriteArray ua i e =+  withUniqueArrayPtr ua $ \ptr -> pokeElemOff ptr i e++-- Allocate a new array with enough storage to hold the given number of+-- elements.+--+-- 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)+      didAllocateBytesLocal (fromIntegral bytes)+      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+--+{-# INLINE mallocPlainForeignPtrBytesAligned #-}+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#) #)+
+ src/Data/Array/Accelerate/Array/Lifted.hs view
@@ -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+-}+
+ src/Data/Array/Accelerate/Array/Remote.hs view
@@ -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+
+ src/Data/Array/Accelerate/Array/Remote/Class.hs view
@@ -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+
+ src/Data/Array/Accelerate/Array/Remote/LRU.hs view
@@ -0,0 +1,428 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DoAndIfThenElse     #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# 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 Control.Concurrent.MVar                                  ( MVar, newMVar, withMVar, takeMVar, putMVar, mkWeakMVar )+import Control.Monad                                            ( filterM )+import Control.Monad.Catch+import Control.Monad.IO.Class                                   ( MonadIO, liftIO )+import Data.Functor+import Data.Int                                                 ( Int64 )+import Data.Maybe                                               ( isNothing )+import Data.Proxy+import Foreign.Storable                                         ( sizeOf )+import System.CPUTime+import System.Mem.Weak                                          ( Weak, deRefWeak, finalize )+import Prelude                                                  hiding ( lookup )+import qualified Data.HashTable.IO                              as HT++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 Data.Array.Accelerate.Error                              ( internalError )+import qualified Data.Array.Accelerate.Array.Remote.Table       as Basic+import qualified Data.Array.Accelerate.Debug                    as D+++-- 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.CuckooHashTable 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 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.mutate utbl key $ \case+      Nothing -> (Nothing,           Nothing)+      Just u  -> (Just (incCount u), Just u)+    --+    case mu of+      Nothing -> do+        message ("withRemote/array has never been malloc'd: " ++ show key)+        return Nothing -- The array was never in the table++      Just u  -> do+        mp  <- liftIO $ Basic.lookup mt arr+        ptr <- case mp of+                 Just p          -> return p+                 Nothing+                   | isEvicted u -> copyBack utbl (incCount u)+                   | otherwise   -> do message ("lost array " ++ show key)+                                       $internalError "withRemote" "non-evicted array has been lost"+        return (Just ptr)+  --+  case mp of+    Nothing  -> return Nothing+    Just ptr -> Just <$> go key ptr+  where+    updateTask :: Used task -> task -> IO (Used task)+    updateTask (Used _ status count tasks n weak_arr) task = do+      ts      <- getCPUTime+      tasks'  <- cleanUses tasks+      return (Used ts status (count - 1) (task : tasks') n weak_arr)++    copyBack :: UT task -> Used task -> m (RemotePtr m b)+    copyBack 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++    -- We can't combine the use of `withMVar ref` above with the one here+    -- because the `permute` operation from the PTX backend requires nested+    -- calls to `withRemote` in order to copy the defaults array.+    --+    go :: StableArray -> RemotePtr m b -> m c+    go key ptr = do+      message ("withRemote/using: " ++ show key)+      (task, c) <- run ptr+      liftIO . withMVar ref  $ \utbl -> do+        HT.mutateIO utbl key $ \case+          Nothing -> $internalError "withRemote" "invariant violated"+          Just u  -> do+            u' <- updateTask u task+            return (Just u', ())+        --+        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 that the array 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 this function is called on an array that is already contained within the+-- cache, this is 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                              -- ^ Was the array allocated successfully?+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 $ D.didEvictBytes (remoteBytes n weak_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++    remoteBytes :: forall e a. PrimElt e a => Int -> Weak (ArrayData e) -> Int64+    remoteBytes n _ = fromIntegral n * fromIntegral (sizeOf (undefined::a))++    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 = HT.delete+++-- |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++{-# INLINE withMVar' #-}+withMVar' :: (MonadIO m, MonadMask m) => MVar a -> (a -> m b) -> m b+withMVar' m f =+  mask $ \restore -> do+    a <- takeMVar' m+    b <- restore (f a) `onException` putMVar' m a+    putMVar' m a+    return b++{-# INLINE putMVar' #-}+putMVar' :: (MonadIO m, MonadMask m) => MVar a -> a -> m ()+putMVar' m a = liftIO (putMVar m a)++{-# INLINE takeMVar' #-}+takeMVar' :: (MonadIO m, MonadMask m) => MVar a -> m a+takeMVar' m = liftIO (takeMVar m)+++-- 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)+
+ src/Data/Array/Accelerate/Array/Remote/Nursery.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE LambdaCase      #-}+{-# 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 Debug++-- libraries+import Control.Concurrent.MVar+import Data.Int+import Data.Sequence                                            ( Seq )+import Data.Word+import System.Mem.Weak                                          ( Weak )+import Prelude                                                  hiding ( lookup )+import qualified Data.HashTable.IO                              as HT+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.+--+type HashTable key val  = HT.CuckooHashTable key val+type NRS ptr            = MVar ( HashTable Int (Seq (ptr Word8)) )  -- #bytes -> available memory+data Nursery ptr        = Nursery {-# UNPACK #-} !(NRS ptr)+                                  {-# UNPACK #-} !(Weak (NRS ptr))+++-- | 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"+  nrs    <- HT.new+  ref    <- newMVar nrs+  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 !_) =+  withMVar ref $ \nrs ->+    HT.mutateIO nrs key $ \case+      Nothing -> return (Nothing, Nothing)+      Just r  ->+        case Seq.viewl r of+          v Seq.:< vs -> do+            Debug.decreaseCurrentBytesNursery (fromIntegral key)+            if Seq.null vs+              then return (Nothing, Just v)   -- delete this entry from the map+              else return (Just vs, Just v)   -- re-insert the tail+          --+          Seq.EmptyL  -> $internalError "lookup" "expected non-empty sequence"+++-- | Add an entry to the nursery+--+{-# INLINEABLE insert #-}+insert :: Int -> ptr Word8 -> Nursery ptr -> IO ()+insert !key !val (Nursery !ref _) =+  withMVar ref $ \nrs -> do+    Debug.increaseCurrentBytesRemote (fromIntegral key)+    HT.mutate nrs key $ \case+      Nothing -> (Just (Seq.singleton val), ())+      Just vs -> (Just (vs Seq.|> val),     ())+++-- | Delete all entries from the nursery+--+{-# INLINEABLE cleanup #-}+cleanup :: (ptr Word8 -> IO ()) -> NRS ptr -> IO ()+cleanup delete !ref = do+  message "nursery cleanup"+  modifyMVar_ ref $ \nrs -> do+    HT.mapM_ (Seq.mapM delete . snd) nrs+    Debug.setCurrentBytesNursery 0+    nrs'   <- HT.new+    return nrs'+++-- | The total number of bytes retained by the nursery+--+{-# INLINEABLE size #-}+size :: Nursery ptr -> IO Int64+size (Nursery ref _)+  = withMVar ref+  $ HT.foldM (\s (k,v) -> return $ s + fromIntegral (k * (Seq.length v))) 0+++-- Debug+-- -----++{-# INLINE message #-}+message :: String -> IO ()+message msg = Debug.traceIO Debug.dump_gc ("gc: " ++ msg)+
+ src/Data/Array/Accelerate/Array/Remote/Table.hs view
@@ -0,0 +1,487 @@+{-# 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.CuckooHashTable 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 ->+  HT.mutateIO mt sa $ \mw -> do+    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+        D.decreaseCurrentBytesRemote (fromIntegral bytes)++    return (Nothing, ())+++-- 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  $ D.increaseCurrentBytesRemote (fromIntegral bytes)+  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.+  --+  D.didRemoteGC+  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 :: (ArrayPtrs e ~ Ptr a) => 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 ArrayEltRhalf      (AD_Half 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 (ArrayEltRvec2 r)  (AD_V2 a)       = id r a+    id (ArrayEltRvec3 r)  (AD_V3 a)       = id r a+    id (ArrayEltRvec4 r)  (AD_V4 a)       = id r a+    id (ArrayEltRvec8 r)  (AD_V8 a)       = id r a+    id (ArrayEltRvec16 r) (AD_V16 a)      = id r a+#if __GLASGOW_HASKELL__ < 800+    id _ _ =+      error "I do have a cause, though. It is obscenity. I'm for it."+#endif++-- 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 :: (ArrayPtrs e' ~ Ptr a) => 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 ArrayEltRhalf      (AD_Half 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+    mw (ArrayEltRvec2 r)  (AD_V2 a)       = mw r a+    mw (ArrayEltRvec3 r)  (AD_V3 a)       = mw r a+    mw (ArrayEltRvec4 r)  (AD_V4 a)       = mw r a+    mw (ArrayEltRvec8 r)  (AD_V8 a)       = mw r a+    mw (ArrayEltRvec16 r) (AD_V16 a)      = mw r a+#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+
+ src/Data/Array/Accelerate/Array/Representation.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Representation+-- 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.Representation (++  -- * Array shapes, indices, and slices+  Shape(..), Slice(..), SliceIndex(..),++  -- * Slice shape functions+  sliceShape, enumSlices,++) where++-- friends+import Data.Array.Accelerate.Error++-- standard library+import GHC.Base                                         ( quotInt, remInt )+++-- |Index representation+--++-- |Class of index representations (which are nested pairs)+--+class (Eq sh, Slice sh) => Shape sh where+  -- user-facing methods+  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)+  fromIndex :: sh -> Int -> sh -- inverse of `toIndex`++  iter      :: sh -> (sh -> a) -> (a -> a -> a) -> a -> a+                               -- iterate through the entire shape, applying the function in the+                               -- second argument; third argument combines results and fourth is an+                               -- initial value that is combined with the results; the index space+                               -- is traversed in row-major order++  iter1     :: sh -> (sh -> a) -> (a -> a -> a) -> a+                               -- variant of 'iter' without an initial value++  -- operations to facilitate conversion with IArray+  rangeToShape :: (sh, sh) -> sh   -- convert a minpoint-maxpoint index+                                   -- into a shape+  shapeToRange :: sh -> (sh, sh)   -- ...the converse+++  -- other conversions+  shapeToList :: sh -> [Int]    -- convert a shape into its list of dimensions+  listToShape :: [Int] -> sh    -- convert a list of dimensions into a shape++instance Shape () where+  rank _            = 0+  empty             = ()+  ignore            = ()+  () `intersect` () = ()+  () `union` ()     = ()+  size ()           = 1+  toIndex () ()     = 0+  fromIndex () _    = ()+  iter  () f _ _    = f ()+  iter1 () f _      = f ()++  rangeToShape ((), ()) = ()+  shapeToRange ()       = ((), ())++  shapeToList () = []+  listToShape [] = ()+  listToShape _  = $internalError "listToShape" "non-empty list when converting to unit"++instance Shape sh => Shape (sh, Int) where+  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++  fromIndex (sh, sz) i              = (fromIndex sh (i `quotInt` sz), r)+    -- If we assume that the index is in range, there is no point in computing+    -- the remainder for the highest dimension since i < sz must hold.+    --+    where+      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      -> next `addDim` 0+                                        Mirror     -> next `addDim` (-i)+                                        Wrap       -> next `addDim` (sz+i)+                                        Constant e -> Left e+    | i >= sz                       = case bndy of+                                        Clamp      -> next `addDim` (sz-1)+                                        Mirror     -> next `addDim` (sz-(i-sz+2))+                                        Wrap       -> next `addDim` (i-sz)+                                        Constant e -> Left e+    | otherwise                     = next `addDim` i+    where+      -- This function is quite difficult to optimize due to the deep recursion+      -- that it 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+--}++  iter (sh, sz) f c r = iter sh (\ix -> iter' (ix,0)) c r+    where+      iter' (ix,i) | i >= sz   = r+                   | otherwise = f (ix,i) `c` iter' (ix,i+1)++  iter1 (_,  0)  _ _ = $boundsError "iter1" "empty iteration space"+  iter1 (sh, sz) f c = iter1 sh (\ix -> iter1' (ix,0)) c+    where+      iter1' (ix,i) | i == sz-1 = f (ix,i)+                    | otherwise = f (ix,i) `c` iter1' (ix,i+1)++  rangeToShape ((sh1, sz1), (sh2, sz2))+    = (rangeToShape (sh1, sh2), sz2 - sz1 + 1)+  shapeToRange (sh, sz)+    = let (low, high) = shapeToRange sh+      in+      ((low, 0), (high, sz - 1))++  shapeToList (sh,sz) = sz : shapeToList sh+  listToShape []      = $internalError "listToShape" "empty list when converting to Ix"+  listToShape (x:xs)  = (listToShape xs,x)+++-- |Slice representation+--++-- |Class of slice representations (which are nested pairs)+--+class Slice sl where+  type SliceShape    sl      -- the projected slice+  type CoSliceShape  sl      -- the complement of the slice+  type FullShape     sl      -- the combined dimension+    -- argument *value* not used; it's just a phantom value to fix the type+  sliceIndex :: {-dummy-} sl -> SliceIndex sl (SliceShape sl) (CoSliceShape sl) (FullShape sl)++instance Slice () where+  type SliceShape    () = ()+  type CoSliceShape  () = ()+  type FullShape     () = ()+  sliceIndex _ = SliceNil++instance Slice sl => Slice (sl, ()) where+  type SliceShape   (sl, ()) = (SliceShape  sl, Int)+  type CoSliceShape (sl, ()) = CoSliceShape sl+  type FullShape    (sl, ()) = (FullShape   sl, Int)+  sliceIndex _ = 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 _ = SliceFixed (sliceIndex (undefined::sl))++-- |Generalised array index, which may index only in a subset of the dimensions+-- of a shape.+--+data SliceIndex ix slice coSlice sliceDim where+  SliceNil   :: SliceIndex () () () ()+  SliceAll   ::+   SliceIndex ix slice co dim -> SliceIndex (ix, ()) (slice, Int) co (dim, Int)+  SliceFixed ::+   SliceIndex ix slice co dim -> SliceIndex (ix, Int) slice (co, Int) (dim, Int)++instance Show (SliceIndex ix slice coSlice sliceDim) where+  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]]+
+ src/Data/Array/Accelerate/Array/Sugar.hs view
@@ -0,0 +1,1381 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#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, Matrix, 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, reshape, (!), (!!), allocateArray, fromFunction, fromFunctionM, 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.Typeable+import GHC.Exts                                                 ( IsList )+import System.IO.Unsafe                                         ( unsafePerformIO )+import Prelude                                                  hiding ( (!!) )+import Language.Haskell.TH                                      hiding ( Foreign )+import qualified GHC.Exts                                       as GHC+import qualified Data.Vector.Unboxed                            as U++-- friends+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Type+import qualified Data.Array.Accelerate.Array.Representation     as Repr++-- $setup+-- >>> :seti -XOverloadedLists++-- 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+-- ---------------------------------------------+--+-- TLM: Why is EltRepr not an associated type of Elt?+--++-- | 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 Half            = Half+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 (V2 a)          = V2 a    -- we can only store primitive types in SIMD vectors+type instance EltRepr (V3 a)          = V3 a+type instance EltRepr (V4 a)          = V4 a+type instance EltRepr (V8 a)          = V8 a+type instance EltRepr (V16 a)         = V16 a+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 instance EltRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = 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, EltRepr p)++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 (half, 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 _ = TypeRunit+  fromElt   = id+  toElt     = id++instance Elt Z where+  eltType _  = TypeRunit+  fromElt Z  = ()+  toElt ()   = Z++instance (Elt t, Elt h) => Elt (t:.h) where+  eltType (_::(t:.h))   = TypeRpair (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 _     = TypeRunit+  fromElt All   = ()+  toElt ()      = All++instance Elt (Any Z) where+  eltType _     = TypeRunit+  fromElt _     = ()+  toElt _       = Any++instance Shape sh => Elt (Any (sh:.Int)) where+  eltType _     = TypeRpair (eltType (undefined::Any sh)) TypeRunit+  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 Half 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 _             = TypeRpair (TypeRpair TypeRunit (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 _             = TypeRpair (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 _             = TypeRpair (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 _               = TypeRpair (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 _+    = TypeRpair (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 _+    = TypeRpair (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 _+    = TypeRpair (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 _+    = TypeRpair (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 _+    = TypeRpair (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 _+    = TypeRpair (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 _+    = TypeRpair (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 _+    = TypeRpair (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 _+    = TypeRpair (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 _+    = TypeRpair (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)++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 p)+  => Elt (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where+  eltType _+    = TypeRpair (eltType (undefined :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)))+                (eltType (undefined :: p))+  fromElt (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = (fromElt (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o), fromElt p)+  toElt (abcdefghijklmno, p) = let (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = toElt abcdefghijklmno+                               in  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, toElt p)++-- |Convenience functions+--++singletonScalarType :: IsScalar a => a -> TupleType a+singletonScalarType _ = TypeRscalar scalarType++{-# INLINE liftToElt #-}+liftToElt :: (Elt a, Elt b)+          => (EltRepr a -> EltRepr b)+          -> (a -> b)+liftToElt f = toElt . f . fromElt++{-# INLINE liftToElt2 #-}+liftToElt2 :: (Elt a, Elt b, Elt c)+           => (EltRepr a -> EltRepr b -> EltRepr c)+           -> (a -> b -> c)+liftToElt2 f x y = toElt $ f (fromElt x) (fromElt y)++{-# INLINE sinkFromElt #-}+sinkFromElt :: (Elt a, Elt b)+            => (a -> b)+            -> (EltRepr a -> EltRepr b)+sinkFromElt f = fromElt . f . toElt++{-# INLINE sinkFromElt2 #-}+sinkFromElt2 :: (Elt a, Elt b, Elt c)+             => (a -> b -> c)+             -> (EltRepr a -> EltRepr b -> EltRepr c)+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+  strForeign _ = "<foreign>"++  -- Backends which want to support compile-time embedding must be able to lift+  -- the foreign function into Template Haskell+  liftForeign :: asm args -> Q (TExp (asm args))+  liftForeign _ = $internalError "liftForeign" "not supported by this backend"+++-- 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 instance ArrRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = 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, ArrRepr p)++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)++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 p)+  => Arrays (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where+  arrays  _             = ArraysRpair (arrays (undefined :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o))) (arrays (undefined::p))+  flavour _             = ArraysFtuple+  --+  toArr    (abcdefghijklmno, p) = let (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = toArr abcdefghijklmno in (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, toArr p)+  fromArr  (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = (fromArr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o), fromArr p)+++-- {-# 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+    where+      Z :. rows :. cols = shape arr+      lengths           = U.generate (rows*cols) (\i -> length (show (arr !! i)))+      widths            = U.generate cols (\c -> U.maximum (U.generate rows (\r -> lengths U.! (r*cols+c))))+      --+      showMat+        | rows * cols == 0 = "[]"+        | otherwise        = "\n  [" ++ ppMat 0 0+      --+      ppMat :: Int -> Int -> String+      ppMat !r !c | c >= cols = ppMat (r+1) 0+      ppMat !r !c             =+        let+            !i    = r*cols+c+            !l    = lengths U.! i+            !w    = widths  U.! c+            !pad  = 1+            cell  = replicate (w-l+pad) ' ' ++ show (arr !! i)+            --+            before+              | r > 0 && c == 0 = "\n   "+              | otherwise       = ""+            --+            after+              | r >= rows-1 && c >= cols-1 = "]"+              | otherwise                  = ',' : ppMat r (c+1)+        in+        before ++ cell ++ after+#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 ArrayEltRhalf         (AD_Half 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 (ArrayEltRvec2 r)     (AD_V2 a)       = go r a `seq` ()+      go (ArrayEltRvec3 r)     (AD_V3 a)       = go r a `seq` ()+      go (ArrayEltRvec4 r)     (AD_V4 a)       = go r a `seq` ()+      go (ArrayEltRvec8 r)     (AD_V8 a)       = go r a `seq` ()+      go (ArrayEltRvec16 r)    (AD_V16 a)      = go r a `seq` ()+      go (ArrayEltRpair r1 r2) (AD_Pair a1 a2) = go r1 a1 `seq` go r2 a2 `seq` ()+++-- | Scalar arrays hold a single element+--+type Scalar = Array DIM0++-- | Vectors are one-dimensional arrays+--+type Vector = Array DIM1++-- | Matrices are two-dimensional arrays+--+type Matrix = Array DIM2++-- | 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 = Vector++-- 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++  -- |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)++  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++-- | Change the shape of an array without altering its contents. The 'size' of+-- the source and result arrays must be identical.+--+reshape :: (Shape sh, Shape sh', Elt e) => sh -> Array sh' e -> Array sh e+reshape sh (Array sh' adata)+  = $boundsCheck "reshape" "shape mismatch" (size sh == Repr.size sh')+  $ Array (fromElt sh) adata++-- | Array indexing+--+infixl 9 !+{-# INLINE (!) #-}+(!) :: Array sh e -> sh -> e+(!) (Array sh adata) ix = toElt (adata `unsafeIndexArrayData` toIndex (toElt sh) ix)++infixl 9 !!+{-# INLINE (!!) #-}+(!!) :: Array sh e -> Int -> e+(!!) (Array _ adata) i = toElt (adata `unsafeIndexArrayData` i)++-- | Create an array from its representation function, applied at each index of+-- the array.+--+{-# INLINEABLE fromFunction #-}+fromFunction :: (Shape sh, Elt e) => sh -> (sh -> e) -> Array sh e+fromFunction sh f = unsafePerformIO $! fromFunctionM sh (return . f)++-- | Create an array using a monadic function applied at each index.+--+{-# INLINEABLE fromFunctionM #-}+fromFunctionM :: (Shape sh, Elt e) => sh -> (sh -> IO e) -> IO (Array sh e)+fromFunctionM sh f = do+  let !n = size sh+  arr <- newArrayData n+  --+  let write !i+        | i >= n    = return ()+        | otherwise = do+            v <- f (fromIndex sh i)+            unsafeWriteArrayData arr i (fromElt v)+            write (i+1)+  --+  write 0+  return $! arr `seq` Array (fromElt sh) arr+++-- | Create a vector from the concatenation of the given list of vectors.+--+{-# INLINEABLE concatVectors #-}+concatVectors :: Elt e => [Vector e] -> Vector e+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.+--+{-# INLINEABLE allocateArray #-}+allocateArray :: (Shape sh, Elt e) => sh -> IO (Array sh e)+allocateArray sh = do+  adata  <- newArrayData (size sh)+  return $! Array (fromElt sh) adata+++-- | 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) :: Matrix 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.+--+{-# INLINEABLE fromList #-}+fromList :: (Shape sh, Elt e) => sh -> [e] -> Array sh e+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.+--+{-# INLINEABLE toList #-}+toList :: forall sh e. Array sh e -> [e]+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+++-- | Orphans+--+deriving instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p)+  => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+
+ src/Data/Array/Accelerate/Array/Unique.hs view
@@ -0,0 +1,98 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Array.Unique+-- Copyright   : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, 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.Unique (++  UniqueArray(..),+  newUniqueArray,+  withUniqueArrayPtr,+  unsafeUniqueArrayPtr,+  touchUniqueArray,++) where++-- library+import Control.Applicative+import Control.Concurrent.Unique+import Control.DeepSeq+import Foreign.ForeignPtr+import Foreign.ForeignPtr.Unsafe+import Foreign.Ptr+import Prelude++-- friends+import Data.Array.Accelerate.Lifetime+++-- | A uniquely identifiable array.+--+-- For the purposes of memory management, we use arrays as keys in a table. For+-- this reason we need a way to uniquely identify each array we create. We do+-- this by attaching a unique identifier to each array.+--+-- Note: [Unique array strictness]+--+-- The actual array data is in many cases unnecessary. For discrete memory+-- backends such as for GPUs, we require the unique identifier to track the data+-- in the remote memory space, but the data will in most cases never be copied+-- back to the host. Thus, the array payload field is only lazily allocated, and+-- we should be careful not to make this field overly strict.+--+data UniqueArray e = UniqueArray+    { uniqueArrayId   :: {-# UNPACK #-} !Unique+    , uniqueArrayData :: {-# UNPACK #-} !(Lifetime (ForeignPtr e))+    }++instance NFData (UniqueArray e) where+  rnf (UniqueArray _ ad) = unsafeGetValue ad `seq` ()+++-- | Create a new UniqueArray+--+{-# INLINE newUniqueArray #-}+newUniqueArray :: ForeignPtr e -> IO (UniqueArray e)+newUniqueArray fp = UniqueArray <$> newUnique <*> newLifetime fp++-- | Access the pointer backing the unique array.+--+-- The array data is kept alive at least during the whole action, even if it is+-- not directly used inside. Note that it is not safe to return the pointer from+-- the action and use it after the action completes. All uses of the pointer+-- should be inside the bracketed function.+--+{-# INLINE withUniqueArrayPtr #-}+withUniqueArrayPtr :: UniqueArray a -> (Ptr a -> IO b) -> IO b+withUniqueArrayPtr ua go =+  withLifetime (uniqueArrayData ua) $ \fp -> withForeignPtr fp go+++-- | Extract the pointer backing the unique array.+--+-- This is potentially unsafe, as if the argument is the last occurrence of this+-- unique array then the finalisers will be run, potentially invalidating the+-- plain pointer just obtained.+--+-- See also: 'unsafeGetValue', 'unsafeForeignPtrToPtr'.+--+{-# INLINE unsafeUniqueArrayPtr #-}+unsafeUniqueArrayPtr :: UniqueArray a -> Ptr a+unsafeUniqueArrayPtr = unsafeForeignPtrToPtr . unsafeGetValue . uniqueArrayData+++-- | Ensure that the unique array is alive at the given place in a sequence of+-- IO actions. Note that this does not force the actual array payload.+--+-- See: [Unique array strictness]+--+{-# INLINE touchUniqueArray #-}+touchUniqueArray :: UniqueArray a -> IO ()+touchUniqueArray = touchLifetime . uniqueArrayData+
+ src/Data/Array/Accelerate/Async.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE CPP           #-}+{-# LANGUAGE MagicHash     #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Async+-- Copyright   : [2009..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.Async (++  -- * Asynchronous actions+  Async,++  -- ** Spawning+  async, asyncOn, asyncBound,++  -- ** Querying 'Async's+  wait, poll, cancel,++) where++import Control.Exception+import Control.Concurrent++import GHC.Exts+import GHC.Conc+import GHC.IO+++-- We need to execute the main thread asynchronously to give finalisers a chance+-- to run. Make sure to catch exceptions to avoid "blocked indefinitely on MVar"+-- errors.+--+data Async a = Async {-# UNPACK #-} !ThreadId+                     {-# UNPACK #-} !(MVar (Either SomeException a))++-- | Spawn an asynchronous action in a separate thread.+--+async :: IO a -> IO (Async a)+async = inline asyncUsing rawForkIO++-- | Like 'async', but using 'forkOn' internally.+--+asyncOn :: Int -> IO a -> IO (Async a)+asyncOn cpu = inline asyncUsing (rawForkOn cpu)++-- | Like 'async', but using 'forkOS' internally.+--+asyncBound :: IO a -> IO (Async a)+asyncBound = inline asyncUsing forkOS++asyncUsing :: (IO () -> IO ThreadId) -> IO a -> IO (Async a)+asyncUsing fork action = do+   var <- newEmptyMVar+   tid <- mask $ \restore ->+            fork $ try (restore action) >>= putMVar var+   return (Async tid var)++-- | Block the calling thread until the computation completes, then return the+-- result.+--+{-# INLINE wait #-}+wait :: Async a -> IO a+wait (Async _ var) = either throwIO return =<< readMVar var++-- | Test whether the asynchronous computation has already completed. If so,+-- return the result, else 'Nothing'.+--+{-# INLINE poll #-}+poll :: Async a -> IO (Maybe a)+poll (Async _ var) =+  maybe (return Nothing) (either throwIO (return . Just)) =<< tryReadMVar var++-- | Cancel a running asynchronous computation.+--+{-# INLINE cancel #-}+cancel :: Async a -> IO ()+cancel (Async tid _) = throwTo tid ThreadKilled+++-- A version of 'forkIO' that does not include the outer exception handler. This+-- saves a bit of time when we will be installing our own exception handler.+--+-- Stolen from Simon Marlow's 'async' package (BSD).+--+{-# INLINE rawForkIO #-}+rawForkIO :: IO () -> IO ThreadId+rawForkIO action = IO $ \s ->+  case fork# action s of+    (# s', tid #) -> (# s', ThreadId tid #)++{-# INLINE rawForkOn #-}+rawForkOn :: Int -> IO () -> IO ThreadId+rawForkOn (I# cpu) action = IO $ \s ->+  case forkOn# cpu action s of+    (# s', tid #) -> (# s', ThreadId tid #)+
+ src/Data/Array/Accelerate/Classes.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Module      : Data.Array.Accelerate.Classes+-- Copyright   : [2016..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)+--+-- This module provides instances for standard Haskell 98 classes where+-- possible, and provides new implementations of those classes where the types+-- do not match.+--++module Data.Array.Accelerate.Classes (++  -- *** Basic type classes+  module Eq,+  module Ord,+  module Enum,+  module Bounded,++  -- *** Numeric type classes+  module Num,+  module Real,+  module Integral,+  module Fractional,+  module Floating,+  module RealFrac,+  module RealFloat,++  -- *** Numeric conversions+  module FromIntegral,+  module ToFloating,++) where++import Data.Array.Accelerate.Classes.Bounded                        as Bounded+import Data.Array.Accelerate.Classes.Enum                           as Enum+import Data.Array.Accelerate.Classes.Eq                             as Eq+import Data.Array.Accelerate.Classes.Floating                       as Floating+import Data.Array.Accelerate.Classes.Fractional                     as Fractional+import Data.Array.Accelerate.Classes.FromIntegral                   as FromIntegral+import Data.Array.Accelerate.Classes.Integral                       as Integral+import Data.Array.Accelerate.Classes.Num                            as Num+import Data.Array.Accelerate.Classes.Ord                            as Ord+import Data.Array.Accelerate.Classes.Real                           as Real+import Data.Array.Accelerate.Classes.RealFloat                      as RealFloat+import Data.Array.Accelerate.Classes.RealFrac                       as RealFrac+import Data.Array.Accelerate.Classes.ToFloating                     as ToFloating+
+ src/Data/Array/Accelerate/Classes/Bounded.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.Bounded+-- Copyright   : [2016..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.Classes.Bounded (++  Bounded,+  P.minBound, P.maxBound,++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import qualified Prelude                                            as P+++-- | Name the upper and lower limits of a type. Types which are not totally+-- ordered may still have upper and lower bounds.+--+type Bounded a = (Elt a, P.Bounded (Exp a))+++instance P.Bounded (Exp ()) where+  minBound = constant ()+  maxBound = constant ()++instance P.Bounded (Exp Int) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Int8) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Int16) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Int32) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Int64) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Word) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Word8) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Word16) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Word32) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Word64) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CShort) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CUShort) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CInt) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CUInt) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CLong) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CULong) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CLLong) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CULLong) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Bool) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp Char) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CChar) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CSChar) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance P.Bounded (Exp CUChar) where+  minBound = mkMinBound+  maxBound = mkMaxBound++instance (Bounded a, Bounded b)+    => P.Bounded (Exp (a,b)) where+  minBound = tup2 (P.minBound, P.minBound)+  maxBound = tup2 (P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c)+    => P.Bounded (Exp (a,b,c)) where+  minBound = tup3 (P.minBound, P.minBound, P.minBound)+  maxBound = tup3 (P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d)+    => P.Bounded (Exp (a,b,c,d)) where+  minBound = tup4 (P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup4 (P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e)+    => P.Bounded (Exp (a,b,c,d,e)) where+  minBound = tup5 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup5 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f)+    => P.Bounded (Exp (a,b,c,d,e,f)) where+  minBound = tup6 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup6 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g)+    => P.Bounded (Exp (a,b,c,d,e,f,g)) where+  minBound = tup7 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup7 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, Bounded h)+    => P.Bounded (Exp (a,b,c,d,e,f,g,h)) where+  minBound = tup8 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup8 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, Bounded h, Bounded i)+    => P.Bounded (Exp (a,b,c,d,e,f,g,h,i)) where+  minBound = tup9 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup9 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, Bounded h, Bounded i, Bounded j)+    => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j)) where+  minBound = tup10 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup10 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k)+    => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k)) where+  minBound = tup11 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup11 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k, Bounded l)+    => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k,l)) where+  minBound = tup12 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup12 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m)+    => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k,l,m)) where+  minBound = tup13 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup13 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n)+    => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) where+  minBound = tup14 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup14 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n, Bounded o)+    => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) where+  minBound = tup15 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup15 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)++instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g, Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n, Bounded o, Bounded p)+    => P.Bounded (Exp (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) where+  minBound = tup16 (P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound, P.minBound)+  maxBound = tup16 (P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound, P.maxBound)+
+ src/Data/Array/Accelerate/Classes/Enum.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds    #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.Enum+-- Copyright   : [2016..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.Classes.Enum (++  Enum,+  succ, pred,++) where++import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type+import Text.Printf++import Prelude                                                      hiding ( Enum )+import qualified Prelude                                            as P+++-- | Operations over sequentially ordered types+--+type Enum a = P.Enum (Exp a)+++instance P.Enum (Exp Int) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Int8) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Int16) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Int32) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Int64) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Word) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Word8) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Word16) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Word32) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Word64) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CInt) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CUInt) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CLong) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CULong) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CLLong) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CULLong) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CShort) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CUShort) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Half) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Float) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp Double) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CFloat) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum++instance P.Enum (Exp CDouble) where+  succ x    = mkAdd x (constant 1)+  pred x    = mkSub x (constant 1)+  toEnum    = defaultToEnum+  fromEnum  = defaultFromEnum+++defaultToEnum :: Int -> a+defaultToEnum = preludeError "toEnum"++defaultFromEnum :: a -> Int+defaultFromEnum = preludeError "fromEnum"++preludeError :: String -> a+preludeError x+  = error+  $ unlines [ printf "Prelude.%s is not supported for Accelerate types" x+            , ""+            , "These Prelude.Enum instances are present only to fulfil superclass"+            , "constraints for subsequent classes in the standard Haskell numeric hierarchy."+            ]+
+ src/Data/Array/Accelerate/Classes/Eq.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.Eq+-- Copyright   : [2016..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.Classes.Eq (++  Eq(..),+  (&&),+  (||),+  not,++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Text.Printf+import Prelude                                                      ( String, error)+import qualified Prelude                                            as P+++infix 4 ==+infix 4 /=++-- | Conjunction: True if both arguments are true. This is a short-circuit+-- operator, so the second argument will be evaluated only if the first is true.+--+infixr 3 &&+(&&) :: Exp Bool -> Exp Bool -> Exp Bool+(&&) = mkLAnd++-- | Disjunction: True if either argument is true. This is a short-circuit+-- operator, so the second argument will be evaluated only if the first is+-- false.+--+infixr 2 ||+(||) :: Exp Bool -> Exp Bool -> Exp Bool+(||) = mkLOr++-- | Logical negation+--+not :: Exp Bool -> Exp Bool+not = mkLNot+++-- | The 'Eq' class defines equality '==' and inequality '/=' for scalar+-- Accelerate expressions.+--+-- For convenience, we include 'Elt' as a superclass.+--+class Elt a => Eq a where+  (==) :: Exp a -> Exp a -> Exp Bool+  (/=) :: Exp a -> Exp a -> Exp Bool+  {-# MINIMAL (==) | (/=) #-}+  x == y = mkLNot (x /= y)+  x /= y = mkLNot (x == y)+++instance Eq () where+  _ == _ = constant True   -- force arguments?+  _ /= _ = constant False  -- force arguments?++instance Eq Int where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Int8 where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Int16 where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Int32 where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Int64 where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Word where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Word8 where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Word16 where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Word32 where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Word64 where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CInt where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CUInt where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CLong where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CULong where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CLLong where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CULLong where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CShort where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CUShort where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Bool where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Char where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CChar where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CUChar where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CSChar where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Half where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Float where+  (==) = mkEq+  (/=) = mkNEq++instance Eq Double where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CFloat where+  (==) = mkEq+  (/=) = mkNEq++instance Eq CDouble where+  (==) = mkEq+  (/=) = mkNEq++instance (Eq a, Eq b) => Eq (a, b) where+  x == y = let (a1,b1) = untup2 x+               (a2,b2) = untup2 y+           in a1 == a2 && b1 == b2+  x /= y = let (a1,b1) = untup2 x+               (a2,b2) = untup2 y+           in a1 /= a2 || b1 /= b2++instance (Eq a, Eq b, Eq c) => Eq (a, b, c) where+  x == y = let (a1,b1,c1) = untup3 x+               (a2,b2,c2) = untup3 y+           in a1 == a2 && b1 == b2 && c1 == c2+  x /= y = let (a1,b1,c1) = untup3 x+               (a2,b2,c2) = untup3 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2++instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) where+  x == y = let (a1,b1,c1,d1) = untup4 x+               (a2,b2,c2,d2) = untup4 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2+  x /= y = let (a1,b1,c1,d1) = untup4 x+               (a2,b2,c2,d2) = untup4 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2++instance (Eq a, Eq b, Eq c, Eq d, Eq e) => Eq (a, b, c, d, e) where+  x == y = let (a1,b1,c1,d1,e1) = untup5 x+               (a2,b2,c2,d2,e2) = untup5 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2+  x /= y = let (a1,b1,c1,d1,e1) = untup5 x+               (a2,b2,c2,d2,e2) = untup5 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => Eq (a, b, c, d, e, f) where+  x == y = let (a1,b1,c1,d1,e1,f1) = untup6 x+               (a2,b2,c2,d2,e2,f2) = untup6 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2+  x /= y = let (a1,b1,c1,d1,e1,f1) = untup6 x+               (a2,b2,c2,d2,e2,f2) = untup6 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a, b, c, d, e, f, g) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x+               (a2,b2,c2,d2,e2,f2,g2) = untup7 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x+               (a2,b2,c2,d2,e2,f2,g2) = untup7 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h) => Eq (a, b, c, d, e, f, g, h) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x+               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x+               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i) => Eq (a, b, c, d, e, f, g, h, i) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j) => Eq (a, b, c, d, e, f, g, h, i, j) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k) => Eq (a, b, c, d, e, f, g, h, i, j, k) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l) => Eq (a, b, c, d, e, f, g, h, i, j, k, l) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2 || l1 /= l2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2 || l1 /= l2 || m1 /= m2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2 || l1 /= l2 || m1 /= m2 || n1 /= n2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2 && o1 == o2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2 || l1 /= l2 || m1 /= m2 || n1 /= n2 || o1 /= o2++instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where+  x == y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1) = untup16 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2) = untup16 y+           in a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 && i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 && m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2+  x /= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1) = untup16 x+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2) = untup16 y+           in a1 /= a2 || b1 /= b2 || c1 /= c2 || d1 /= d2 || e1 /= e2 || f1 /= f2 || g1 /= g2 || h1 /= h2 || i1 /= i2 || j1 /= j2 || k1 /= k2 || l1 /= l2 || m1 /= m2 || n1 /= n2 || o1 /= o2 || p1 /= p2+++-- Instances of 'Prelude.Eq' don't make sense with the standard signatures as+-- the return type is fixed to 'Bool'. This instance is provided to provide+-- a useful error message.+--+instance Eq a => P.Eq (Exp a) where+  (==) = preludeError "Eq.(==)" "(==)"+  (/=) = preludeError "Eq.(/=)" "(/=)"++preludeError :: String -> String -> a+preludeError x y = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x y)+
+ src/Data/Array/Accelerate/Classes/Floating.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.Floating+-- Copyright   : [2016..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.Classes.Floating (++  Floating,+  P.pi,+  P.sin, P.cos, P.tan,+  P.asin, P.acos, P.atan,+  P.sinh, P.cosh, P.tanh,+  P.asinh, P.acosh, P.atanh,+  P.exp,+  P.sqrt,+  P.log,+  (P.**),+  P.logBase,++) where++import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Fractional++import qualified Prelude                                            as P+++-- | Trigonometric and hyperbolic functions and related functions+--+type Floating a = (Fractional a, P.Floating (Exp a))+++instance P.Floating (Exp Half) where+  pi      = mkPi+  sin     = mkSin+  cos     = mkCos+  tan     = mkTan+  asin    = mkAsin+  acos    = mkAcos+  atan    = mkAtan+  sinh    = mkSinh+  cosh    = mkCosh+  tanh    = mkTanh+  asinh   = mkAsinh+  acosh   = mkAcosh+  atanh   = mkAtanh+  exp     = mkExpFloating+  sqrt    = mkSqrt+  log     = mkLog+  (**)    = mkFPow+  logBase = mkLogBase++instance P.Floating (Exp Float) where+  pi      = mkPi+  sin     = mkSin+  cos     = mkCos+  tan     = mkTan+  asin    = mkAsin+  acos    = mkAcos+  atan    = mkAtan+  sinh    = mkSinh+  cosh    = mkCosh+  tanh    = mkTanh+  asinh   = mkAsinh+  acosh   = mkAcosh+  atanh   = mkAtanh+  exp     = mkExpFloating+  sqrt    = mkSqrt+  log     = mkLog+  (**)    = mkFPow+  logBase = mkLogBase++instance P.Floating (Exp Double) where+  pi      = mkPi+  sin     = mkSin+  cos     = mkCos+  tan     = mkTan+  asin    = mkAsin+  acos    = mkAcos+  atan    = mkAtan+  sinh    = mkSinh+  cosh    = mkCosh+  tanh    = mkTanh+  asinh   = mkAsinh+  acosh   = mkAcosh+  atanh   = mkAtanh+  exp     = mkExpFloating+  sqrt    = mkSqrt+  log     = mkLog+  (**)    = mkFPow+  logBase = mkLogBase++instance P.Floating (Exp CFloat) where+  pi      = mkPi+  sin     = mkSin+  cos     = mkCos+  tan     = mkTan+  asin    = mkAsin+  acos    = mkAcos+  atan    = mkAtan+  sinh    = mkSinh+  cosh    = mkCosh+  tanh    = mkTanh+  asinh   = mkAsinh+  acosh   = mkAcosh+  atanh   = mkAtanh+  exp     = mkExpFloating+  sqrt    = mkSqrt+  log     = mkLog+  (**)    = mkFPow+  logBase = mkLogBase++instance P.Floating (Exp CDouble) where+  pi      = mkPi+  sin     = mkSin+  cos     = mkCos+  tan     = mkTan+  asin    = mkAsin+  acos    = mkAcos+  atan    = mkAtan+  sinh    = mkSinh+  cosh    = mkCosh+  tanh    = mkTanh+  asinh   = mkAsinh+  acosh   = mkAcosh+  atanh   = mkAtanh+  exp     = mkExpFloating+  sqrt    = mkSqrt+  log     = mkLog+  (**)    = mkFPow+  logBase = mkLogBase+
+ src/Data/Array/Accelerate/Classes/Fractional.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.Fractional+-- Copyright   : [2016..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.Classes.Fractional (++  Fractional,+  (P./), P.recip, fromRational,++) where++import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Num++import Prelude                                                      ( Rational, (.) )+import qualified Prelude                                            as P+++-- | Conversion from a 'Rational'.+--+-- A floating point literal representations the application of the function+-- 'fromRational' to a value of type 'Rational'. We export this specialised+-- version where the return type is fixed to an 'Exp' term in order to improve+-- type checking in Accelerate modules when @RebindableSyntax@ is enabled.+--+fromRational :: Fractional a => Rational -> Exp a+fromRational = P.fromRational+++-- | Fractional numbers, supporting real division+--+type Fractional a = (Num a, P.Fractional (Exp a))+++instance P.Fractional (Exp Half) where+  (/)          = mkFDiv+  recip        = mkRecip+  fromRational = constant . P.fromRational++instance P.Fractional (Exp Float) where+  (/)          = mkFDiv+  recip        = mkRecip+  fromRational = constant . P.fromRational++instance P.Fractional (Exp Double) where+  (/)          = mkFDiv+  recip        = mkRecip+  fromRational = constant . P.fromRational++instance P.Fractional (Exp CFloat) where+  (/)          = mkFDiv+  recip        = mkRecip+  fromRational = constant . P.fromRational++instance P.Fractional (Exp CDouble) where+  (/)          = mkFDiv+  recip        = mkRecip+  fromRational = constant . P.fromRational+
+ src/Data/Array/Accelerate/Classes/FromIntegral.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MonoLocalBinds        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.FromIntegral+-- Copyright   : [2016..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.Classes.FromIntegral (++  FromIntegral(..),++) where++import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Integral++import Language.Haskell.TH                                          hiding ( Exp )+import Prelude                                                      hiding ( Integral )+++-- | Accelerate lacks a most-general lossless 'Prelude.Integer' type, which the+-- standard 'Prelude.fromIntegral' function uses as an intermediate value when+-- coercing from integral types. Instead, we use this class to capture a direct+-- coercion between two types.+--+class FromIntegral a b where+  -- | General coercion from integral types+  fromIntegral :: Integral a => Exp a -> Exp b++-- instance {-# OVERLAPPABLE #-} (Elt a, Elt b, IsIntegral a, IsNum b) => FromIntegral a b where+--   fromIntegral = mkFromIntegral+++-- Reify in ghci:+--+-- $( stringE . show =<< reify ''Thing )++-- Generate all the standard instances explicitly. This gives us sensible error+-- messages when we don't have an instance available, rather than a "can not+-- deduce IsNum..." style error (which the user can do nothing about).+--+$(runQ $ do+    let+        -- Get all the types that our dictionaries reify+        digItOut :: Name -> Q [Name]+        digItOut name = do+#if __GLASGOW_HASKELL__ < 800+          TyConI (DataD _ _ _   cons _) <- reify name+#else+          TyConI (DataD _ _ _ _ cons _) <- reify name+#endif+          let+            -- This is what a constructor such as IntegralNumType will be reified+            -- as prior to GHC 8.4...+            dig (NormalC _ [(_, AppT (ConT n) (VarT _))])               = digItOut n+#if __GLASGOW_HASKELL__ < 800+            dig (ForallC _ _ (NormalC _ [(_, AppT (ConT _) (ConT n))])) = return [n]+#else+            -- ...but this is what IntegralNumType will be reified as on GHC 8.4+            -- and later, after the changes described in+            -- https://ghc.haskell.org/trac/ghc/wiki/Migration/8.4#TemplateHaskellreificationchangesforGADTs+            dig (ForallC _ _ (GadtC _ [(_, AppT (ConT n) (VarT _))] _)) = digItOut n+            dig (GadtC _ _ (AppT (ConT _) (ConT n)))                    = return [n]+#endif+            dig _ = error "Unexpected case generating FromIntegral instances"+            --+          concat `fmap` mapM dig cons++        thFromIntegral :: Name -> Name -> Q Dec+        thFromIntegral a b =+          let+              ty  = AppT (AppT (ConT (mkName "FromIntegral")) (ConT a)) (ConT b)+              dec = ValD (VarP (mkName "fromIntegral")) (NormalB (VarE (mkName "mkFromIntegral"))) []+          in+          instanceD (return []) (return ty) [return dec]+    --+    as <- digItOut ''IntegralType+    bs <- digItOut ''NumType+    sequence [ thFromIntegral a b | a <- as, b <- bs ]+ )+
+ src/Data/Array/Accelerate/Classes/Integral.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds    #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.Integral+-- Copyright   : [2016..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.Classes.Integral (++  Integral,+  P.quot,+  P.rem,+  P.div,+  P.mod,+  P.quotRem,+  P.divMod,++) where++import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Enum+import Data.Array.Accelerate.Classes.Real++import Prelude                                                      ( error )+import qualified Prelude                                            as P+++-- | Integral numbers, supporting integral division+--+type Integral a = (Enum a, Real a, P.Integral (Exp a))+++instance P.Integral (Exp Int) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp Int8) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp Int16) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp Int32) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp Int64) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp Word) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp Word8) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp Word16) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp Word32) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp Word64) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp CInt) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp CUInt) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp CLong) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp CULong) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp CLLong) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp CULLong) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp CShort) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"++instance P.Integral (Exp CUShort) where+  quot      = mkQuot+  rem       = mkRem+  div       = mkIDiv+  mod       = mkMod+  quotRem   = mkQuotRem+  divMod    = mkDivMod+  toInteger = error "Prelude.toInteger not supported for Accelerate types"+
+ src/Data/Array/Accelerate/Classes/Num.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.Num+-- Copyright   : [2016..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.Classes.Num (++  Num,+  (P.+), (P.-), (P.*), P.negate, P.abs, P.signum, fromInteger,++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Prelude                                                      ( Integer, (.) )+import qualified Prelude                                            as P+++-- Note: [Haskell/Accelerate numeric hierarchy]+--+-- Should we replace 'Prelude.Num' with our own version, as we did with 'Ord'+-- and 'Eq'? That might require clients to enable RebindableSyntax in order to+-- get the correct 'fromInteger' (or miss out on special magic and need to add+-- 'constant' instead).+--+-- I think that we should, because otherwise we require FlexibleContexts and+-- constraints are going to be inconsistent, e.g.:+--+-- f :: (P.Num (Exp a), A.Ord a) => ...+--+-- A light-weight alternative is the following constraint kind:+--+-- UPDATE TLM 2018-01-12: I attempted separating the two class hierarchies, and+-- while in principle it works, has very poor ergonomics in modules which use+-- both Accelerate and standard Haskell types. RebindableSyntax only helps for+-- Accelerate-only modules; for mixed-mode files, we need to use every operation+-- qualified, which is a pain. On the other hand, type inference appears to be+-- much, _much_ better.+--+++-- | Conversion from an 'Integer'.+--+-- An integer literal represents the application of the function 'fromInteger'+-- to the appropriate value of type 'Integer'. We export this specialised+-- version where the return type is fixed to an 'Exp' term in order to improve+-- type checking in Accelerate modules when @RebindableSyntax@ is enabled.+--+fromInteger :: Num a => Integer -> Exp a+fromInteger = P.fromInteger+++-- | Basic numeric class+--+type Num a = (Elt a, P.Num (Exp a))+++instance P.Num (Exp Int) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Int8) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Int16) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Int32) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Int64) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Word) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Word8) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Word16) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Word32) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Word64) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CInt) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CUInt) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CLong) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CULong) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CLLong) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CULLong) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CShort) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CUShort) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Half) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Float) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp Double) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CFloat) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger++instance P.Num (Exp CDouble) where+  (+)         = mkAdd+  (-)         = mkSub+  (*)         = mkMul+  negate      = mkNeg+  abs         = mkAbs+  signum      = mkSig+  fromInteger = constant . P.fromInteger+
+ src/Data/Array/Accelerate/Classes/Ord.hs view
@@ -0,0 +1,544 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax  #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.Ord+-- Copyright   : [2016..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.Classes.Ord (++  Ord(..),+  Ordering(..),++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Eq++import Text.Printf+import Prelude                                                      ( ($), (.), Ordering(..), String, error, unlines )+import qualified Prelude                                            as P+++infix 4 <+infix 4 >+infix 4 <=+infix 4 >=++-- | The 'Ord' class for totally ordered datatypes+--+class Eq a => Ord a where+  {-# MINIMAL (<=) | compare #-}+  (<)     :: Exp a -> Exp a -> Exp Bool+  (>)     :: Exp a -> Exp a -> Exp Bool+  (<=)    :: Exp a -> Exp a -> Exp Bool+  (>=)    :: Exp a -> Exp a -> Exp Bool+  min     :: Exp a -> Exp a -> Exp a+  max     :: Exp a -> Exp a -> Exp a+  compare :: Exp a -> Exp a -> Exp Ordering++  x <  y = if compare x y == constant LT then constant True  else constant False+  x <= y = if compare x y == constant GT then constant False else constant True+  x >  y = if compare x y == constant GT then constant True  else constant False+  x >= y = if compare x y == constant LT then constant False else constant True++  min x y = if x <= y then x else y+  max x y = if x <= y then y else x++  compare x y =+    if x == y then constant EQ else+    if x <= y then constant LT+              else constant GT++-- Local redefinition for use with RebindableSyntax (pulled forward from Prelude.hs)+--+ifThenElse :: Elt a => Exp Bool -> Exp a -> Exp a -> Exp a+ifThenElse = Exp $$$ Cond++instance Ord () where+  (<)     _ _ = constant False+  (>)     _ _ = constant False+  (>=)    _ _ = constant True+  (<=)    _ _ = constant True+  min     _ _ = constant ()+  max     _ _ = constant ()+  compare _ _ = constant EQ++instance Ord Int where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Int8 where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Int16 where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Int32 where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Int64 where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Word where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Word8 where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Word16 where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Word32 where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Word64 where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CInt where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CUInt where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CLong where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CULong where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CLLong where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CULLong where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CShort where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CUShort where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Bool where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Char where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CChar where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CUChar where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CSChar where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Half where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Float where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord Double where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CFloat where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance Ord CDouble where+  (<)  = mkLt+  (>)  = mkGt+  (<=) = mkLtEq+  (>=) = mkGtEq+  min  = mkMin+  max  = mkMax++instance (Ord a, Ord b) => Ord (a, b) where+  x <= y = let (a1,b1) = untup2 x+               (a2,b2) = untup2 y+           in a1 < a2 || (a1 == a2 && b1 <= b2)+  x >= y = let (a1,b1) = untup2 x+               (a2,b2) = untup2 y+           in a1 > a2 || (a1 == a2 && b1 >= b2)+  x < y  = let (a1,b1) = untup2 x+               (a2,b2) = untup2 y+           in a1 < a2 || (a1 == a2 && b1 < b2)+  x > y  = let (a1,b1) = untup2 x+               (a2,b2) = untup2 y+           in a1 > a2 || (a1 == a2 && b1 > b2)++instance (Ord a, Ord b, Ord c) => Ord (a, b, c) where+  x <= y = let (a1,b1,c1) = untup3 x; x' = tup2 (b1,c1)+               (a2,b2,c2) = untup3 y; y' = tup2 (b2,c2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1) = untup3 x; x' = tup2 (b1,c1)+               (a2,b2,c2) = untup3 y; y' = tup2 (b2,c2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1) = untup3 x; x' = tup2 (b1,c1)+               (a2,b2,c2) = untup3 y; y' = tup2 (b2,c2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1) = untup3 x; x' = tup2 (b1,c1)+               (a2,b2,c2) = untup3 y; y' = tup2 (b2,c2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) where+  x <= y = let (a1,b1,c1,d1) = untup4 x; x' = tup3 (b1,c1,d1)+               (a2,b2,c2,d2) = untup4 y; y' = tup3 (b2,c2,d2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1) = untup4 x; x' = tup3 (b1,c1,d1)+               (a2,b2,c2,d2) = untup4 y; y' = tup3 (b2,c2,d2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1) = untup4 x; x' = tup3 (b1,c1,d1)+               (a2,b2,c2,d2) = untup4 y; y' = tup3 (b2,c2,d2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1) = untup4 x; x' = tup3 (b1,c1,d1)+               (a2,b2,c2,d2) = untup4 y; y' = tup3 (b2,c2,d2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e) where+  x <= y = let (a1,b1,c1,d1,e1) = untup5 x; x' = tup4 (b1,c1,d1,e1)+               (a2,b2,c2,d2,e2) = untup5 y; y' = tup4 (b2,c2,d2,e2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1) = untup5 x; x' = tup4 (b1,c1,d1,e1)+               (a2,b2,c2,d2,e2) = untup5 y; y' = tup4 (b2,c2,d2,e2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1) = untup5 x; x' = tup4 (b1,c1,d1,e1)+               (a2,b2,c2,d2,e2) = untup5 y; y' = tup4 (b2,c2,d2,e2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1) = untup5 x; x' = tup4 (b1,c1,d1,e1)+               (a2,b2,c2,d2,e2) = untup5 y; y' = tup4 (b2,c2,d2,e2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) => Ord (a, b, c, d, e, f) where+  x <= y = let (a1,b1,c1,d1,e1,f1) = untup6 x; x' = tup5 (b1,c1,d1,e1,f1)+               (a2,b2,c2,d2,e2,f2) = untup6 y; y' = tup5 (b2,c2,d2,e2,f2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1) = untup6 x; x' = tup5 (b1,c1,d1,e1,f1)+               (a2,b2,c2,d2,e2,f2) = untup6 y; y' = tup5 (b2,c2,d2,e2,f2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1) = untup6 x; x' = tup5 (b1,c1,d1,e1,f1)+               (a2,b2,c2,d2,e2,f2) = untup6 y; y' = tup5 (b2,c2,d2,e2,f2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1) = untup6 x; x' = tup5 (b1,c1,d1,e1,f1)+               (a2,b2,c2,d2,e2,f2) = untup6 y; y' = tup5 (b2,c2,d2,e2,f2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g) => Ord (a, b, c, d, e, f, g) where+  x <= y = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x; x' = tup6 (b1,c1,d1,e1,f1,g1)+               (a2,b2,c2,d2,e2,f2,g2) = untup7 y; y' = tup6 (b2,c2,d2,e2,f2,g2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x; x' = tup6 (b1,c1,d1,e1,f1,g1)+               (a2,b2,c2,d2,e2,f2,g2) = untup7 y; y' = tup6 (b2,c2,d2,e2,f2,g2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x; x' = tup6 (b1,c1,d1,e1,f1,g1)+               (a2,b2,c2,d2,e2,f2,g2) = untup7 y; y' = tup6 (b2,c2,d2,e2,f2,g2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1,g1) = untup7 x; x' = tup6 (b1,c1,d1,e1,f1,g1)+               (a2,b2,c2,d2,e2,f2,g2) = untup7 y; y' = tup6 (b2,c2,d2,e2,f2,g2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h) => Ord (a, b, c, d, e, f, g, h) where+  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x; x' = tup7 (b1,c1,d1,e1,f1,g1,h1)+               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y; y' = tup7 (b2,c2,d2,e2,f2,g2,h2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x; x' = tup7 (b1,c1,d1,e1,f1,g1,h1)+               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y; y' = tup7 (b2,c2,d2,e2,f2,g2,h2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x; x' = tup7 (b1,c1,d1,e1,f1,g1,h1)+               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y; y' = tup7 (b2,c2,d2,e2,f2,g2,h2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1) = untup8 x; x' = tup7 (b1,c1,d1,e1,f1,g1,h1)+               (a2,b2,c2,d2,e2,f2,g2,h2) = untup8 y; y' = tup7 (b2,c2,d2,e2,f2,g2,h2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i) => Ord (a, b, c, d, e, f, g, h, i) where+  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x; x' = tup8 (b1,c1,d1,e1,f1,g1,h1,i1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y; y' = tup8 (b2,c2,d2,e2,f2,g2,h2,i2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x; x' = tup8 (b1,c1,d1,e1,f1,g1,h1,i1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y; y' = tup8 (b2,c2,d2,e2,f2,g2,h2,i2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x; x' = tup8 (b1,c1,d1,e1,f1,g1,h1,i1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y; y' = tup8 (b2,c2,d2,e2,f2,g2,h2,i2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1) = untup9 x; x' = tup8 (b1,c1,d1,e1,f1,g1,h1,i1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2) = untup9 y; y' = tup8 (b2,c2,d2,e2,f2,g2,h2,i2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j) => Ord (a, b, c, d, e, f, g, h, i, j) where+  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x; x' = tup9 (b1,c1,d1,e1,f1,g1,h1,i1,j1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y; y' = tup9 (b2,c2,d2,e2,f2,g2,h2,i2,j2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x; x' = tup9 (b1,c1,d1,e1,f1,g1,h1,i1,j1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y; y' = tup9 (b2,c2,d2,e2,f2,g2,h2,i2,j2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x; x' = tup9 (b1,c1,d1,e1,f1,g1,h1,i1,j1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y; y' = tup9 (b2,c2,d2,e2,f2,g2,h2,i2,j2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1) = untup10 x; x' = tup9 (b1,c1,d1,e1,f1,g1,h1,i1,j1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = untup10 y; y' = tup9 (b2,c2,d2,e2,f2,g2,h2,i2,j2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k) => Ord (a, b, c, d, e, f, g, h, i, j, k) where+  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x; x' = tup10 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y; y' = tup10 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x; x' = tup10 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y; y' = tup10 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x; x' = tup10 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y; y' = tup10 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1) = untup11 x; x' = tup10 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = untup11 y; y' = tup10 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l) => Ord (a, b, c, d, e, f, g, h, i, j, k, l) where+  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x; x' = tup11 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y; y' = tup11 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x; x' = tup11 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y; y' = tup11 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x; x' = tup11 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y; y' = tup11 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1) = untup12 x; x' = tup11 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = untup12 y; y' = tup11 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l, Ord m) => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x; x' = tup12 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y; y' = tup12 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x; x' = tup12 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y; y' = tup12 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x; x' = tup12 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y; y' = tup12 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1) = untup13 x; x' = tup12 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = untup13 y; y' = tup12 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n) => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x; x' = tup13 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y; y' = tup13 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x; x' = tup13 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y; y' = tup13 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x; x' = tup13 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y; y' = tup13 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1) = untup14 x; x' = tup13 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = untup14 y; y' = tup13 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2)+           in a1 > a2 || (a1 == a2 && x' > y')++instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o) => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  x <= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x; x' = tup14 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y; y' = tup14 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2)+           in a1 < a2 || (a1 == a2 && x' <= y')+  x >= y = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x; x' = tup14 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y; y' = tup14 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2)+           in a1 > a2 || (a1 == a2 && x' >= y')+  x < y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x; x' = tup14 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y; y' = tup14 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2)+           in a1 < a2 || (a1 == a2 && x' < y')+  x > y  = let (a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1) = untup15 x; x' = tup14 (b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1)+               (a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = untup15 y; y' = tup14 (b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2)+           in a1 > a2 || (a1 == a2 && x' > y')+++type instance EltRepr Ordering = Int8++instance Elt Ordering where+  eltType _ = TypeRscalar scalarType+  fromElt = P.fromIntegral . P.fromEnum+  toElt   = P.toEnum . P.fromIntegral++instance Eq Ordering where+  x == y = mkBitcast x == (mkBitcast y :: Exp Int8)+  x /= y = mkBitcast x /= (mkBitcast y :: Exp Int8)++instance Ord Ordering where+  x < y   = mkBitcast x < (mkBitcast y :: Exp Int8)+  x > y   = mkBitcast x > (mkBitcast y :: Exp Int8)+  x <= y  = mkBitcast x <= (mkBitcast y :: Exp Int8)+  x >= y  = mkBitcast x >= (mkBitcast y :: Exp Int8)+  min x y = mkBitcast $ min (mkBitcast x) (mkBitcast y :: Exp Int8)+  max x y = mkBitcast $ max (mkBitcast x) (mkBitcast y :: Exp Int8)+++-- Instances of 'Prelude.Ord' (mostly) don't make sense with the standard+-- signatures as the return type is fixed to 'Bool'. This instance is provided+-- to provide a useful error message.+--+-- Note that 'min' and 'max' are implementable, so we do hook those into the+-- accelerate instances defined here. This allows us to use operations such as+-- 'Prelude.minimum' and 'Prelude.maximum'.+--+instance Ord a => P.Ord (Exp a) where+  (<)     = preludeError "Ord.(<)"  "(<)"+  (<=)    = preludeError "Ord.(<=)" "(<=)"+  (>)     = preludeError "Ord.(>)"  "(>)"+  (>=)    = preludeError "Ord.(>=)" "(>=)"+  min     = min+  max     = max++preludeError :: String -> String -> a+preludeError x y+  = error+  $ unlines [ printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x y+            , ""+            , "These Prelude.Ord instances are present only to fulfil superclass"+            , "constraints for subsequent classes in the standard Haskell numeric"+            , "hierarchy."+            ]+
+ src/Data/Array/Accelerate/Classes/Real.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE MonoLocalBinds       #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# OPTIONS_GHC -fno-warn-orphans         #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.Real+-- Copyright   : [2016..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.Classes.Real (++  Real,++) where++import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Ord++import Prelude                                                      hiding ( Real, Num, Ord )+import qualified Prelude                                            as P+++type Real a = (Num a, Ord a, P.Real (Exp a))++-- Instances of 'Real' don't make sense in Accelerate at the moment. These are+-- only provided to fulfil superclass constraints; e.g. Integral.+--+-- We won't need `toRational' until we support rational numbers in AP+-- computations.+--+instance (Num a, Ord a) => P.Real (Exp a) where+  toRational+    = error+    $ unlines [ "Prelude.toRational is not supported for Accelerate types"+              , ""+              , "These Prelude.Real instances are present only to fulfil superclass"+              , "constraints for subsequent classes in the standard Haskell numeric hierarchy."+              ]+
+ src/Data/Array/Accelerate/Classes/RealFloat.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DefaultSignatures   #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.RealFloat+-- Copyright   : [2016..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.Classes.RealFloat (++  RealFloat(..),++) where++import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Data.Bits++import Data.Array.Accelerate.Classes.Eq+import Data.Array.Accelerate.Classes.Floating+import Data.Array.Accelerate.Classes.FromIntegral+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Ord+import Data.Array.Accelerate.Classes.RealFrac++import Text.Printf+import Prelude                                                      ( (.), ($), String, error, undefined, unlines, otherwise )+import qualified Prelude                                            as P+++-- | Efficient, machine-independent access to the components of a floating-point+-- number+--+class (RealFrac a, Floating a) => RealFloat a where+  -- | The radix of the representation (often 2) (constant)+  floatRadix     :: Exp a -> Exp Int64  -- Integer+  default floatRadix :: P.RealFloat a => Exp a -> Exp Int64+  floatRadix _    = P.fromInteger (P.floatRadix (undefined::a))++  -- | The number of digits of 'floatRadix' in the significand (constant)+  floatDigits    :: Exp a -> Exp Int+  default floatDigits :: P.RealFloat a => Exp a -> Exp Int+  floatDigits _   = constant (P.floatDigits (undefined::a))++  -- | The lowest and highest values the exponent may assume (constant)+  floatRange     :: Exp a -> (Exp Int, Exp Int)+  default floatRange :: P.RealFloat a => Exp a -> (Exp Int, Exp Int)+  floatRange _    = let (m,n) = P.floatRange (undefined::a)+                    in (constant m, constant n)++  -- | Return the significand and an appropriately scaled exponent. If+  -- @(m,n) = 'decodeFloat' x@ then @x = m*b^^n@, where @b@ is the+  -- floating-point radix ('floatRadix'). Furthermore, either @m@ and @n@ are+  -- both zero, or @b^(d-1) <= 'abs' m < b^d@, where @d = 'floatDigits' x@.+  decodeFloat    :: Exp a -> (Exp Int64, Exp Int)    -- Integer++  -- | Inverse of 'decodeFloat'+  encodeFloat    :: Exp Int64 -> Exp Int -> Exp a    -- Integer+  default encodeFloat :: (FromIntegral Int a, FromIntegral Int64 a) => Exp Int64 -> Exp Int -> Exp a+  encodeFloat x e = fromIntegral x * (fromIntegral (floatRadix (undefined :: Exp a)) ** fromIntegral e)++  -- | Corresponds to the second component of 'decodeFloat'+  exponent       :: Exp a -> Exp Int+  exponent x      = let (m,n) = decodeFloat x+                    in  Exp $ Cond (m == 0)+                                   0+                                   (n + floatDigits x)++  -- | Corresponds to the first component of 'decodeFloat'+  significand    :: Exp a -> Exp a+  significand x   = let (m,_) = decodeFloat x+                    in  encodeFloat m (negate (floatDigits x))++  -- | Multiply a floating point number by an integer power of the radix+  scaleFloat     :: Exp Int -> Exp a -> Exp a+  scaleFloat k x  =+    Exp $ Cond (k == 0 || isFix) x+        $ encodeFloat m (n + clamp b)+    where+      isFix = x == 0 || isNaN x || isInfinite x+      (m,n) = decodeFloat x+      (l,h) = floatRange x+      d     = floatDigits x+      b     = h - l + 4*d+      -- n+k may overflow, which would lead to incorrect results, hence we clamp+      -- the scaling parameter. If (n+k) would be larger than h, (n + clamp b k)+      -- must be too, similar for smaller than (l-d).+      clamp bd  = max (-bd) (min bd k)++  -- | 'True' if the argument is an IEEE \"not-a-number\" (NaN) value+  isNaN          :: Exp a -> Exp Bool++  -- | 'True' if the argument is an IEEE infinity or negative-infinity+  isInfinite     :: Exp a -> Exp Bool++  -- | 'True' if the argument is too small to be represented in normalized+  -- format+  isDenormalized :: Exp a -> Exp Bool++  -- | 'True' if the argument is an IEEE negative zero+  isNegativeZero :: Exp a -> Exp Bool++  -- | 'True' if the argument is an IEEE floating point number+  isIEEE         :: Exp a -> Exp Bool+  default isIEEE :: P.RealFloat a => Exp a -> Exp Bool+  isIEEE _        = constant (P.isIEEE (undefined::a))++  -- | A version of arctangent taking two real floating-point arguments.+  -- For real floating @x@ and @y@, @'atan2' y x@ computes the angle (from the+  -- positive x-axis) of the vector from the origin to the point @(x,y)@.+  -- @'atan2' y x@ returns a value in the range [@-pi@, @pi@].+  atan2          :: Exp a -> Exp a -> Exp a+++instance RealFloat Half where+  atan2           = mkAtan2+  isNaN           = mkIsNaN+  isInfinite      = mkIsInfinite+  floatRange _    = (-13,16)    -- bug in half <= 2.2.3+  isDenormalized  = ieee754 "isDenormalized" (ieee754_f16_is_denormalized . mkUnsafeCoerce)+  isNegativeZero  = ieee754 "isNegativeZero" (ieee754_f16_is_negative_zero . mkUnsafeCoerce)+  decodeFloat     = ieee754 "decodeFloat"    (\x -> let (m,n) = untup2 $ ieee754_f16_decode (mkUnsafeCoerce x)+                                                    in  (fromIntegral m, n))++instance RealFloat Float where+  atan2           = mkAtan2+  isNaN           = mkIsNaN+  isInfinite      = mkIsInfinite+  isDenormalized  = ieee754 "isDenormalized" (ieee754_f32_is_denormalized . mkUnsafeCoerce)+  isNegativeZero  = ieee754 "isNegativeZero" (ieee754_f32_is_negative_zero . mkUnsafeCoerce)+  decodeFloat     = ieee754 "decodeFloat"    (\x -> let (m,n) = untup2 $ ieee754_f32_decode (mkUnsafeCoerce x)+                                                    in  (fromIntegral m, n))++instance RealFloat Double where+  atan2           = mkAtan2+  isNaN           = mkIsNaN+  isInfinite      = mkIsInfinite+  isDenormalized  = ieee754 "isDenormalized" (ieee754_f64_is_denormalized . mkUnsafeCoerce)+  isNegativeZero  = ieee754 "isNegativeZero" (ieee754_f64_is_negative_zero . mkUnsafeCoerce)+  decodeFloat     = ieee754 "decodeFloat"    (untup2 . ieee754_f64_decode . mkUnsafeCoerce)++instance RealFloat CFloat where+  atan2           = mkAtan2+  isNaN           = mkIsNaN+  isInfinite      = mkIsInfinite+  isDenormalized  = ieee754 "isDenormalized" (ieee754_f32_is_denormalized . mkUnsafeCoerce)+  isNegativeZero  = ieee754 "isNegativeZero" (ieee754_f32_is_negative_zero . mkUnsafeCoerce)+  decodeFloat     = ieee754 "decodeFloat"    (\x -> let (m,n) = untup2 $ ieee754_f32_decode (mkUnsafeCoerce x)+                                                    in  (fromIntegral m, n))++instance RealFloat CDouble where+  atan2           = mkAtan2+  isNaN           = mkIsNaN+  isInfinite      = mkIsInfinite+  isDenormalized  = ieee754 "isDenormalized" (ieee754_f64_is_denormalized . mkUnsafeCoerce)+  isNegativeZero  = ieee754 "isNegativeZero" (ieee754_f64_is_negative_zero . mkUnsafeCoerce)+  decodeFloat     = ieee754 "decodeFloat"    (untup2 . ieee754_f64_decode . mkUnsafeCoerce)+++-- To satisfy superclass constraints+--+instance RealFloat a => P.RealFloat (Exp a) where+  floatRadix     = preludeError "floatRadix"+  floatDigits    = preludeError "floatDigits"+  floatRange     = preludeError "floatRange"+  decodeFloat    = preludeError "decodeFloat"+  encodeFloat    = preludeError "encodeFloat"+  isNaN          = preludeError "isNaN"+  isInfinite     = preludeError "isInfinite"+  isDenormalized = preludeError "isDenormalized"+  isNegativeZero = preludeError "isNegativeZero"+  isIEEE         = preludeError "isIEEE"++preludeError :: String -> a+preludeError x+  = error+  $ unlines [ printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x x+            , ""+            , "These Prelude.RealFloat instances are present only to fulfil superclass"+            , "constraints for subsequent classes in the standard Haskell numeric hierarchy."+            ]+++ieee754 :: forall a b. P.RealFloat a => String -> (Exp a -> b) -> Exp a -> b+ieee754 name f x+  | P.isIEEE (undefined::a) = f x+  | otherwise               = $internalError (printf "RealFloat.%s" name) "Not implemented for non-IEEE floating point"++-- From: ghc/libraries/base/cbits/primFloat.c+-- ------------------------------------------++-- An IEEE754 number is denormalised iff:+--   * exponent is zero+--   * mantissa is non-zero.+--   * (don't care about setting of sign bit.)+--+ieee754_f64_is_denormalized :: Exp Word64 -> Exp Bool+ieee754_f64_is_denormalized x =+  ieee754_f64_mantissa x == 0 &&+  ieee754_f64_exponent x /= 0++ieee754_f32_is_denormalized :: Exp Word32 -> Exp Bool+ieee754_f32_is_denormalized x =+  ieee754_f32_mantissa x == 0 &&+  ieee754_f32_exponent x /= 0++ieee754_f16_is_denormalized :: Exp Word16 -> Exp Bool+ieee754_f16_is_denormalized x =+  ieee754_f16_mantissa x == 0 &&+  ieee754_f16_exponent x /= 0++-- Negative zero if only the sign bit is set+--+ieee754_f64_is_negative_zero :: Exp Word64 -> Exp Bool+ieee754_f64_is_negative_zero x =+  ieee754_f64_negative x &&+  ieee754_f64_exponent x == 0 &&+  ieee754_f64_mantissa x == 0++ieee754_f32_is_negative_zero :: Exp Word32 -> Exp Bool+ieee754_f32_is_negative_zero x =+  ieee754_f32_negative x &&+  ieee754_f32_exponent x == 0 &&+  ieee754_f32_mantissa x == 0++ieee754_f16_is_negative_zero :: Exp Word16 -> Exp Bool+ieee754_f16_is_negative_zero x =+  ieee754_f16_negative x &&+  ieee754_f16_exponent x == 0 &&+  ieee754_f16_mantissa x == 0+++-- Assume the host processor stores integers and floating point numbers in the+-- same endianness (true for modern processors).+--+-- To recap, here's the representation of a double precision+-- IEEE floating point number:+--+-- sign         63           sign bit (0==positive, 1==negative)+-- exponent     62-52        exponent (biased by 1023)+-- fraction     51-0         fraction (bits to right of binary point)+--+ieee754_f64_mantissa :: Exp Word64 -> Exp Word64+ieee754_f64_mantissa x = x .&. 0xFFFFFFFFFFFFF++ieee754_f64_exponent :: Exp Word64 -> Exp Word16+ieee754_f64_exponent x = fromIntegral (x `unsafeShiftR` 52) .&. 0x7FF++ieee754_f64_negative :: Exp Word64 -> Exp Bool+ieee754_f64_negative x = testBit x 63++-- Representation of single precision IEEE floating point number:+--+-- sign         31           sign bit (0==positive, 1==negative)+-- exponent     30-23        exponent (biased by 127)+-- fraction     22-0         fraction (bits to right of binary point)+--+ieee754_f32_mantissa :: Exp Word32 -> Exp Word32+ieee754_f32_mantissa x = x .&. 0x7FFFFF++ieee754_f32_exponent :: Exp Word32 -> Exp Word8+ieee754_f32_exponent x = fromIntegral (x `unsafeShiftR` 23)++ieee754_f32_negative :: Exp Word32 -> Exp Bool+ieee754_f32_negative x = testBit x 31++-- Representation of half precision IEEE floating point number:+--+-- sign         15           sign bit (0==positive, 1==negative)+-- exponent     14-10        exponent (biased by 15)+-- fraction     9-0          fraction (bits to right of binary point)+--+ieee754_f16_mantissa :: Exp Word16 -> Exp Word16+ieee754_f16_mantissa x = x .&. 0x3FF++ieee754_f16_exponent :: Exp Word16 -> Exp Word8+ieee754_f16_exponent x = fromIntegral (x `unsafeShiftR` 10) .&. 0x1F++ieee754_f16_negative :: Exp Word16 -> Exp Bool+ieee754_f16_negative x = testBit x 15+++-- reverse engineered following the below++ieee754_f16_decode :: Exp Word16 -> Exp (Int16, Int)+ieee754_f16_decode i =+  let+      _HHIGHBIT                       = 0x0400+      _HMSBIT                         = 0x8000+      _HMINEXP                        = ((_HALF_MIN_EXP) - (_HALF_MANT_DIG) - 1)+      _HALF_MANT_DIG                  = floatDigits (undefined::Exp Half)+      (_HALF_MIN_EXP, _HALF_MAX_EXP)  = floatRange  (undefined::Exp Half)++      high1 = fromIntegral i+      high2 = high1 .&. (_HHIGHBIT - 1)++      exp1  = ((fromIntegral high1 `unsafeShiftR` 10) .&. 0x1F) + _HMINEXP+      exp2  = exp1 + 1++      (high3, exp3)+            = untup2+            $ Exp $ Cond (exp1 /= _HMINEXP)+                         -- don't add hidden bit to denorms+                         (tup2 (high2 .|. _HHIGHBIT, exp1))+                         -- a denorm, normalise the mantissa+                         (Exp $ While (\(untup2 -> (h,_)) -> (h .&. _HHIGHBIT) /= 0 )+                                      (\(untup2 -> (h,e)) -> tup2 (h `unsafeShiftL` 1, e-1))+                                      (tup2 (high2, exp2)))++      high4 = Exp $ Cond (fromIntegral i < (0 :: Exp Int16)) (-high3) high3+  in+  Exp $ Cond (high1 .&. complement _HMSBIT == 0)+             (tup2 (0,0))+             (tup2 (high4, exp3))+++-- From: ghc/rts/StgPrimFloat.c+-- ----------------------------++ieee754_f32_decode :: Exp Word32 -> Exp (Int32, Int)+ieee754_f32_decode i =+  let+      _FHIGHBIT                     = 0x00800000+      _FMSBIT                       = 0x80000000+      _FMINEXP                      = ((_FLT_MIN_EXP) - (_FLT_MANT_DIG) - 1)+      _FLT_MANT_DIG                 = floatDigits (undefined::Exp Float)+      (_FLT_MIN_EXP, _FLT_MAX_EXP)  = floatRange  (undefined::Exp Float)++      high1 = fromIntegral i+      high2 = high1 .&. (_FHIGHBIT - 1)++      exp1  = ((fromIntegral high1 `unsafeShiftR` 23) .&. 0xFF) + _FMINEXP+      exp2  = exp1 + 1++      (high3, exp3)+            = untup2+            $ Exp $ Cond (exp1 /= _FMINEXP)+                         -- don't add hidden bit to denorms+                         (tup2 (high2 .|. _FHIGHBIT, exp1))+                         -- a denorm, normalise the mantissa+                         (Exp $ While (\(untup2 -> (h,_)) -> (h .&. _FHIGHBIT) /= 0 )+                                      (\(untup2 -> (h,e)) -> tup2 (h `unsafeShiftL` 1, e-1))+                                      (tup2 (high2, exp2)))++      high4 = Exp $ Cond (fromIntegral i < (0 :: Exp Int32)) (-high3) high3+  in+  Exp $ Cond (high1 .&. complement _FMSBIT == 0)+             (tup2 (0,0))+             (tup2 (high4, exp3))+++ieee754_f64_decode :: Exp Word64 -> Exp (Int64, Int)+ieee754_f64_decode i =+  let (s,h,l,e) = untup4 $ ieee754_f64_decode2 i+  in  tup2 (fromIntegral s * (fromIntegral h `unsafeShiftL` 32 .|. fromIntegral l), e)++ieee754_f64_decode2 :: Exp Word64 -> Exp (Int, Word32, Word32, Int)+ieee754_f64_decode2 i =+  let+      _DHIGHBIT                     = 0x00100000+      _DMSBIT                       = 0x80000000+      _DMINEXP                      = ((_DBL_MIN_EXP) - (_DBL_MANT_DIG) - 1)+      _DBL_MANT_DIG                 = floatDigits (undefined::Exp Double)+      (_DBL_MIN_EXP, _DBL_MAX_EXP)  = floatRange  (undefined::Exp Double)++      low   = fromIntegral i+      high  = fromIntegral (i `unsafeShiftR` 32)++      iexp  = (fromIntegral ((high `unsafeShiftR` 20) .&. 0x7FF) + _DMINEXP)+      sign = Exp $ Cond (fromIntegral i < (0 :: Exp Int64)) (-1) 1++      high2 = high .&. (_DHIGHBIT - 1)+      iexp2 = iexp + 1++      (hi,lo,ie)+            = untup3+            $ Exp $ Cond (iexp2 /= _DMINEXP)+                         -- don't add hidden bit to denorms+                         (tup3 (high2 .|. _DHIGHBIT, low, iexp))+                         -- a denorm, nermalise the mantissa+                         (Exp $ While (\(untup3 -> (h,_,_)) -> (h .&. _DHIGHBIT) /= 0)+                                      (\(untup3 -> (h,l,e)) ->+                                        let h1 = h `unsafeShiftL` 1+                                            h2 = Exp $ Cond ((l .&. _DMSBIT) /= 0) (h1+1) h1+                                        in  tup3 (h2, l `unsafeShiftL` 1, e-1))+                                      (tup3 (high2, low, iexp2)))++  in+  Exp $ Cond (low == 0 && (high .&. (complement _DMSBIT)) == 0)+             (tup4 (1,0,0,0))+             (tup4 (sign,hi,lo,ie))+
+ src/Data/Array/Accelerate/Classes/RealFrac.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds    #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.RealFrac+-- Copyright   : [2016..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.Classes.RealFrac (++  RealFrac(..),+  div', mod', divMod',++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Eq+import Data.Array.Accelerate.Classes.Floating+import Data.Array.Accelerate.Classes.Fractional+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Real+import Data.Array.Accelerate.Classes.ToFloating++import Text.Printf+import Prelude                                                      ( ($), String, error, unlines )+import qualified Prelude                                            as P+++-- | Generalisation of 'P.div' to any instance of 'RealFrac'+--+div' :: (RealFrac a, Elt b, IsIntegral b) => Exp a -> Exp a -> Exp b+div' n d = floor (n / d)++-- | Generalisation of 'P.mod' to any instance of 'RealFrac'+--+mod' :: (Floating a, RealFrac a, ToFloating Int a) => Exp a -> Exp a -> Exp a+mod' n d = n - (toFloating f) * d+  where+    f :: Exp Int+    f = div' n d++-- | Generalisation of 'P.divMod' to any instance of 'RealFrac'+--+divMod'+    :: (Floating a, RealFrac a, Num b, IsIntegral b, ToFloating b a)+    => Exp a+    -> Exp a+    -> (Exp b, Exp a)+divMod' n d = (f, n - (toFloating f) * d)+  where+    f = div' n d+++-- | Extracting components of fractions.+--+class (Real a, Fractional a) => RealFrac a where+  -- The function 'properFraction' takes a real fractional number @x@ and+  -- returns a pair @(n,f)@ such that @x = n+f@, and:+  --+  -- * @n@ is an integral number with the same sign as @x@; and+  --+  -- * @f@ is a fraction with the same type and sign as @x@,+  --   and with absolute value less than @1@.+  --+  -- The default definitions of the 'ceiling', 'floor', 'truncate'+  -- and 'round' functions are in terms of 'properFraction'.+  properFraction :: (Num b, ToFloating b a, IsIntegral b) => Exp a -> (Exp b, Exp a)++  -- The function 'splitFraction' takes a real fractional number @x@ and+  -- returns a pair @(n,f)@ such that @x = n+f@, and:+  --+  -- * @n@ is an integral number with the same sign as @x@; and+  --+  -- * @f@ is a fraction with the same type as @x@ in the range [0,1). Note that+  -- this differs from 'Prelude.properFraction'.+  --+  -- splitFraction :: (Elt b, IsIntegral b) => Exp a -> (Exp b, Exp a)++  -- @fraction x@ returns @x@ with the integer part removed.+  -- fraction       :: Exp a -> Exp a++  -- properFraction is part of the standard Haskell'98 RealFrac type classes+  -- splitFraction / fraction are from numeric-prelude Algebra.RealRing++  -- | @truncate x@ returns the integer nearest @x@ between zero and @x@+  truncate       :: (Elt b, IsIntegral b) => Exp a -> Exp b++  -- | @'round' x@ returns the nearest integer to @x@; the even integer if @x@+  -- is equidistant between two integers+  round          :: (Elt b, IsIntegral b) => Exp a -> Exp b++  -- | @'ceiling' x@ returns the least integer not less than @x@+  ceiling        :: (Elt b, IsIntegral b) => Exp a -> Exp b++  -- | @'floor' x@ returns the greatest integer not greater than @x@+  floor          :: (Elt b, IsIntegral b) => Exp a -> Exp b+++instance RealFrac Half where+  properFraction  = defaultProperFraction+  truncate        = mkTruncate+  round           = mkRound+  ceiling         = mkCeiling+  floor           = mkFloor++instance RealFrac Float where+  properFraction  = defaultProperFraction+  truncate        = mkTruncate+  round           = mkRound+  ceiling         = mkCeiling+  floor           = mkFloor++instance RealFrac Double where+  properFraction  = defaultProperFraction+  truncate        = mkTruncate+  round           = mkRound+  ceiling         = mkCeiling+  floor           = mkFloor++instance RealFrac CFloat where+  properFraction  = defaultProperFraction+  truncate        = mkTruncate+  round           = mkRound+  ceiling         = mkCeiling+  floor           = mkFloor++instance RealFrac CDouble where+  properFraction  = defaultProperFraction+  truncate        = mkTruncate+  round           = mkRound+  ceiling         = mkCeiling+  floor           = mkFloor+++-- Must test for ±0.0 to avoid returning -0.0 in the second component of the+-- pair. Unfortunately the branching costs a lot of performance.+--+defaultProperFraction+    :: (ToFloating a b, RealFrac b, IsIntegral a, Num a, Floating b)+    => Exp b+    -> (Exp a, Exp b)+defaultProperFraction x =+  untup2 $ Exp+         $ Cond (x == 0) (tup2 (0, 0))+                         (tup2 (n, f))+  where+    n = truncate x+    f = x - toFloating n+++-- To satisfy superclass constraints+--+instance RealFrac a => P.RealFrac (Exp a) where+  properFraction = preludeError "properFraction"+  truncate       = preludeError "truncate"+  round          = preludeError "round"+  ceiling        = preludeError "ceiling"+  floor          = preludeError "floor"++preludeError :: String -> a+preludeError x+  = error+  $ unlines [ printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x x+            , ""+            , "These Prelude.RealFrac instances are present only to fulfil superclass"+            , "constraints for subsequent classes in the standard Haskell numeric hierarchy."+            ]+
+ src/Data/Array/Accelerate/Classes/ToFloating.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE TemplateHaskell       #-}+-- |+-- Module      : Data.Array.Accelerate.Classes.ToFloating+-- Copyright   : [2016..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.Classes.ToFloating (++  ToFloating(..),++) where++import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Floating+import Data.Array.Accelerate.Classes.Num++import Language.Haskell.TH                                          hiding ( Exp )+import Control.Monad+import Prelude                                                      ( ($), error, concat )+++-- | Accelerate lacks an arbitrary-precision 'Prelude.Rational' type, which the+-- standard 'Prelude.realToFrac' uses as an intermediate value when coercing+-- to floating-point types. Instead, we use this class to capture a direct+-- coercion between to types.+--+class ToFloating a b where+  -- | General coercion to floating types+  toFloating :: (Num a, Floating b) => Exp a -> Exp b++-- instance (Elt a, Elt b, IsNum a, IsFloating b) => ToFloating a b where+--   toFloating = mkToFloating++-- Generate standard instances explicitly. See also: 'FromIntegral'.+--+$(runQ $ do+    let+        -- Get all the types that our dictionaries reify+        digItOut :: Name -> Q [Name]+        digItOut name = do+#if __GLASGOW_HASKELL__ < 800+          TyConI (DataD _ _ _   cons _) <- reify name+#else+          TyConI (DataD _ _ _ _ cons _) <- reify name+#endif+          let+            -- This is what a constructor such as IntegralNumType will be reified+            -- as prior to GHC 8.4...+            dig (NormalC _ [(_, AppT (ConT n) (VarT _))])               = digItOut n+#if __GLASGOW_HASKELL__ < 800+            dig (ForallC _ _ (NormalC _ [(_, AppT (ConT _) (ConT n))])) = return [n]+#else+            -- ...but this is what IntegralNumType will be reified as on GHC 8.4+            -- and later, after the changes described in+            -- https://ghc.haskell.org/trac/ghc/wiki/Migration/8.4#TemplateHaskellreificationchangesforGADTs+            dig (ForallC _ _ (GadtC _ [(_, AppT (ConT n) (VarT _))] _)) = digItOut n+            dig (GadtC _ _ (AppT (ConT _) (ConT n)))                    = return [n]+#endif+            dig _ = error "Unexpected case generating ToFloating instances"+            --+          concat `fmap` mapM dig cons++        thToFloating :: Name -> Name -> Q Dec+        thToFloating a b =+          let+              ty  = AppT (AppT (ConT (mkName "ToFloating")) (ConT a)) (ConT b)+              dec = ValD (VarP (mkName "toFloating")) (NormalB (VarE (mkName "mkToFloating"))) []+          in+          instanceD (return []) (return ty) [return dec]+    --+    as <- digItOut ''NumType+    bs <- digItOut ''FloatingType+    sequence [ thToFloating a b | a <- as, b <- bs ]+ )+
+ src/Data/Array/Accelerate/Data/Bits.hs view
@@ -0,0 +1,808 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.Data.Bits+-- Copyright   : [2016..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)+--+-- Bitwise operations for signed and unsigned integer expressions.+--++module Data.Array.Accelerate.Data.Bits (++  Bits(..),+  FiniteBits(..),++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Language+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Eq+import Data.Array.Accelerate.Classes.Ord+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Integral                       ()++import Prelude                                                      ( ($), undefined, otherwise )+import qualified Data.Bits                                          as B+++infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`+infixl 7 .&.+infixl 6 `xor`+infixl 5 .|.+++-- | The 'Bits' class defines bitwise operations over integral scalar expression+-- types. As usual, bits are numbered from zero, with zero being the least+-- significant bit.+--+class Eq a => Bits a where+  {-# MINIMAL (.&.), (.|.), xor, complement,+              (shift | (shiftL, shiftR)),+              (rotate | (rotateL, rotateR)),+              isSigned, testBit, bit, popCount #-}++  -- | Bitwise "and"+  (.&.)         :: Exp a -> Exp a -> Exp a++  -- | Bitwise "or"+  (.|.)         :: Exp a -> Exp a -> Exp a++  -- | Bitwise "xor"+  xor           :: Exp a -> Exp a -> Exp a++  -- | Reverse all bits in the argument+  complement    :: Exp a -> Exp a++  -- | @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive, or right by+  -- @-i@ bits otherwise. Right shifts perform sign extension on signed number+  -- types; i.e. they fill the top bits with 1 if the @x@ is negative and with+  -- 0 otherwise.+  shift         :: Exp a -> Exp Int -> Exp a+  shift x i+    = cond (i < 0) (x `shiftR` (-i))+    $ cond (i > 0) (x `shiftL` i)+    $ x++  -- | @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive, or right+  -- by @-i@ bits otherwise.+  rotate        :: Exp a -> Exp Int -> Exp a+  rotate x i+    = cond (i < 0) (x `rotateR` (-i))+    $ cond (i > 0) (x `rotateL` i)+    $ x++  -- | The value with all bits unset+  zeroBits      :: Exp a+  zeroBits = clearBit (bit 0) 0++  -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear.+  bit           :: Exp Int -> Exp a++  -- | @x \`setBit\` i@ is the same as @x .|. bit i@+  setBit        :: Exp a -> Exp Int -> Exp a+  setBit x i = x .|. bit i++  -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@+  clearBit      :: Exp a -> Exp Int -> Exp a+  clearBit x i = x .&. complement (bit i)++  -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@+  complementBit :: Exp a -> Exp Int -> Exp a+  complementBit x i = x `xor` bit i++  -- | Return 'True' if the @n@th bit of the argument is 1+  testBit       :: Exp a -> Exp Int -> Exp Bool++  -- | Return 'True' if the argument is a signed type.+  isSigned      :: Exp a -> Exp Bool++  -- | Shift the argument left by the specified number of bits (which must be+  -- non-negative).+  shiftL        :: Exp a -> Exp Int -> Exp a+  shiftL x i = x `shift` i++  -- | Shift the argument left by the specified number of bits. The result is+  -- undefined for negative shift amounts and shift amounts greater or equal to+  -- the 'finiteBitSize'.+  unsafeShiftL  :: Exp a -> Exp Int -> Exp a+  unsafeShiftL = shiftL++  -- | Shift the first argument right by the specified number of bits (which+  -- must be non-negative).+  --+  -- Right shifts perform sign extension on signed number types; i.e. they fill+  -- the top bits with 1 if @x@ is negative and with 0 otherwise.+  shiftR        :: Exp a -> Exp Int -> Exp a+  shiftR x i = x `shift` (-i)++  -- | Shift the first argument right by the specified number of bits. The+  -- result is undefined for negative shift amounts and shift amounts greater or+  -- equal to the 'finiteBitSize'.+  unsafeShiftR  :: Exp a -> Exp Int -> Exp a+  unsafeShiftR = shiftR++  -- | Rotate the argument left by the specified number of bits (which must be+  -- non-negative).+  rotateL       :: Exp a -> Exp Int -> Exp a+  rotateL x i = x `rotate` i++  -- | Rotate the argument right by the specified number of bits (which must be non-negative).+  rotateR       :: Exp a -> Exp Int -> Exp a+  rotateR x i = x `rotate` (-i)++  -- | Return the number of set bits in the argument. This number is known as+  -- the population count or the Hamming weight.+  popCount      :: Exp a -> Exp Int+++class Bits b => FiniteBits b where+  -- | Return the number of bits in the type of the argument.+  finiteBitSize :: Exp b -> Exp Int++  -- | Count the number of zero bits preceding the most significant set bit.+  -- This can be used to compute a base-2 logarithm via:+  --+  -- > logBase2 x = finiteBitSize x - 1 - countLeadingZeros x+  --+  countLeadingZeros :: Exp b -> Exp Int++  -- | Count the number of zero bits following the least significant set bit.+  -- The related+  -- <http://en.wikipedia.org/wiki/Find_first_set find-first-set operation> can+  -- be expressed in terms of this as:+  --+  -- > findFirstSet x = 1 + countTrailingZeros x+  --+  countTrailingZeros :: Exp b -> Exp Int+++-- Instances for Bits+-- ------------------++instance Bits Bool where+  (.&.)        = (&&)+  (.|.)        = (||)+  xor          = (/=)+  complement   = not+  shift x i    = cond (i == 0) x (constant False)+  testBit x i  = cond (i == 0) x (constant False)+  rotate x _   = x+  bit i        = i == 0+  isSigned     = isSignedDefault+  popCount     = mkBoolToInt++instance Bits Int where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits Int8 where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits Int16 where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits Int32 where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits Int64 where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits Word where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits Word8 where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits Word16 where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits Word32 where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits Word64 where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits CInt where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits CUInt where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits CLong where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits CULong where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits CLLong where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits CULLong where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits CShort where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++instance Bits CUShort where+  (.&.)        = mkBAnd+  (.|.)        = mkBOr+  xor          = mkBXor+  complement   = mkBNot+  bit          = bitDefault+  testBit      = testBitDefault+  shift        = shiftDefault+  shiftL       = shiftLDefault+  shiftR       = shiftRDefault+  unsafeShiftL = mkBShiftL+  unsafeShiftR = mkBShiftR+  rotate       = rotateDefault+  rotateL      = rotateLDefault+  rotateR      = rotateRDefault+  isSigned     = isSignedDefault+  popCount     = mkPopCount++-- instance Bits CChar where+--   (.&.)        = mkBAnd+--   (.|.)        = mkBOr+--   xor          = mkBXor+--   complement   = mkBNot+--   bit          = bitDefault+--   testBit      = testBitDefault+--   shift        = shiftDefault+--   shiftL       = shiftLDefault+--   shiftR       = shiftRDefault+--   unsafeShiftL = mkBShiftL+--   unsafeShiftR = mkBShiftR+--   rotate       = rotateDefault+--   rotateL      = rotateLDefault+--   rotateR      = rotateRDefault+--   isSigned     = isSignedDefault+--   popCount     = mkPopCount++-- instance Bits CUChar where+--   (.&.)        = mkBAnd+--   (.|.)        = mkBOr+--   xor          = mkBXor+--   complement   = mkBNot+--   bit          = bitDefault+--   testBit      = testBitDefault+--   shift        = shiftDefault+--   shiftL       = shiftLDefault+--   shiftR       = shiftRDefault+--   unsafeShiftL = mkBShiftL+--   unsafeShiftR = mkBShiftR+--   rotate       = rotateDefault+--   rotateL      = rotateLDefault+--   rotateR      = rotateRDefault+--   isSigned     = isSignedDefault+--   popCount     = mkPopCount++-- instance Bits CSChar where+--   (.&.)        = mkBAnd+--   (.|.)        = mkBOr+--   xor          = mkBXor+--   complement   = mkBNot+--   bit          = bitDefault+--   testBit      = testBitDefault+--   shift        = shiftDefault+--   shiftL       = shiftLDefault+--   shiftR       = shiftRDefault+--   unsafeShiftL = mkBShiftL+--   unsafeShiftR = mkBShiftR+--   rotate       = rotateDefault+--   rotateL      = rotateLDefault+--   rotateR      = rotateRDefault+--   isSigned     = isSignedDefault+--   popCount     = mkPopCount+++-- Instances for FiniteBits+-- ------------------------++instance FiniteBits Bool where+  finiteBitSize _      = constant 8 -- stored as Word8 {- (B.finiteBitSize (undefined::Bool)) -}+  countLeadingZeros  x = cond x 0 1+  countTrailingZeros x = cond x 0 1++instance FiniteBits Int where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits Int8 where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int8))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits Int16 where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int16))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits Int32 where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int32))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits Int64 where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Int64))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits Word where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits Word8 where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word8))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits Word16 where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word16))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits Word32 where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word32))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits Word64 where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::Word64))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits CInt where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::CInt))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits CUInt where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::CUInt))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits CLong where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::CLong))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits CULong where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::CULong))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits CLLong where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::CLLong))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits CULLong where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::CULLong))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits CShort where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::CShort))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++instance FiniteBits CUShort where+  finiteBitSize _    = constant (B.finiteBitSize (undefined::CUShort))+  countLeadingZeros  = mkCountLeadingZeros+  countTrailingZeros = mkCountTrailingZeros++-- instance FiniteBits CChar+-- instance FiniteBits CUChar+-- instance FiniteBits CSChar+++-- Default implementations+-- -----------------------++bitDefault :: (IsIntegral t, Bits t) => Exp Int -> Exp t+bitDefault x = constant 1 `shiftL` x++testBitDefault :: (IsIntegral t, Bits t) => Exp t -> Exp Int -> Exp Bool+testBitDefault x i = (x .&. bit i) /= constant 0++shiftDefault :: (FiniteBits t, IsIntegral t, B.Bits t) => Exp t -> Exp Int -> Exp t+shiftDefault x i+  = cond (i >= 0) (shiftLDefault x i)+                  (shiftRDefault x (-i))++shiftLDefault :: (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t+shiftLDefault x i+  = cond (i >= finiteBitSize x) (constant 0)+  $ mkBShiftL x i++shiftRDefault :: forall t. (B.Bits t, FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t+shiftRDefault+  | B.isSigned (undefined::t) = shiftRADefault+  | otherwise                 = shiftRLDefault++-- Shift the argument right (signed)+shiftRADefault :: (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t+shiftRADefault x i+  = cond (i >= finiteBitSize x) (cond (mkLt x (constant 0)) (constant (-1)) (constant 0))+  $ mkBShiftR x i++-- Shift the argument right (unsigned)+shiftRLDefault :: (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t+shiftRLDefault x i+  = cond (i >= finiteBitSize x) (constant 0)+  $ mkBShiftR x i++rotateDefault :: forall t. (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t+rotateDefault =+  case (integralType :: IntegralType t) of+    TypeInt{}     -> rotateDefault' (undefined::Word)+    TypeInt8{}    -> rotateDefault' (undefined::Word8)+    TypeInt16{}   -> rotateDefault' (undefined::Word16)+    TypeInt32{}   -> rotateDefault' (undefined::Word32)+    TypeInt64{}   -> rotateDefault' (undefined::Word64)+    TypeWord{}    -> rotateDefault' (undefined::Word)+    TypeWord8{}   -> rotateDefault' (undefined::Word8)+    TypeWord16{}  -> rotateDefault' (undefined::Word16)+    TypeWord32{}  -> rotateDefault' (undefined::Word32)+    TypeWord64{}  -> rotateDefault' (undefined::Word64)+    TypeCShort{}  -> rotateDefault' (undefined::CUShort)+    TypeCUShort{} -> rotateDefault' (undefined::CUShort)+    TypeCInt{}    -> rotateDefault' (undefined::CUInt)+    TypeCUInt{}   -> rotateDefault' (undefined::CUInt)+    TypeCLong{}   -> rotateDefault' (undefined::CULong)+    TypeCULong{}  -> rotateDefault' (undefined::CULong)+    TypeCLLong{}  -> rotateDefault' (undefined::CULLong)+    TypeCULLong{} -> rotateDefault' (undefined::CULLong)++rotateDefault'+    :: forall i w. (Elt w, FiniteBits i, IsIntegral i, IsIntegral w, IsIntegral (EltRepr i), IsIntegral (EltRepr w), BitSizeEq (EltRepr i) (EltRepr w), BitSizeEq (EltRepr w) (EltRepr i))+    => w {- dummy -}+    -> Exp i+    -> Exp Int+    -> Exp i+rotateDefault' _ x i+  = cond (i' == 0) x+  $ w2i ((x' `mkBShiftL` i') `mkBOr` (x' `mkBShiftR` (wsib - i')))+  where+    w2i  = mkBitcast :: Exp w -> Exp i+    i2w  = mkBitcast :: Exp i -> Exp w+    --+    x'   = i2w x+    i'   = i `mkBAnd` (wsib - 1)+    wsib = finiteBitSize x++rotateLDefault :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+rotateLDefault x i+  = cond (i == 0) x+  $ mkBRotateL x i++rotateRDefault :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+rotateRDefault x i+  = cond (i == 0) x+  $ mkBRotateR x i++isSignedDefault :: forall b. B.Bits b => Exp b -> Exp Bool+isSignedDefault _ = constant (B.isSigned (undefined::b))++{--+_popCountDefault :: forall a. (B.FiniteBits a, IsScalar a, Bits a, Num a) => Exp a -> Exp Int+_popCountDefault =+  $( [e| case B.finiteBitSize (undefined::a) of+           8  -> popCnt8  . mkUnsafeCoerce+           16 -> popCnt16 . mkUnsafeCoerce+           32 -> popCnt32 . mkUnsafeCoerce+           64 -> popCnt64 . mkUnsafeCoerce+           _  -> popCountKernighan |] )++-- http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan+popCountKernighan :: (Bits a, Num a) => Exp a -> Exp Int+popCountKernighan x = r+  where+    (r,_) = untup2+          $ while (\(untup2 -> (_,v)) -> v /= 0)+                  (\(untup2 -> (c,v)) -> tup2 (c+1, v .&. (v-1)))+                  (tup2 (0,x))++-- http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetParallel+popCnt8 :: Exp Word8 -> Exp Int+popCnt8 v1 = mkFromIntegral c+  where+    v2 = v1 - ((v1 `unsafeShiftR` 1) .&. 0x55)+    v3 = (v2 .&. 0x33) + ((v2 `unsafeShiftR` 2) .&. 0x33)+    v4 = (v3 + (v3 `unsafeShiftR` 4)) .&. 0x0F+    c  = v4 * 0x01++popCnt16 :: Exp Word16 -> Exp Int+popCnt16 v1 = mkFromIntegral c+  where+    v2 = v1 - ((v1 `unsafeShiftR` 1) .&. 0x5555)+    v3 = (v2 .&. 0x3333) + ((v2 `unsafeShiftR` 2) .&. 0x3333)+    v4 = (v3 + (v3 `unsafeShiftR` 4)) .&. 0x0F0F+    c  = (v4 * 0x0101) `unsafeShiftR` 8++popCnt32 :: Exp Word32 -> Exp Int+popCnt32 v1 = mkFromIntegral c+  where+    v2 = v1 - ((v1 `unsafeShiftR` 1) .&. 0x55555555)+    v3 = (v2 .&. 0x33333333) + ((v2 `unsafeShiftR` 2) .&. 0x33333333)+    v4 = (v3 + (v3 `unsafeShiftR` 4)) .&. 0x0F0F0F0F+    c  = (v4 * 0x01010101) `unsafeShiftR` 24++popCnt64 :: Exp Word64 -> Exp Int+popCnt64 v1 = mkFromIntegral c+  where+    v2 = v1 - ((v1 `unsafeShiftR` 1) .&. 0x5555555555555555)+    v3 = (v2 .&. 0x3333333333333333) + ((v2 `unsafeShiftR` 2) .&. 0x3333333333333333)+    v4 = (v3 + (v3 `unsafeShiftR` 4)) .&. 0X0F0F0F0F0F0F0F0F+    c  = (v4 * 0x0101010101010101) `unsafeShiftR` 56+--}+
+ src/Data/Array/Accelerate/Data/Complex.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ViewPatterns          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Data.Complex+-- Copyright   : [2015..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Complex numbers, stored in the usual C-style array-of-struct representation,+-- for easy interoperability.+--+module Data.Array.Accelerate.Data.Complex (++  -- * Rectangular from+  Complex(..),+  real,+  imag,++  -- * Polar form+  mkPolar,+  cis,+  polar,+  magnitude,+  phase,++  -- * Conjugate+  conjugate,++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Classes+import Data.Array.Accelerate.Data.Functor+import Data.Array.Accelerate.Prelude+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Prelude                                                      ( ($), undefined )+import Data.Complex                                                 ( Complex(..) )+import qualified Data.Complex                                       as C+import qualified Prelude                                            as P+++-- Use an array-of-structs representation for complex numbers. This matches the+-- standard C-style layout, but means that we can define instances only at+-- specific types (not for any type 'a') as we can only have vectors of+-- primitive type.+--+type instance EltRepr (Complex Half)    = V2 Half+type instance EltRepr (Complex Float)   = V2 Float+type instance EltRepr (Complex Double)  = V2 Double+type instance EltRepr (Complex CFloat)  = V2 CFloat+type instance EltRepr (Complex CDouble) = V2 CDouble++instance Elt (Complex Half) where+  eltType _        = TypeRscalar scalarType+  toElt (V2 r i)   = r :+ i+  fromElt (r :+ i) = V2 r i++instance Elt (Complex Float) where+  eltType _        = TypeRscalar scalarType+  toElt (V2 r i)   = r :+ i+  fromElt (r :+ i) = V2 r i++instance Elt (Complex Double) where+  eltType _        = TypeRscalar scalarType+  toElt (V2 r i)   = r :+ i+  fromElt (r :+ i) = V2 r i++instance Elt (Complex CFloat) where+  eltType _        = TypeRscalar scalarType+  toElt (V2 r i)   = r :+ i+  fromElt (r :+ i) = V2 r i++instance Elt (Complex CDouble) where+  eltType _        = TypeRscalar scalarType+  toElt (V2 r i)   = r :+ i+  fromElt (r :+ i) = V2 r i++instance cst a => IsProduct cst (Complex a) where+  type ProdRepr (Complex a) = ProdRepr (V2 a)+  fromProd cst (r :+ i) = fromProd cst (V2 r i)+  toProd cst p          = let (V2 r i) = toProd cst p in (r :+ i)+  prod cst _            = prod cst (undefined :: (V2 a))++instance (Lift Exp a, Elt (Plain a), Elt (Complex (Plain a))) => Lift Exp (Complex a) where+  type Plain (Complex a) = Complex (Plain a)+  lift (r :+ i)          = Exp $ Tuple (NilTup `SnocTup` lift r `SnocTup` lift i)++instance (Elt a, Elt (Complex a)) => Unlift Exp (Complex (Exp a)) where+  unlift e+    = let r     = Exp $ SuccTupIdx ZeroTupIdx `Prj` e+          i     = Exp $ ZeroTupIdx `Prj` e+      in+      r :+ i+++instance (Eq a, Elt (Complex a)) => Eq (Complex a) where+  x == y = let r1 :+ c1 = unlift x+               r2 :+ c2 = unlift y+           in  r1 == r2 && c1 == c2+  x /= y = let r1 :+ c1 = unlift x+               r2 :+ c2 = unlift y+           in  r1 /= r2 || c1 /= c2++instance (RealFloat a, Elt (Complex a)) => P.Num (Exp (Complex a)) where+  (+)           = lift2 ((+) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))+  (-)           = lift2 ((-) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))+  (*)           = lift2 ((*) :: Complex (Exp a) -> Complex (Exp a) -> Complex (Exp a))+  negate        = lift1 (negate :: Complex (Exp a) -> Complex (Exp a))+  signum z      = if z == 0+                    then z+                    else let x :+ y = unlift z+                             r      = magnitude z+                         in+                         lift (x/r :+ y/r)+  abs z         = lift (magnitude z :+ 0)+  fromInteger n = lift (fromInteger n :+ 0)++instance (RealFloat a, Elt (Complex a)) => P.Fractional (Exp (Complex a)) where+  fromRational x  = lift (fromRational x :+ 0)+  z / z'          = lift ((x*x''+y*y'') / d :+ (y*x''-x*y'') / d)+    where+      x  :+ y   = unlift z+      x' :+ y'  = unlift z'+      --+      x'' = scaleFloat k x'+      y'' = scaleFloat k y'+      k   = - max (exponent x') (exponent y')+      d   = x'*x'' + y'*y''++instance (RealFloat a, Elt (Complex a)) => P.Floating (Exp (Complex a)) where+  pi                      = lift $ pi :+ 0++  exp (unlift -> x :+ y)  = let expx = exp x+                            in  complex $ expx * cos y :+ expx * sin y++  log z                   = lift $ log (magnitude z) :+ phase z++  sqrt z@(unlift -> x :+ y) =+    if z == 0+      then 0+      else lift $ u :+ (y < 0 ? (-v, v))+    where+      (u,v) = unlift (x < 0 ? (lift (v',u'), lift (u',v')))+      v'    = abs y / (u'*2)+      u'    = sqrt ((magnitude z + abs x) / 2)++  x ** y =+    if y == 0 then 1 else+    if x == 0 then if exp_r > 0 then 0 else+                   if exp_r < 0 then lift (inf :+ 0)+                                else lift (nan :+ nan)+              else if isInfinite r || isInfinite i+                     then if exp_r > 0 then lift (inf :+ 0) else+                          if exp_r < 0 then 0+                                       else lift (nan :+ nan)+                     else exp (log x * y)+    where+      r     :+ i  = unlift x+      exp_r :+ _  = unlift y+      --+      inf = 1 / 0+      nan = 0 / 0++  sin (unlift -> x :+ y)  = complex $ sin x * cosh y :+ cos x * sinh y+  cos (unlift -> x :+ y)  = complex $ cos x * cosh y :+ (- sin x * sinh y)+  tan (unlift -> x :+ y)  = (complex $ sinx*coshy :+ cosx*sinhy) / (complex $ cosx*coshy :+ (-sinx*sinhy))+    where+      sinx  = sin x+      cosx  = cos x+      sinhy = sinh y+      coshy = cosh y++  sinh (unlift -> x :+ y) = complex $ cos y * sinh x :+ sin  y * cosh x+  cosh (unlift -> x :+ y) = complex $ cos y * cosh x :+ sin y * sinh x+  tanh (unlift -> x :+ y) = (complex $ cosy*sinhx :+ siny*coshx) / (complex $ cosy*coshx :+ siny*sinhx)+    where+      siny  = sin y+      cosy  = cos y+      sinhx = sinh x+      coshx = cosh x++  asin z@(unlift -> x :+ y) = complex $ y' :+ (-x')+    where+      x' :+ y' = unlift $ log ((complex ((-y):+x)) + sqrt (1 - z*z))++  acos z                    = complex $ y'' :+ (-x'')+    where+      x'' :+ y''  = unlift $ log (z + (complex ((-y') :+ x')))+      x'  :+ y'   = unlift $ sqrt (1 - z*z)++  atan z@(unlift -> x :+ y) = complex $ y' :+ (-x')+    where+      x' :+ y' = unlift $ log ((complex ((1-y):+x)) / sqrt (1+z*z))++  asinh z =  log (z + sqrt (1+z*z))+  acosh z =  log (z + (z+1) * sqrt ((z-1)/(z+1)))+  atanh z =  0.5 * log ((1.0+z) / (1.0-z))+++instance (FromIntegral a b, Num b, Elt (Complex b)) => FromIntegral a (Complex b) where+  fromIntegral x = lift (fromIntegral x :+ 0)++-- | @since 1.2.0.0+instance Functor Complex where+  fmap f (unlift -> r :+ i) = lift (f r :+ f i)+++-- Helper function to fix the types for lift (ugh)+--+complex :: (Elt a, Elt (Complex a)) => Complex (Exp a) -> Exp (Complex a)+complex = lift++-- | The non-negative magnitude of a complex number+--+magnitude :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp a+-- magnitude (unlift -> r :+ i) = sqrt (r*r + i*i)+magnitude (unlift -> r :+ i) = scaleFloat k (sqrt (sqr (scaleFloat mk r) + sqr (scaleFloat mk i)))+  where+    k     = max (exponent r) (exponent i)+    mk    = -k+    sqr z = z * z++-- | The phase of a complex number, in the range @(-'pi', 'pi']@. If the+-- magnitude is zero, then so is the phase.+--+phase :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp a+phase z@(unlift -> r :+ i) =+  if z == 0+    then 0+    else atan2 i r++-- | The function 'polar' takes a complex number and returns a (magnitude,+-- phase) pair in canonical form: the magnitude is non-negative, and the phase+-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.+--+polar :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp (a,a)+polar z =  lift (magnitude z, phase z)++-- | Form a complex number from polar components of magnitude and phase.+--+#if __GLASGOW_HASKELL__ <= 708+mkPolar :: forall a. (RealFloat a, Elt (Complex a)) => Exp a -> Exp a -> Exp (Complex a)+#else+mkPolar :: forall a. (Floating a,  Elt (Complex a)) => Exp a -> Exp a -> Exp (Complex a)+#endif+mkPolar = lift2 (C.mkPolar :: Exp a -> Exp a -> Complex (Exp a))++-- | @'cis' t@ is a complex value with magnitude @1@ and phase @t@ (modulo+-- @2*'pi'@).+--+#if __GLASGOW_HASKELL__ <= 708+cis :: forall a. (RealFloat a, Elt (Complex a)) => Exp a -> Exp (Complex a)+#else+cis :: forall a. (Floating a,  Elt (Complex a)) => Exp a -> Exp (Complex a)+#endif+cis = lift1 (C.cis :: Exp a -> Complex (Exp a))++-- | Return the real part of a complex number+--+real :: (Elt a, Elt (Complex a)) => Exp (Complex a) -> Exp a+real (unlift -> r :+ _) = r++-- | Return the imaginary part of a complex number+--+imag :: (Elt a, Elt (Complex a)) => Exp (Complex a) -> Exp a+imag (unlift -> _ :+ i) = i++-- | Return the complex conjugate of a complex number, defined as+--+-- > conjugate(Z) = X - iY+--+conjugate :: (Num a, Elt (Complex a)) => Exp (Complex a) -> Exp (Complex a)+conjugate z = lift $ real z :+ (- imag z)+
+ src/Data/Array/Accelerate/Data/Either.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Data.Either+-- Copyright   : [2018] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- @since 1.2.0.0+--++module Data.Array.Accelerate.Data.Either (++  Either(..),+  left, right,+  either, isLeft, isRight, fromLeft, fromRight, lefts, rights,++) where++import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Sugar                            hiding ( (!), shape, ignore, toIndex )+import Data.Array.Accelerate.Language                               hiding ( chr )+import Data.Array.Accelerate.Prelude                                hiding ( filter )+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Eq+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Ord++import Data.Array.Accelerate.Data.Functor+import Data.Array.Accelerate.Data.Monoid+#if __GLASGOW_HASKELL__ >= 800+import Data.Array.Accelerate.Data.Semigroup+#endif++import Data.Char+import Data.Either                                                  ( Either(..) )+import Data.Maybe+import Data.Typeable+import Foreign.C.Types+import Prelude                                                      ( (.), ($), const, undefined, otherwise )+++-- | Lift a value into the 'Left' constructor+--+left :: forall a b. (Elt a, Elt b) => Exp a -> Exp (Either a b)+left a = lift (Left a :: Either (Exp a) (Exp b))++-- | Lift a value into the 'Right' constructor+--+right :: forall a b. (Elt a, Elt b) => Exp b -> Exp (Either a b)+right b = lift (Right b :: Either (Exp a) (Exp b))+--+-- See Note: [lifting Nothing]+++-- | Return 'True' if the argument is a 'Left'-value+--+isLeft :: (Elt a, Elt b) => Exp (Either a b) -> Exp Bool+isLeft x = tag x == 0++-- | Return 'True' if the argument is a 'Right'-value+--+isRight :: (Elt a, Elt b) => Exp (Either a b) -> Exp Bool+isRight x = tag x == 1++-- | The 'fromLeft' function extracts the element out of the 'Left' constructor.+-- If the argument was actually 'Right', you will get an undefined value+-- instead.+--+fromLeft :: (Elt a, Elt b) => Exp (Either a b) -> Exp a+fromLeft x = Exp $ SuccTupIdx ZeroTupIdx `Prj` x++-- | The 'fromRight' function extracts the element out of the 'Right'+-- constructor. If the argument was actually 'Left', you will get an undefined+-- value instead.+--+fromRight :: (Elt a, Elt b) => Exp (Either a b) -> Exp b+fromRight x = Exp $ ZeroTupIdx `Prj` x++-- | The 'either' function performs case analysis on the 'Either' type. If the+-- value is @'Left' a@, apply the first function to @a@; if it is @'Right' b@,+-- apply the second function to @b@.+--+either :: (Elt a, Elt b, Elt c) => (Exp a -> Exp c) -> (Exp b -> Exp c) -> Exp (Either a b) -> Exp c+either f g x =+  cond (isLeft x) (f (fromLeft x)) (g (fromRight x))+++-- | Extract from the array of 'Either' all of the 'Left' elements, together+-- with a segment descriptor indicating how many elements along each dimension+-- were returned.+--+lefts :: (Shape sh, Slice sh, Elt a, Elt b)+      => Acc (Array (sh:.Int) (Either a b))+      -> Acc (Vector a, Array sh Int)+lefts es = filter' (map isLeft es) (map fromLeft es)++-- | Extract from the array of 'Either' all of the 'Right' elements, together+-- with a segment descriptor indicating how many elements along each dimension+-- were returned.+--+rights :: (Shape sh, Slice sh, Elt a, Elt b)+       => Acc (Array (sh:.Int) (Either a b))+       -> Acc (Vector b, Array sh Int)+rights es = filter' (map isRight es) (map fromRight es)+++instance Elt a => Functor (Either a) where+  fmap f = either left (right . f)++instance (Eq a, Eq b) => Eq (Either a b) where+  ex == ey = isLeft  ex && isLeft  ey ? ( fromLeft ex  == fromLeft ey+           , isRight ex && isRight ey ? ( fromRight ex == fromRight ey+           , {- else -}                   constant False ))++instance (Ord a, Ord b) => Ord (Either a b) where+  compare ex ey = isLeft  ex && isLeft  ey ? ( compare (fromLeft ex) (fromLeft ey)+                , isRight ex && isRight ey ? ( compare (fromRight ex) (fromRight ey)+                , {- else -}                   compare (tag ex) (tag ey) ))++#if __GLASGOW_HASKELL__ >= 800+instance (Elt a, Elt b) => Semigroup (Exp (Either a b)) where+  ex <> ey = isLeft ex ? ( ey, ex )+#endif++tag :: (Elt a, Elt b) => Exp (Either a b) -> Exp Word8+tag x = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` x++type instance EltRepr (Either a b) = TupleRepr (Word8, EltRepr a, EltRepr b)++instance (Elt a, Elt b) => Elt (Either a b) where+  eltType _ = eltType (undefined::(Word8,a,b))+  toElt ((((),0),a),_)  = Left  (toElt a)+  toElt (_         ,b)  = Right (toElt b)+  fromElt (Left a)      = ((((),0), fromElt a), undef' (eltType (undefined::b)))+  fromElt (Right b)     = ((((),1), undef' (eltType (undefined::a))), fromElt b)++instance (Elt a, Elt b) => IsProduct Elt (Either a b) where+  type ProdRepr (Either a b) = ProdRepr (Word8, a, b)+  toProd _ ((((),0),a),_) = Left a+  toProd _ (_         ,b) = Right b+  fromProd _ (Left a)   = ((((), 0), a), toElt (undef' (eltType (undefined::b))))+  fromProd _ (Right b)  = ((((), 1), toElt (undef' (eltType (undefined::a)))), b)+  prod cst _ = prod cst (undefined::(Word8,a,b))++instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b)) => Lift Exp (Either a b) where+  type Plain (Either a b) = Either (Plain a) (Plain b)+  lift (Left a)  = Exp . Tuple $ NilTup `SnocTup` constant 0 `SnocTup` lift a `SnocTup` undef+  lift (Right b) = Exp . Tuple $ NilTup `SnocTup` constant 1 `SnocTup` undef  `SnocTup` lift b+++-- Utilities+-- ---------++-- We need an undefined value for the Nothing case. We just fill this with+-- zeros, though it would be better if we can actually do nothing, and leave+-- those value in memory undefined.+--+undef' :: TupleType t -> t+undef' TypeRunit         = ()+undef' (TypeRpair ta tb) = (undef' ta, undef' tb)+undef' (TypeRscalar s)   = scalar s++scalar :: ScalarType t -> t+scalar (SingleScalarType t) = single t+scalar (VectorScalarType t) = vector t++single :: SingleType t -> t+single (NumSingleType    t) = num t+single (NonNumSingleType t) = nonnum t++vector :: VectorType t -> t+vector (Vector2Type t)  = let x = single t in V2 x x+vector (Vector3Type t)  = let x = single t in V3 x x x+vector (Vector4Type t)  = let x = single t in V4 x x x x+vector (Vector8Type t)  = let x = single t in V8 x x x x x x x x+vector (Vector16Type t) = let x = single t in V16 x x x x x x x x x x x x x x x x++num :: NumType t -> t+num (IntegralNumType t) | IntegralDict <- integralDict t = 0+num (FloatingNumType t) | FloatingDict <- floatingDict t = 0++nonnum :: NonNumType t -> t+nonnum TypeBool{}   = False+nonnum TypeChar{}   = chr 0+nonnum TypeCChar{}  = CChar 0+nonnum TypeCSChar{} = CSChar 0+nonnum TypeCUChar{} = CUChar 0+++filter'+    :: forall sh e. (Shape sh, Slice sh, Elt e)+    => Acc (Array (sh:.Int) Bool)     -- tags+    -> Acc (Array (sh:.Int) e)        -- values+    -> Acc (Vector e, Array sh Int)+filter' keep arr+  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+  = let+        (target, len)   = unlift $ scanl' (+) 0 (map boolToInt keep)+        prj ix          = keep!ix ? ( index1 (target!ix), ignore )+        dummy           = fill (index1 (the len)) undef+        result          = permute const dummy prj arr+    in+    null keep ?| ( lift (emptyArray, fill (constant Z) 0)+                 , lift (result, len)+                 )+  | otherwise+  = let+        sz              = indexTail (shape arr)+        (target, len)   = unlift $ scanl' (+) 0 (map boolToInt keep)+        (offset, valid) = unlift $ scanl' (+) 0 (flatten len)+        prj ix          = cond (keep!ix)+                               (index1 $ offset!index1 (toIndex sz (indexTail ix)) + target!ix)+                               ignore+        dummy           = fill (index1 (the valid)) undef+        result          = permute const dummy prj arr+    in+    null keep ?| ( lift (emptyArray, fill sz 0)+                 , lift (result, len)+                 )++emptyArray :: (Shape sh, Elt e) => Acc (Array sh e)+emptyArray = fill (constant empty) undef++matchShapeType :: forall s t. (Shape s, Shape t) => s -> t -> Maybe (s :~: t)+matchShapeType _ _+  | Just Refl <- matchTupleType (eltType (undefined::s)) (eltType (undefined::t))+  = gcast Refl++matchShapeType _ _+  = Nothing+
+ src/Data/Array/Accelerate/Data/Fold.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeOperators     #-}+-- |+-- Module      : Data.Array.Accelerate.Data.Fold+-- Copyright   : [2016..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Combine folds in 'Applicative' style to generate multiple results with+-- a single pass over the array. Based on Max Rabkin's "Beautiful Folding" [1]+-- and talks by Gabriel Gonzalez [2].+--+--  1. <http://squing.blogspot.com/2008/11/beautiful-folding.html>+--  2. <https://www.youtube.com/watch?v=6a5Ti0r8Q2s>+--++module Data.Array.Accelerate.Data.Fold (++  Fold(..), runFold,++) where++import Data.Array.Accelerate                                        hiding ( fold, sum, product, length )+import Data.Array.Accelerate.Data.Monoid+import qualified Data.Array.Accelerate                              as A++import Control.Applicative                                          as P+import Prelude                                                      hiding ( sum, product, length )+import qualified Prelude                                            as P+++-- | 'Fold' describes how to process data of some 'i'nput type into some+-- 'o'utput type, via a reduction using some intermediate Monoid 'w'. For+-- example, both 'sum' and 'length' below use the 'Sum' monoid:+--+-- > sum = Fold (lift . Sum) (getSum . unlift)+-- > length = Fold (\_ -> 1) (getSum . unlift)+--+-- The key is that 'Fold's can be combined using 'Applicative' in order to+-- produce multiple outputs from a /single/ reduction of the array. For example:+--+-- > average = (/) <$> sum <*> length+--+-- This computes both the sum of the array as well as its length in a single+-- traversal, then combines both results to compute the average.+--+-- Because 'Fold' has some numeric instances, this can also be defined more+-- succinctly as:+--+-- > average = sum / length+--+-- A more complex example:+--+-- > sumOfSquares = Fold (lift . Sum . (^2)) (getSum . unlift)+-- > standardDeviation = sqrt ((sumOfSquares / length) - (sum / length) ^ 2)+--+-- These will all execute with a single reduction kernel and a single map to+-- summarise (combine) the results.+--+data Fold i o where+  Fold :: (Elt w, Monoid (Exp w))+       => (i -> Exp w)              -- transform input element into internal monoid type+       -> (Exp w -> o)              -- summarise the reduction to retrieve the final result+       -> Fold i o++-- | Apply a 'Fold' to an array.+--+runFold+    :: (Shape sh, Elt i, Elt o)+    => Fold (Exp i) (Exp o)+    -> Acc (Array (sh:.Int) i)+    -> Acc (Array sh o)+runFold (Fold tally summarise) is+  = A.map summarise+  $ A.fold mappend mempty+  $ A.map tally is+++-- sum :: A.Num e => Fold (Exp e) (Exp e)+-- sum = Fold (lift . Sum) (getSum . unlift)++-- product :: A.Num e => Fold (Exp e) (Exp e)+-- product = Fold (lift . Product) (getProduct . unlift)++-- length :: A.Num i => Fold (Exp e) (Exp i)+-- length = Fold (\_ -> 1) (getSum . unlift)+++-- combine2 :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a,b)+-- combine2 a b = lift (a,b)++-- combine3 :: (Elt a, Elt b, Elt c) => Exp a -> Exp b -> Exp c -> Exp (a,b,c)+-- combine3 a b c = lift (a,b,c)++-- combine4 :: (Elt a, Elt b, Elt c, Elt d) => Exp a -> Exp b -> Exp c -> Exp d -> Exp (a,b,c,d)+-- combine4 a b c d = lift (a,b,c,d)++-- combine5 :: (Elt a, Elt b, Elt c, Elt d, Elt e) => Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp (a,b,c,d,e)+-- combine5 a b c d e = lift (a,b,c,d,e)+++-- Instances for 'Fold'+-- --------------------++instance P.Functor (Fold i) where+  fmap k (Fold tally summarise) = Fold tally (k . summarise)++instance P.Applicative (Fold i) where+  pure o                    = Fold (\_ -> constant ()) (\_ -> o)+  Fold tF sF <*> Fold tX sX = Fold tally summarise+    where+      tally i     = lift (tF i, tX i)+      summarise t = let (mF, mX) = unlift t+                    in sF mF (sX mX)++instance A.Num b => P.Num (Fold a (Exp b)) where+  (+)           = liftA2 (+)+  (-)           = liftA2 (-)+  (*)           = liftA2 (*)+  negate        = fmap negate+  abs           = fmap abs+  signum        = fmap signum+  fromInteger n = pure (A.fromInteger n)++instance A.Fractional b => P.Fractional (Fold a (Exp b)) where+  (/)            = liftA2 (/)+  recip          = fmap recip+  fromRational n = pure (A.fromRational n)++instance A.Floating b => P.Floating (Fold a (Exp b)) where+  pi      = pure pi+  sin     = fmap sin+  cos     = fmap cos+  tan     = fmap tan+  asin    = fmap asin+  acos    = fmap acos+  atan    = fmap atan+  sinh    = fmap sinh+  cosh    = fmap cosh+  tanh    = fmap tanh+  asinh   = fmap asinh+  acosh   = fmap acosh+  atanh   = fmap atanh+  exp     = fmap exp+  sqrt    = fmap sqrt+  log     = fmap log+  (**)    = liftA2 (**)+  logBase = liftA2 logBase+
+ src/Data/Array/Accelerate/Data/Functor.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP              #-}+{-# LANGUAGE RebindableSyntax #-}+-- |+-- Module      : Data.Array.Accelerate.Data.Functor+-- Copyright   : [2018] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- A functor performs a uniform action over a parameterised type+--+-- This is essentially the same as the standard Haskell 'Prelude.Functor' class,+-- lifted to Accelarete 'Exp' terms.+--+-- @since 1.2.0.0+--++module Data.Array.Accelerate.Data.Functor (++  Functor(..),+  (<$>),+  ($>),+  void,++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Lift+import Data.Array.Accelerate.Smart++import Data.Monoid+import Prelude                                                      ( flip )+#if __GLASGOW_HASKELL__ >= 800+import Data.Semigroup+#endif+import Prelude                                                      ( (.), const )+++-- | The 'Functor' class is used for scalar types which can be mapped over.+-- Instances of 'Functor' should satisfy the following laws:+--+-- > fmap id      == id+-- > fmap (f . g) == fmap f . fmap g+--+class Functor f where+  fmap :: (Elt a, Elt b, Elt (f a), Elt (f b)) => (Exp a -> Exp b) -> Exp (f a) -> Exp (f b)++  -- | Replace all locations in the input with the same value. The default+  -- definition is @fmap . const@, but this may be overridden with a more+  -- efficient version.+  --+  infixl 4 <$+  (<$) :: (Elt a, Elt b, Elt (f a), Elt (f b)) => Exp a -> Exp (f b) -> Exp (f a)+  (<$) = fmap . const+++-- | An infix synonym for 'fmap'+--+-- The name of this operator is an allusion to 'Prelude.$'. Note the+-- similarities between their types:+--+-- >  ($)  ::              (Exp a -> Exp b) -> Exp a     -> Exp b+-- > (<$>) :: Functor f => (Exp a -> Exp b) -> Exp (f a) -> Exp (f b)+--+-- Whereas 'Prelude.$' is function application, '<$>' is function application+-- lifted over a 'Functor'.+--+infixl 4 <$>+(<$>) :: (Functor f, Elt a, Elt b, Elt (f a), Elt (f b)) => (Exp a -> Exp b) -> Exp (f a) -> Exp (f b)+(<$>) = fmap+++-- | A flipped version of '(<$)'.+--+infixl 4 $>+($>) :: (Functor f, Elt a, Elt b, Elt (f a), Elt (f b)) => Exp (f a) -> Exp b -> Exp (f b)+($>) = flip (<$)+++-- | @'void' value@ discards or ignores the result of evaluation.+--+void :: (Functor f, Elt a, Elt (f a), Elt (f ())) => Exp (f a) -> Exp (f ())+void x = constant () <$ x+++instance Functor Sum where+  fmap f = lift1 (fmap f)++instance Functor Product where+  fmap f = lift1 (fmap f)++#if __GLASGOW_HASKELL__ >= 800+instance Functor Min where+  fmap f = lift1 (fmap f)++instance Functor Max where+  fmap f = lift1 (fmap f)+#endif+
+ src/Data/Array/Accelerate/Data/Maybe.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Data.Maybe+-- Copyright   : [2018] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- @since 1.2.0.0+--++module Data.Array.Accelerate.Data.Maybe (++  Maybe(..),+  just, nothing,+  maybe, isJust, isNothing, fromMaybe, fromJust, justs,++) where++import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Sugar                            hiding ( (!), shape, ignore, toIndex )+import Data.Array.Accelerate.Language                               hiding ( chr )+import Data.Array.Accelerate.Prelude                                hiding ( filter )+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Eq+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Ord++import Data.Array.Accelerate.Data.Functor+import Data.Array.Accelerate.Data.Monoid+#if __GLASGOW_HASKELL__ >= 800+import Data.Array.Accelerate.Data.Semigroup+#endif++import Data.Char+import Data.Maybe                                                   ( Maybe(..) )+import Data.Typeable+import Foreign.C.Types+import Prelude                                                      ( (.), ($), const, undefined, otherwise )+++-- | Lift a value into a 'Just' constructor+--+just :: Elt a => Exp a -> Exp (Maybe a)+just x = lift (Just x)++-- | The 'Nothing' constructor+--+nothing :: forall a. Elt a => Exp (Maybe a)+nothing = lift (Nothing :: Maybe (Exp a))+--+-- Note: [lifting Nothing]+--+-- The lift instance for 'Nothing' uses our magic 'undef' term, meaning that our+-- backends will know that we can leave this slot in the values array undefined.+-- If we had instead written 'constant Nothing' this would result in writing an+-- actual (unspecified) value into the values array, which is what we want to+-- avoid.+--++-- | Returns 'True' if the argument is 'Nothing'+--+isNothing :: Elt a => Exp (Maybe a) -> Exp Bool+isNothing x = tag x == 0++-- | Returns 'True' if the argument is of the form @Just _@+--+isJust :: Elt a => Exp (Maybe a) -> Exp Bool+isJust x = tag x == 1++-- | The 'fromMaybe' function takes a default value and a 'Maybe' value. If the+-- 'Maybe' is 'Nothing', the default value is returned; otherwise, it returns+-- the value contained in the 'Maybe'.+--+fromMaybe :: Elt a => Exp a -> Exp (Maybe a) -> Exp a+fromMaybe d x = cond (isNothing x) d (fromJust x)++-- | The 'fromJust' function extracts the element out of the 'Just' constructor.+-- If the argument was actually 'Nothing', you will get an undefined value+-- instead.+--+fromJust :: Elt a => Exp (Maybe a) -> Exp a+fromJust x = Exp $ ZeroTupIdx `Prj` x++-- | The 'maybe' function takes a default value, a function, and a 'Maybe'+-- value. If the 'Maybe' value is nothing, the default value is returned;+-- otherwise, it applies the function to the value inside the 'Just' and returns+-- the result+--+maybe :: (Elt a, Elt b) => Exp b -> (Exp a -> Exp b) -> Exp (Maybe a) -> Exp b+maybe d f x = cond (isNothing x) d (f (fromJust x))+++-- | Extract from an array all of the 'Just' values, together with a segment+-- descriptor indicating how many elements along each dimension were returned.+--+justs :: (Shape sh, Slice sh, Elt a)+      => Acc (Array (sh:.Int) (Maybe a))+      -> Acc (Vector a, Array sh Int)+justs xs = filter' (map isJust xs) (map fromJust xs)+++instance Functor Maybe where+  fmap f x = cond (isNothing x) (constant Nothing) (lift (Just (f (fromJust x))))++instance Eq a => Eq (Maybe a) where+  ma == mb = cond (isNothing ma && isNothing mb) (constant True)+           $ cond (isJust ma    && isJust mb)    (fromJust ma == fromJust mb)+           $ constant False++instance Ord a => Ord (Maybe a) where+  compare ma mb = cond (isJust ma && isJust mb)+                       (compare (fromJust ma) (fromJust mb))+                       (compare (tag ma) (tag mb))++instance (Monoid (Exp a), Elt a) => Monoid (Exp (Maybe a)) where+  mempty        = constant Nothing+#if __GLASGOW_HASKELL__ < 804+  mappend ma mb = cond (isNothing ma) mb+                $ cond (isNothing mb) ma+                $ lift (Just (fromJust ma `mappend` fromJust mb))+#endif++#if __GLASGOW_HASKELL__ >= 800+instance (Semigroup (Exp a), Elt a) => Semigroup (Exp (Maybe a)) where+  ma <> mb = cond (isNothing ma) mb+           $ cond (isNothing mb) mb+           $ lift (Just (fromJust ma <> fromJust mb))+#endif+++tag :: Elt a => Exp (Maybe a) -> Exp Word8+tag x = Exp $ SuccTupIdx ZeroTupIdx `Prj` x+++type instance EltRepr (Maybe a) = TupleRepr (Word8, EltRepr a)++instance Elt a => Elt (Maybe a) where+  eltType _        = eltType (undefined::(Word8,a))+  toElt (((),0),_) = Nothing+  toElt (_     ,x) = Just (toElt x)+  fromElt Nothing  = (((),0), undef' (eltType (undefined::a)))+  fromElt (Just a) = (((),1), fromElt a)++instance Elt a => IsProduct Elt (Maybe a) where+  type ProdRepr (Maybe a) = ProdRepr (Word8, a)+  toProd _ (((),0),_) = Nothing+  toProd _ (_,     x) = Just x+  fromProd _ Nothing  = (((), 0), toElt (undef' (eltType (undefined::a))))+  fromProd _ (Just a) = (((), 1), a)+  prod cst _ = prod cst (undefined :: (Word8,a))++instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Maybe a) where+  type Plain (Maybe a) = Maybe (Plain a)+  lift Nothing  = Exp . Tuple $ NilTup `SnocTup` constant 0 `SnocTup` undef+  lift (Just x) = Exp . Tuple $ NilTup `SnocTup` constant 1 `SnocTup` lift x+++-- Utilities+-- ---------++-- We need an undefined value for the Nothing case. We just fill this with+-- zeros, though it would be better if we can actually do nothing, and leave+-- those value in memory undefined.+--+undef' :: TupleType t -> t+undef' TypeRunit         = ()+undef' (TypeRpair ta tb) = (undef' ta, undef' tb)+undef' (TypeRscalar s)   = scalar s++scalar :: ScalarType t -> t+scalar (SingleScalarType t) = single t+scalar (VectorScalarType t) = vector t++single :: SingleType t -> t+single (NumSingleType    t) = num t+single (NonNumSingleType t) = nonnum t++vector :: VectorType t -> t+vector (Vector2Type t)  = let x = single t in V2 x x+vector (Vector3Type t)  = let x = single t in V3 x x x+vector (Vector4Type t)  = let x = single t in V4 x x x x+vector (Vector8Type t)  = let x = single t in V8 x x x x x x x x+vector (Vector16Type t) = let x = single t in V16 x x x x x x x x x x x x x x x x++num :: NumType t -> t+num (IntegralNumType t) | IntegralDict <- integralDict t = 0+num (FloatingNumType t) | FloatingDict <- floatingDict t = 0++nonnum :: NonNumType t -> t+nonnum TypeBool{}   = False+nonnum TypeChar{}   = chr 0+nonnum TypeCChar{}  = CChar 0+nonnum TypeCSChar{} = CSChar 0+nonnum TypeCUChar{} = CUChar 0+++filter'+    :: forall sh e. (Shape sh, Slice sh, Elt e)+    => Acc (Array (sh:.Int) Bool)     -- tags+    -> Acc (Array (sh:.Int) e)        -- values+    -> Acc (Vector e, Array sh Int)+filter' keep arr+  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+  = let+        (target, len)   = unlift $ scanl' (+) 0 (map boolToInt keep)+        prj ix          = keep!ix ? ( index1 (target!ix), ignore )+        dummy           = fill (index1 (the len)) undef+        result          = permute const dummy prj arr+    in+    null keep ?| ( lift (emptyArray, fill (constant Z) 0)+                 , lift (result, len)+                 )+  | otherwise+  = let+        sz              = indexTail (shape arr)+        (target, len)   = unlift $ scanl' (+) 0 (map boolToInt keep)+        (offset, valid) = unlift $ scanl' (+) 0 (flatten len)+        prj ix          = cond (keep!ix)+                               (index1 $ offset!index1 (toIndex sz (indexTail ix)) + target!ix)+                               ignore+        dummy           = fill (index1 (the valid)) undef+        result          = permute const dummy prj arr+    in+    null keep ?| ( lift (emptyArray, fill sz 0)+                 , lift (result, len)+                 )++emptyArray :: (Shape sh, Elt e) => Acc (Array sh e)+emptyArray = fill (constant empty) undef++matchShapeType :: forall s t. (Shape s, Shape t) => s -> t -> Maybe (s :~: t)+matchShapeType _ _+  | Just Refl <- matchTupleType (eltType (undefined::s)) (eltType (undefined::t))+  = gcast Refl++matchShapeType _ _+  = Nothing+
+ src/Data/Array/Accelerate/Data/Monoid.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Data.Monoid+-- Copyright   : [2016..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Monoid instances for Accelerate+--+-- @since 1.2.0.0+--++module Data.Array.Accelerate.Data.Monoid (++  Monoid(..), (<>),++  Sum(..),+  Product(..),++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Classes.Bounded+import Data.Array.Accelerate.Classes.Eq+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Ord+import Data.Array.Accelerate.Language+import Data.Array.Accelerate.Lift+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type+#if __GLASGOW_HASKELL__ >= 800+import Data.Array.Accelerate.Data.Semigroup                         ()+#endif++import Data.Function+#if __GLASGOW_HASKELL__ >= 800+import Data.Monoid                                                  hiding ( (<>) )+import Data.Semigroup+#else+import Data.Monoid+#endif+import Prelude                                                      ( undefined )+import qualified Prelude                                            as P+++-- Sum: Monoid under addition+-- --------------------------++type instance EltRepr (Sum a) = ((), EltRepr a)++instance Elt a => Elt (Sum a) where+  eltType _       = TypeRpair TypeRunit (eltType (undefined::a))+  toElt ((),x)    = Sum (toElt x)+  fromElt (Sum x) = ((), fromElt x)++instance Elt a => IsProduct Elt (Sum a) where+  type ProdRepr (Sum a) = ((), a)+  toProd _ ((),a)    = Sum a+  fromProd _ (Sum a) = ((),a)+  prod _ _           = ProdRsnoc ProdRunit++instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Sum a) where+  type Plain (Sum a) = Sum (Plain a)+  lift (Sum a)       = Exp $ Tuple $ NilTup `SnocTup` lift a++instance Elt a => Unlift Exp (Sum (Exp a)) where+  unlift t = Sum . Exp $ ZeroTupIdx `Prj` t++instance Bounded a => P.Bounded (Exp (Sum a)) where+  minBound = lift $ Sum (minBound :: Exp a)+  maxBound = lift $ Sum (maxBound :: Exp a)++instance Num a => P.Num (Exp (Sum a)) where+  (+)             = lift2 ((+) :: Sum (Exp a) -> Sum (Exp a) -> Sum (Exp a))+  (-)             = lift2 ((-) :: Sum (Exp a) -> Sum (Exp a) -> Sum (Exp a))+  (*)             = lift2 ((*) :: Sum (Exp a) -> Sum (Exp a) -> Sum (Exp a))+  negate          = lift1 (negate :: Sum (Exp a) -> Sum (Exp a))+  signum          = lift1 (signum :: Sum (Exp a) -> Sum (Exp a))+  abs             = lift1 (signum :: Sum (Exp a) -> Sum (Exp a))+  fromInteger x   = lift (P.fromInteger x :: Sum (Exp a))++instance Eq a => Eq (Sum a) where+  (==) = lift2 ((==) `on` getSum)+  (/=) = lift2 ((/=) `on` getSum)++instance Ord a => Ord (Sum a) where+  (<)     = lift2 ((<) `on` getSum)+  (>)     = lift2 ((>) `on` getSum)+  (<=)    = lift2 ((<=) `on` getSum)+  (>=)    = lift2 ((>=) `on` getSum)+  min x y = lift . Sum $ lift2 (min `on` getSum) x y+  max x y = lift . Sum $ lift2 (max `on` getSum) x y++instance Num a => Monoid (Exp (Sum a)) where+  mempty  = 0+#if __GLASGOW_HASKELL__ <  804+#if __GLASGOW_HASKELL__ >= 800+  mappend = (<>)+#else+  mappend = lift2 (mappend :: Sum (Exp a) -> Sum (Exp a) -> Sum (Exp a))+#endif+#endif++#if __GLASGOW_HASKELL__ >= 800+-- | @since 1.2.0.0+instance Num a => Semigroup (Exp (Sum a)) where+  (<>)       = (+)+  stimes n x = lift . Sum $ P.fromIntegral n * getSum (unlift x :: Sum (Exp a))+#endif+++-- Product: Monoid under multiplication+-- ------------------------------------++type instance EltRepr (Product a) = ((), EltRepr a)++instance Elt a => Elt (Product a) where+  eltType _       = TypeRpair TypeRunit (eltType (undefined::a))+  toElt ((),x)    = Product (toElt x)+  fromElt (Product x) = ((), fromElt x)++instance Elt a => IsProduct Elt (Product a) where+  type ProdRepr (Product a) = ((), a)+  toProd _ ((),a)        = Product a+  fromProd _ (Product a) = ((),a)+  prod _ _               = ProdRsnoc ProdRunit++instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Product a) where+  type Plain (Product a) = Product (Plain a)+  lift (Product a)       = Exp $ Tuple $ NilTup `SnocTup` lift a++instance Elt a => Unlift Exp (Product (Exp a)) where+  unlift t = Product . Exp $ ZeroTupIdx `Prj` t++instance Bounded a => P.Bounded (Exp (Product a)) where+  minBound = lift $ Product (minBound :: Exp a)+  maxBound = lift $ Product (maxBound :: Exp a)++instance Num a => P.Num (Exp (Product a)) where+  (+)             = lift2 ((+) :: Product (Exp a) -> Product (Exp a) -> Product (Exp a))+  (-)             = lift2 ((-) :: Product (Exp a) -> Product (Exp a) -> Product (Exp a))+  (*)             = lift2 ((*) :: Product (Exp a) -> Product (Exp a) -> Product (Exp a))+  negate          = lift1 (negate :: Product (Exp a) -> Product (Exp a))+  signum          = lift1 (signum :: Product (Exp a) -> Product (Exp a))+  abs             = lift1 (signum :: Product (Exp a) -> Product (Exp a))+  fromInteger x   = lift (P.fromInteger x :: Product (Exp a))++instance Eq a => Eq (Product a) where+  (==) = lift2 ((==) `on` getProduct)+  (/=) = lift2 ((/=) `on` getProduct)++instance Ord a => Ord (Product a) where+  (<)     = lift2 ((<) `on` getProduct)+  (>)     = lift2 ((>) `on` getProduct)+  (<=)    = lift2 ((<=) `on` getProduct)+  (>=)    = lift2 ((>=) `on` getProduct)+  min x y = lift . Product $ lift2 (min `on` getProduct) x y+  max x y = lift . Product $ lift2 (max `on` getProduct) x y++instance Num a => Monoid (Exp (Product a)) where+  mempty  = 1+#if __GLASGOW_HASKELL__ <  804+#if __GLASGOW_HASKELL__ >= 800+  mappend = (<>)+#else+  mappend = lift2 (mappend :: Product (Exp a) -> Product (Exp a) -> Product (Exp a))+#endif+#endif++#if __GLASGOW_HASKELL__ >= 800+-- | @since 1.2.0.0+instance Num a => Semigroup (Exp (Product a)) where+  (<>)       = (*)+  stimes n x = lift . Product $ getProduct (unlift x :: Product (Exp a)) ^ (P.fromIntegral n :: Exp Int)+#endif+++-- Instances for unit and tuples+-- -----------------------------++instance Monoid (Exp ()) where+  mempty      = constant ()+#if __GLASGOW_HASKELL__ <  804+#if __GLASGOW_HASKELL__ >= 800+  mappend     = (<>)+#else+  mappend _ _ = constant ()+#endif+#endif++-- TLM: despite what -Wcompat tells us, we can not use the canonical+-- implementation `mappend = (<>)` on GHC-8.0 and 8.2 without changing the+-- instance heads to include a `Semigroup` constraint.+--+instance (Elt a, Elt b, Monoid (Exp a), Monoid (Exp b)) => Monoid (Exp (a,b)) where+  mempty      = lift (mempty :: Exp a, mempty :: Exp b)+#if __GLASGOW_HASKELL__ < 804+  mappend x y = let (a1,b1) = unlift x  :: (Exp a, Exp b)+                    (a2,b2) = unlift y+                in+                lift (a1 `mappend` a2, b1 `mappend` b2)+#endif++instance (Elt a, Elt b, Elt c, Monoid (Exp a), Monoid (Exp b), Monoid (Exp c)) => Monoid (Exp (a,b,c)) where+  mempty      = lift (mempty :: Exp a, mempty :: Exp b, mempty :: Exp c)+#if __GLASGOW_HASKELL__ < 804+  mappend x y = let (a1,b1,c1) = unlift x  :: (Exp a, Exp b, Exp c)+                    (a2,b2,c2) = unlift y+                in+                lift (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)+#endif++instance (Elt a, Elt b, Elt c, Elt d, Monoid (Exp a), Monoid (Exp b), Monoid (Exp c), Monoid (Exp d)) => Monoid (Exp (a,b,c,d)) where+  mempty      = lift (mempty :: Exp a, mempty :: Exp b, mempty :: Exp c, mempty :: Exp d)+#if __GLASGOW_HASKELL__ < 804+  mappend x y = let (a1,b1,c1,d1) = unlift x  :: (Exp a, Exp b, Exp c, Exp d)+                    (a2,b2,c2,d2) = unlift y+                in+                lift (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2, d1 `mappend` d2)+#endif++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Monoid (Exp a), Monoid (Exp b), Monoid (Exp c), Monoid (Exp d), Monoid (Exp e)) => Monoid (Exp (a,b,c,d,e)) where+  mempty      = lift (mempty :: Exp a, mempty :: Exp b, mempty :: Exp c, mempty :: Exp d, mempty :: Exp e)+#if __GLASGOW_HASKELL__ < 804+  mappend x y = let (a1,b1,c1,d1,e1) = unlift x  :: (Exp a, Exp b, Exp c, Exp d, Exp e)+                    (a2,b2,c2,d2,e2) = unlift y+                in+                lift (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2, d1 `mappend` d2, e1 `mappend` e2)+#endif+
+ src/Data/Array/Accelerate/Data/Semigroup.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE ViewPatterns          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.Data.Semigroup+-- Copyright   : [2018] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Semigroup instances for Accelerate+--+-- @since 1.2.0.0+--++module Data.Array.Accelerate.Data.Semigroup (++  Semigroup(..),++  Min(..),+  Max(..),++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Classes.Bounded+import Data.Array.Accelerate.Classes.Eq+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Ord+import Data.Array.Accelerate.Lift+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Function+import Data.Monoid                                                  ( Monoid(..) )+import Data.Semigroup+import Prelude                                                      ( undefined )+import qualified Prelude                                            as P+++type instance EltRepr (Min a) = ((), EltRepr a)++instance Elt a => Elt (Min a) where+  eltType _       = TypeRpair TypeRunit (eltType (undefined::a))+  toElt ((),x)    = Min (toElt x)+  fromElt (Min x) = ((), fromElt x)++instance Elt a => IsProduct Elt (Min a) where+  type ProdRepr (Min a) = ((), a)+  toProd _ ((),a)    = Min a+  fromProd _ (Min a) = ((),a)+  prod _ _           = ProdRsnoc ProdRunit++instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Min a) where+  type Plain (Min a) = Min (Plain a)+  lift (Min a)       = Exp $ Tuple $ NilTup `SnocTup` lift a++instance Elt a => Unlift Exp (Min (Exp a)) where+  unlift t = Min . Exp $ ZeroTupIdx `Prj` t++instance Bounded a => P.Bounded (Exp (Min a)) where+  minBound = lift $ Min (minBound :: Exp a)+  maxBound = lift $ Min (maxBound :: Exp a)++instance Num a => P.Num (Exp (Min a)) where+  (+)           = lift2 ((+) :: Min (Exp a) -> Min (Exp a) -> Min (Exp a))+  (-)           = lift2 ((-) :: Min (Exp a) -> Min (Exp a) -> Min (Exp a))+  (*)           = lift2 ((*) :: Min (Exp a) -> Min (Exp a) -> Min (Exp a))+  negate        = lift1 (negate :: Min (Exp a) -> Min (Exp a))+  signum        = lift1 (signum :: Min (Exp a) -> Min (Exp a))+  abs           = lift1 (signum :: Min (Exp a) -> Min (Exp a))+  fromInteger x = lift (P.fromInteger x :: Min (Exp a))++instance Eq a => Eq (Min a) where+  (==) = lift2 ((==) `on` getMin)+  (/=) = lift2 ((/=) `on` getMin)++instance Ord a => Ord (Min a) where+  (<)     = lift2 ((<) `on` getMin)+  (>)     = lift2 ((>) `on` getMin)+  (<=)    = lift2 ((<=) `on` getMin)+  (>=)    = lift2 ((>=) `on` getMin)+  min x y = lift . Min $ lift2 (min `on` getMin) x y+  max x y = lift . Min $ lift2 (max `on` getMin) x y++instance Ord a => Semigroup (Exp (Min a)) where+  x <> y  = lift . Min $ lift2 (min `on` getMin) x y+  stimes  = stimesIdempotent++instance (Ord a, Bounded a) => Monoid (Exp (Min a)) where+  mempty  = maxBound+  mappend = (<>)+++type instance EltRepr (Max a) = ((), EltRepr a)++instance Elt a => Elt (Max a) where+  eltType _       = TypeRpair TypeRunit (eltType (undefined::a))+  toElt ((),x)    = Max (toElt x)+  fromElt (Max x) = ((), fromElt x)++instance Elt a => IsProduct Elt (Max a) where+  type ProdRepr (Max a) = ((), a)+  toProd _ ((),a)    = Max a+  fromProd _ (Max a) = ((),a)+  prod _ _           = ProdRsnoc ProdRunit++instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Max a) where+  type Plain (Max a) = Max (Plain a)+  lift (Max a)       = Exp $ Tuple $ NilTup `SnocTup` lift a++instance Elt a => Unlift Exp (Max (Exp a)) where+  unlift t = Max . Exp $ ZeroTupIdx `Prj` t++instance Bounded a => P.Bounded (Exp (Max a)) where+  minBound = lift $ Max (minBound :: Exp a)+  maxBound = lift $ Max (maxBound :: Exp a)++instance Num a => P.Num (Exp (Max a)) where+  (+)           = lift2 ((+) :: Max (Exp a) -> Max (Exp a) -> Max (Exp a))+  (-)           = lift2 ((-) :: Max (Exp a) -> Max (Exp a) -> Max (Exp a))+  (*)           = lift2 ((*) :: Max (Exp a) -> Max (Exp a) -> Max (Exp a))+  negate        = lift1 (negate :: Max (Exp a) -> Max (Exp a))+  signum        = lift1 (signum :: Max (Exp a) -> Max (Exp a))+  abs           = lift1 (signum :: Max (Exp a) -> Max (Exp a))+  fromInteger x = lift (P.fromInteger x :: Max (Exp a))++instance Eq a => Eq (Max a) where+  (==) = lift2 ((==) `on` getMax)+  (/=) = lift2 ((/=) `on` getMax)++instance Ord a => Ord (Max a) where+  (<)     = lift2 ((<) `on` getMax)+  (>)     = lift2 ((>) `on` getMax)+  (<=)    = lift2 ((<=) `on` getMax)+  (>=)    = lift2 ((>=) `on` getMax)+  min x y = lift . Max $ lift2 (min `on` getMax) x y+  max x y = lift . Max $ lift2 (max `on` getMax) x y++instance Ord a => Semigroup (Exp (Max a)) where+  x <> y  = lift . Max $ lift2 (max `on` getMax) x y+  stimes  = stimesIdempotent++instance (Ord a, Bounded a) => Monoid (Exp (Max a)) where+  mempty  = minBound+  mappend = (<>)+++-- Instances for unit and tuples+-- -----------------------------++instance Semigroup (Exp ()) where+  _ <> _     = constant ()+  sconcat _  = constant ()+  stimes _ _ = constant ()++instance (Elt a, Elt b, Semigroup (Exp a), Semigroup (Exp b)) => Semigroup (Exp (a,b)) where+  (<>) = lift2 ((<>) :: (Exp a, Exp b) -> (Exp a, Exp b) -> (Exp a, Exp b))+  stimes n (unlift -> (a,b) :: (Exp a, Exp b)) = lift (stimes n a, stimes n b)++instance (Elt a, Elt b, Elt c, Semigroup (Exp a), Semigroup (Exp b), Semigroup (Exp c)) => Semigroup (Exp (a,b,c)) where+  (<>) = lift2 ((<>) :: (Exp a, Exp b, Exp c) -> (Exp a, Exp b, Exp c) -> (Exp a, Exp b, Exp c))+  stimes n (unlift -> (a,b,c) :: (Exp a, Exp b, Exp c)) = lift (stimes n a, stimes n b, stimes n c)++instance (Elt a, Elt b, Elt c, Elt d, Semigroup (Exp a), Semigroup (Exp b), Semigroup (Exp c), Semigroup (Exp d)) => Semigroup (Exp (a,b,c,d)) where+  (<>) = lift2 ((<>) :: (Exp a, Exp b, Exp c, Exp d) -> (Exp a, Exp b, Exp c, Exp d) -> (Exp a, Exp b, Exp c, Exp d))+  stimes n (unlift -> (a,b,c,d) :: (Exp a, Exp b, Exp c, Exp d)) = lift (stimes n a, stimes n b, stimes n c, stimes n d)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Semigroup (Exp a), Semigroup (Exp b), Semigroup (Exp c), Semigroup (Exp d), Semigroup (Exp e)) => Semigroup (Exp (a,b,c,d,e)) where+  (<>) = lift2 ((<>) :: (Exp a, Exp b, Exp c, Exp d, Exp e) -> (Exp a, Exp b, Exp c, Exp d, Exp e) -> (Exp a, Exp b, Exp c, Exp d, Exp e))+  stimes n (unlift -> (a,b,c,d,e) :: (Exp a, Exp b, Exp c, Exp d, Exp e)) = lift (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)+
+ src/Data/Array/Accelerate/Debug.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Debug+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Embedded array processing language: debugging support (internal). This module+-- provides functionality that is useful for developers of the library. It is+-- not meant for library users.+--++module Data.Array.Accelerate.Debug (++  module Debug,++  dumpGraph,+  dumpSimplStats,++  debuggingIsEnabled,+  monitoringIsEnabled,+  boundsChecksAreEnabled,+  unsafeChecksAreEnabled,+  internalChecksAreEnabled,++) where++import Data.Array.Accelerate.Debug.Flags                as Debug+import Data.Array.Accelerate.Debug.Monitoring           as Debug+import Data.Array.Accelerate.Debug.Stats                as Debug+import Data.Array.Accelerate.Debug.Timed                as Debug+import Data.Array.Accelerate.Debug.Trace                as Debug++import Data.Array.Accelerate.Pretty.Graphviz++import Control.Monad.Trans                              ( MonadIO )++#ifdef ACCELERATE_DEBUG+import Control.Exception                                ( bracket )+import Control.Monad.Trans                              ( liftIO )+import System.Directory                                 ( getTemporaryDirectory, createDirectoryIfMissing )+import System.FilePath                                  ( (</>) )+import System.IO                                        ( Handle, openTempFile, hPutStrLn, hPrint, hClose, stderr )++#if   defined(UNIX)+import System.Posix.Process                             ( getProcessID )+#elif defined(WIN32)+import System.Win32.Process                             ( ProcessId )+#else+#error "I don't know what operating system I am"+#endif+#endif+++{-# INLINE debuggingIsEnabled #-}+debuggingIsEnabled :: Bool+#ifdef ACCELERATE_DEBUG+debuggingIsEnabled = True+#else+debuggingIsEnabled = False+#endif++{-# INLINE monitoringIsEnabled #-}+monitoringIsEnabled :: Bool+#ifdef ACCELERATE_MONITORING+monitoringIsEnabled = True+#else+monitoringIsEnabled = False+#endif++{-# INLINE boundsChecksAreEnabled #-}+boundsChecksAreEnabled :: Bool+#ifdef ACCELERATE_BOUNDS_CHECKS+boundsChecksAreEnabled = True+#else+boundsChecksAreEnabled = False+#endif++{-# INLINE unsafeChecksAreEnabled #-}+unsafeChecksAreEnabled :: Bool+#ifdef ACCELERATE_UNSAFE_CHECKS+unsafeChecksAreEnabled = True+#else+unsafeChecksAreEnabled = False+#endif++{-# INLINE internalChecksAreEnabled #-}+internalChecksAreEnabled :: Bool+#ifdef ACCELERATE_INTERNAL_CHECKS+internalChecksAreEnabled = True+#else+internalChecksAreEnabled = False+#endif+++-- | Display simplifier statistics. The counts are reset afterwards.+--+{-# INLINEABLE dumpSimplStats #-}+dumpSimplStats :: MonadIO m => m ()+#ifdef ACCELERATE_DEBUG+dumpSimplStats = do+  liftIO $ Debug.when dump_simpl_stats $ do+    stats <- simplCount+    putTraceMsg (show stats)+    resetSimplCount+#else+dumpSimplStats = return ()+#endif+++-- | Write a representation of the given input (a closed array expression or+-- function) to file in Graphviz dot format in the temporary directory.+--+{-# INLINEABLE dumpGraph #-}+dumpGraph :: (MonadIO m, PrettyGraph g) => g -> m ()+#ifdef ACCELERATE_DEBUG+dumpGraph g =+  liftIO $ do+    Debug.when dump_dot       $ writeGraph Full   g+    Debug.when dump_simpl_dot $ writeGraph Simple g+#else+dumpGraph _ = return ()+#endif++#ifdef ACCELERATE_DEBUG+writeGraph :: PrettyGraph g => Detail -> g -> IO ()+writeGraph simple g = do+  withTemporaryFile "acc.dot" $ \path hdl -> do+    hPrint hdl (ppGraph simple g)+    hPutStrLn stderr ("program graph: " ++ path)++withTemporaryFile :: String -> (FilePath -> Handle -> IO a) -> IO a+withTemporaryFile template go = do+  pid <- getProcessID+  tmp <- getTemporaryDirectory+  let dir = tmp </> "accelerate-" ++ show pid+  createDirectoryIfMissing True dir+  bracket (openTempFile dir template) (hClose . snd) (uncurry go)++#ifdef WIN32+getProcessID :: IO ProcessId+getProcessID = return 0xaaaa+#endif+#endif
+ src/Data/Array/Accelerate/Debug/Flags.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeOperators            #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+#endif+-- |+-- Module      : Data.Array.Accelerate.Debug.Flags+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Option parsing for debug flags+--++module Data.Array.Accelerate.Debug.Flags (++  Value,+  unfolding_use_threshold,+  getValue,+  setValue,++  Flag,+  acc_sharing, exp_sharing, fusion, simplify, flush_cache, force_recomp,+  fast_math, debug, verbose, dump_phases, dump_sharing, dump_fusion,+  dump_simpl_stats, dump_simpl_iterations, dump_vectorisation, dump_dot,+  dump_simpl_dot, dump_gc, dump_gc_stats, dump_cc, dump_ld, dump_asm, dump_exec,+  dump_sched,++  getFlag,+  setFlag, setFlags,+  clearFlag, clearFlags,++  when,+  unless,++) where+++import Data.Int+import Foreign.Ptr+import Foreign.Storable++import Control.Monad.IO.Class                                       ( MonadIO, liftIO )+import qualified Control.Monad                                      as M++newtype Flag  = Flag  (Ptr Int32)+newtype Value = Value (Ptr Int32)+++-- | Conditional execution of a monadic debugging expression.+--+-- This does nothing unless the program is compiled in debug mode.+--+{-# INLINEABLE when #-}+when :: MonadIO m => Flag -> m () -> m ()+#if ACCELERATE_DEBUG+when f action = do+  yes <- liftIO $ getFlag f+  M.when yes action+#else+when _ _ = return ()+#endif+++-- | The opposite of 'when'.+--+-- This does nothing unless the program is compiled in debug mode.+--+{-# INLINEABLE unless #-}+unless :: MonadIO m => Flag -> m () -> m ()+#ifdef ACCELERATE_DEBUG+unless f action = do+  yes <- liftIO $ getFlag f+  M.unless yes action+#else+unless _ _ = return ()+#endif+++setValue   :: Value -> Int -> IO ()+#ifdef ACCELERATE_DEBUG+setValue (Value f) v = poke f (fromIntegral v)+#else+setValue _         _ = notEnabled+#endif++getValue   :: Value -> IO Int+#ifdef ACCELERATE_DEBUG+getValue (Value f) = fromIntegral `fmap` peek f+#else+getValue _         = notEnabled+#endif++getFlag    :: Flag -> IO Bool+#ifdef ACCELERATE_DEBUG+getFlag (Flag f) = toBool `fmap` peek f+#else+getFlag _        = notEnabled+#endif++setFlag    :: Flag -> IO ()+#ifdef ACCELERATE_DEBUG+setFlag (Flag f) = poke f (fromBool True)+#else+setFlag _        = notEnabled+#endif++clearFlag  :: Flag -> IO ()+#ifdef ACCELERATE_DEBUG+clearFlag (Flag f) = poke f (fromBool False)+#else+clearFlag _        = notEnabled+#endif++setFlags   :: [Flag] -> IO ()+setFlags = mapM_ setFlag++clearFlags :: [Flag] -> IO ()+clearFlags = mapM_ clearFlag++notEnabled :: a+notEnabled = error $ unlines [ "Data.Array.Accelerate: Debugging options are disabled."+                             , "Reinstall package 'accelerate' with '-fdebug' to enable them." ]++toBool :: Int32 -> Bool+toBool 0 = False+toBool _ = True++fromBool :: Bool -> Int32+fromBool False = 0+fromBool True  = 1+++-- Import the underlying flag variables. These are defined in the file+-- cbits/flags.c and initialised at program initialisation.++-- These @-f<blah>=INT@ values are used by the compiler+--+foreign import ccall "&__unfolding_use_threshold" unfolding_use_threshold :: Value  -- the magic cut-off figure for inlining++-- These @-f<blah>@ flags can be reversed with @-fno-<blah>@+--+foreign import ccall "&__acc_sharing"             acc_sharing             :: Flag   -- recover sharing of array computations+foreign import ccall "&__exp_sharing"             exp_sharing             :: Flag   -- recover sharing of scalar expressions+foreign import ccall "&__fusion"                  fusion                  :: Flag   -- fuse array expressions+foreign import ccall "&__simplify"                simplify                :: Flag   -- simplify scalar expressions+foreign import ccall "&__fast_math"               fast_math               :: Flag   -- delete persistent compilation cache(s)+foreign import ccall "&__flush_cache"             flush_cache             :: Flag   -- force recompilation of array programs+foreign import ccall "&__force_recomp"            force_recomp            :: Flag   -- use faster, less precise math library operations+foreign import ccall "&__debug"                   debug                   :: Flag   -- compile code with debugging symbols (-g)++-- These debugging flags are disable by default and are enabled with @-d<blah>@+--+foreign import ccall "&__verbose"                 verbose                 :: Flag   -- be very chatty+foreign import ccall "&__dump_phases"             dump_phases             :: Flag   -- print information about each phase of the compiler+foreign import ccall "&__dump_sharing"            dump_sharing            :: Flag   -- sharing recovery phase+foreign import ccall "&__dump_fusion"             dump_fusion             :: Flag   -- array fusion phase+foreign import ccall "&__dump_simpl_stats"        dump_simpl_stats        :: Flag   -- statistics form fusion/simplification+foreign import ccall "&__dump_simpl_iterations"   dump_simpl_iterations   :: Flag   -- output from each simplifier iteration+foreign import ccall "&__dump_vectorisation"      dump_vectorisation      :: Flag   -- output from the vectoriser+foreign import ccall "&__dump_dot"                dump_dot                :: Flag   -- generate dot output of the program+foreign import ccall "&__dump_simpl_dot"          dump_simpl_dot          :: Flag   -- generate simplified dot output+foreign import ccall "&__dump_gc"                 dump_gc                 :: Flag   -- trace garbage collector+foreign import ccall "&__dump_gc_stats"           dump_gc_stats           :: Flag   -- print final GC statistics+foreign import ccall "&__dump_cc"                 dump_cc                 :: Flag   -- trace code generation & compilation+foreign import ccall "&__dump_ld"                 dump_ld                 :: Flag   -- trace runtime linker+foreign import ccall "&__dump_asm"                dump_asm                :: Flag   -- trace assembler+foreign import ccall "&__dump_exec"               dump_exec               :: Flag   -- trace execution+foreign import ccall "&__dump_sched"              dump_sched              :: Flag   -- trace scheduler+
+ src/Data/Array/Accelerate/Debug/Monitoring.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE BangPatterns             #-}+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE RecordWildCards          #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Debug.Monitoring+-- Copyright   : [2016..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.Debug.Monitoring (++  beginMonitoring,+  initAccMetrics,++  -- Load monitoring+  Processor(..),+  withProcessor, addProcessorTime,++  -- GC subsystem monitoring+  didAllocateBytesLocal, didAllocateBytesRemote,+  didCopyBytesToRemote, didCopyBytesFromRemote,+  increaseCurrentBytesRemote, decreaseCurrentBytesRemote,+  increaseCurrentBytesNursery, decreaseCurrentBytesNursery, getCurrentBytesNursery, setCurrentBytesNursery,+  didRemoteGC,+  didEvictBytes,++) where++#ifdef ACCELERATE_MONITORING+import System.Metrics+import System.Remote.Monitoring++import Control.Concurrent+import Control.Concurrent.Async+import Data.IORef+import Data.Text                                                    ( Text )+import Text.Printf+import qualified Data.HashMap.Strict                                as Map+#endif++import Data.Atomic                                                  ( Atomic )+import qualified Data.Atomic                                        as Atomic++import Control.Monad+import Data.Int+import Prelude+++-- | Launch a monitoring server that will collect statistics on the running+-- application. This should be called as soon as the application starts. The+-- program will need to be run with the RTS option -T.+--+beginMonitoring :: IO ()+#ifdef ACCELERATE_MONITORING+beginMonitoring = do+  store <- initAccMetrics+  registerGcMetrics store+  r     <- withAsync (forkServerWith store "localhost" 8000 >> threadDelay 10000) waitCatch+  case r of+    Right _ -> printf "EKG monitor started at: http://localhost:8000\n"+    Left _  -> printf "Failed to start EKG monitor\n"+#else+beginMonitoring = return ()+#endif+++-- | Initialise and return the Accelerate monitoring store. To enable monitoring+-- of your application:+--+-- > import Data.Array.Accelerate.Debug+-- >+-- > import System.Metrics+-- > import System.Remote.Monitoring+-- >+-- > main :: IO ()+-- > main = do+-- >   store  <- initAccMetrics+-- >   registerGcMetrics store      -- optional+-- >+-- >   server <- forkServerWith store "localhost" 8000+-- >+-- >   ...+--+-- Note that aside from the processor load metrics, counters are shared between+-- all active backends.+--+-- Registered rates:+--+-- [@acc.load.llvm_native@] Current processor load (%) of the LLVM CPU backend.+-- This only includes time spent executing Accelerate functions; compare this to+-- the total processor load (e.g. via top) to estimate the productivity of the+-- Accelerate program.+--+-- [@acc.load.llvm_ptx@] Current processor load (%) of the GPU in the LLVM PTX+-- backend. This only takes into account how much time the GPU spent executing+-- Accelerate code, and does not consider the number of active cores during that+-- time.+--+-- Registered gauges:+--+-- [@acc.gc.current_bytes_remote@] Total number of bytes currently considered+-- live in the remote address space.+--+-- [@acc.gc.current_bytes_nursery@] Total number of bytes allocated in the+-- remote address space but not currently live (available for reallocation).+--+-- Registered counters:+--+-- [@acc.gc.bytes_allocated_local@] Total number of bytes allocated in the local+-- address space.+--+-- [@acc.gc.bytes_allocated_remote@] Total number of bytes allocated in the+-- remote address space.+--+-- [@acc.gc.bytes_copied_to_remote@] Total number of bytes copied from the host+-- to the remote address space (e.g. from the CPU to the GPU).+--+-- [@acc.gc.bytes_copied_from_remote@] Total number of bytes copied from the+-- remote address space back to the host (e.g. from the GPU back to the CPU).+--+-- [@acc.gc.bytes_evicted_from_remote@] Total number of bytes evicted from the+-- remote address space by the LRU memory manager, in order to make space for+-- new allocations. A subset of __acc.gc.bytes_copied_from_remote__.+--+-- [@acc.gc.num_gcs@] Number of garbage collections of the remote address space+-- performed.+--+-- [@acc.gc.num_lru_evict@] Total number of evictions from the remote address+-- space performed.+--+#ifndef ACCELERATE_MONITORING+initAccMetrics :: IO a+initAccMetrics = error $ unlines [ "Data.Array.Accelerate: Monitoring is disabled."+                                 , "Reinstall package 'accelerate' with '-fekg' to enable it." ]+#else+initAccMetrics :: IO Store+initAccMetrics = do+  store <- newStore++  registerRate    "acc.load.llvm_native"             (estimateProcessorLoad __active_ns_llvm_native) store+  registerRate    "acc.load.llvm_ptx"                (estimateProcessorLoad __active_ns_llvm_ptx)    store+  registerGauge   "acc.gc.current_bytes_remote"      (Atomic.read __current_bytes_remote)            store+  registerGauge   "acc.gc.current_bytes_nursery"     (Atomic.read __current_bytes_nursery)           store+  registerCounter "acc.gc.bytes_allocated_local"     (Atomic.read __total_bytes_allocated_local)     store+  registerCounter "acc.gc.bytes_allocated_remote"    (Atomic.read __total_bytes_allocated_remote)    store+  registerCounter "acc.gc.bytes_copied_to_remote"    (Atomic.read __total_bytes_copied_to_remote)    store+  registerCounter "acc.gc.bytes_copied_from_remote"  (Atomic.read __total_bytes_copied_from_remote)  store+  registerCounter "acc.gc.bytes_evicted_from_remote" (Atomic.read __total_bytes_evicted_from_remote) store+  registerCounter "acc.gc.num_gcs"                   (Atomic.read __num_remote_gcs)                  store+  registerCounter "acc.gc.num_lru_evict"             (Atomic.read __num_evictions)                   store++  return store+++-- Abusing 'registerGroup' to perform the rate calculation on every wake-up.+--+registerRate :: Text -> (IORef EMAState -> IO Int64) -> Store -> IO ()+registerRate name sample store = do+  now <- getMonotonicTime+  st  <- newIORef (ES now 0 0)+  registerGroup (Map.singleton name Gauge) (sample st) store+#endif+++-- Recording metrics+-- -----------------++data Processor = Native | PTX++-- | Execute the given action and assign the elapsed wall-clock time as active+-- time for the given processing element.+--+{-# INLINE withProcessor #-}+withProcessor :: Processor -> IO a -> IO a+#ifndef ACCELERATE_MONITORING+withProcessor _      = id+#else+withProcessor Native = withProcessor' __active_ns_llvm_native+withProcessor PTX    = withProcessor' __active_ns_llvm_ptx++withProcessor' :: Atomic -> IO a -> IO a+withProcessor' var action = do+  wall0 <- getMonotonicTime+  !r    <- action+  wall1 <- getMonotonicTime+  addProcessorTime' var (wall1 - wall0)+  return r+#endif++-- | Record the given number of seconds as active processing time for the given+-- processing element.+--+{-# INLINE addProcessorTime #-}+addProcessorTime :: Processor -> Double -> IO ()+#ifndef ACCELERATE_MONITORING+addProcessorTime _ _    = return ()+#else+addProcessorTime Native = addProcessorTime' __active_ns_llvm_native+addProcessorTime PTX    = addProcessorTime' __active_ns_llvm_ptx++addProcessorTime' :: Atomic -> Double -> IO ()+addProcessorTime' var secs =+  let ns   = round (secs * 1.0E9)+  in  void $ Atomic.add var ns+#endif+++-- | Allocated the number of bytes in the local memory space+--+{-# INLINE didAllocateBytesLocal #-}+didAllocateBytesLocal :: Int64 -> IO ()+#ifndef ACCELERATE_DEBUG+didAllocateBytesLocal _ = return ()+#else+didAllocateBytesLocal n = do+  -- void $ Atomic.add __active_bytes_allocated_local n+  void $ Atomic.add __total_bytes_allocated_local n+#endif++-- Allocations in the number of bytes of /new/ memory in the remote memory space+--+{-# INLINE didAllocateBytesRemote #-}+{-# INLINE increaseCurrentBytesRemote #-}+{-# INLINE decreaseCurrentBytesRemote #-}+didAllocateBytesRemote     :: Int64 -> IO ()+decreaseCurrentBytesRemote :: Int64 -> IO ()+increaseCurrentBytesRemote :: Int64 -> IO ()+#ifndef ACCELERATE_DEBUG+didAllocateBytesRemote     _ = return ()+increaseCurrentBytesRemote _ = return ()+decreaseCurrentBytesRemote _ = return ()+#else+didAllocateBytesRemote n = do+ -- void $ Atomic.add __active_bytes_allocated_remote n+ void $ Atomic.add __total_bytes_allocated_remote n++increaseCurrentBytesRemote n = void $ Atomic.add __current_bytes_remote n+decreaseCurrentBytesRemote n = void $ Atomic.subtract __current_bytes_remote n+#endif+++-- | Copied data between the local and remote memory spaces+--+{-# INLINE didCopyBytesToRemote   #-}+{-# INLINE didCopyBytesFromRemote #-}+didCopyBytesFromRemote :: Int64 -> IO ()+didCopyBytesToRemote   :: Int64 -> IO ()+#ifndef ACCELERATE_DEBUG+didCopyBytesToRemote   _ = return ()+didCopyBytesFromRemote _ = return ()+#else+didCopyBytesToRemote   n = void $ Atomic.add __total_bytes_copied_to_remote n+didCopyBytesFromRemote n = void $ Atomic.add __total_bytes_copied_from_remote n+#endif+++-- Allocations in the nursery+--+{-# INLINE increaseCurrentBytesNursery #-}+{-# INLINE decreaseCurrentBytesNursery #-}+{-# INLINE setCurrentBytesNursery      #-}+increaseCurrentBytesNursery :: Int64 -> IO ()+decreaseCurrentBytesNursery :: Int64 -> IO ()+setCurrentBytesNursery      :: Int64 -> IO ()+getCurrentBytesNursery      :: IO Int64+#ifndef ACCELERATE_DEBUG+increaseCurrentBytesNursery _ = return ()+decreaseCurrentBytesNursery _ = return ()+setCurrentBytesNursery      _ = return ()+getCurrentBytesNursery        = return 0+#else+increaseCurrentBytesNursery n = void $ Atomic.add      __current_bytes_nursery n+decreaseCurrentBytesNursery n = void $ Atomic.subtract __current_bytes_nursery n+setCurrentBytesNursery      n =        Atomic.write    __current_bytes_nursery n+getCurrentBytesNursery        =        Atomic.read     __current_bytes_nursery+#endif+++-- | Performed a major GC of the remote memory space+--+{-# INLINE didRemoteGC #-}+didRemoteGC :: IO ()+#ifndef ACCELERATE_DEBUG+didRemoteGC = return ()+#else+didRemoteGC = void $ Atomic.add __num_remote_gcs 1+#endif++-- | Performed an eviction of a remote array of the given number of bytes+--+{-# INLINE didEvictBytes #-}+didEvictBytes :: Int64 -> IO ()+#ifndef ACCELERATE_DEBUG+didEvictBytes _ = return ()+#else+didEvictBytes n = do+  void $ Atomic.add __num_evictions 1+  void $ Atomic.add __total_bytes_evicted_from_remote n+#endif+++-- Implementation+-- --------------++#ifdef ACCELERATE_MONITORING++-- In order to calculate the processor load we need to remember the previous+-- values. Storing this state in an IORef has a bit of extra overhead (as+-- indirection) compared to the rest of the monitoring counters (which are+-- unboxed values on the heap manipulated directly with atomic primops), but+-- since 'calculateProcessorLoad' will only be called by the EKG monitor+-- whenever it refreshes the value for display, rather than running continuously+-- in the background, we should be okay.+--+data EMAState = ES+  { old_time  :: {-# UNPACK #-} !Double+  , old_inst  :: {-# UNPACK #-} !Double+  , old_avg   :: {-# UNPACK #-} !Double+  }++-- Estimate the load on the processor as a moving exponential average+-- (weight of previous measurement = 0.2).+--+estimateProcessorLoad :: Atomic -> IORef EMAState -> IO Int64+estimateProcessorLoad !var !ref = do+  ES{..} <- readIORef ref+  time   <- getMonotonicTime+  sample <- Atomic.and var 0+  --+  let+      active_ns   = fromIntegral sample+      elapsed_s   = old_time - time+      elapsed_ns  = 1.0E9 * elapsed_s+      --+      new_inst    = 100 * (active_ns / elapsed_ns)                -- instantaneous load+      new_avg     = ema 0.2 elapsed_s old_avg old_inst new_inst   -- moving average load+  --+  writeIORef ref (ES time new_inst new_avg)+  return (round new_avg)++-- cbits/clock.c+foreign import ccall unsafe "clock_gettime_monotonic_seconds" getMonotonicTime :: IO Double++{--+-- Compute the current load on a processor as a percentage of time spent working+-- over the elapsed time. This is meant to run continuously by a background+-- thread, updating the gauge each time it wakes up.+--+monitorProcessorLoad :: Gauge -> Atomic -> UTCTime -> Double -> Double -> IO ()+monitorProcessorLoad !gauge !var !old_time !old_inst !old_avg = do+  time   <- getCurrentTime+  sample <- Atomic.and var 0++  let+      active_ns   = fromIntegral sample+      elapsed_s   = realToFrac (diffUTCTime time old_time)+      elapsed_ns  = 1.0E9 * elapsed_s++      load_inst   = 100 * (active_ns / elapsed_ns)                -- instantaneous load+      load_avg    = ema 0.2 elapsed_s old_avg old_inst load_inst  -- moving average load++  -- Set what we thing the processor load over the previous interval should be+  Gauge.set gauge (round load_avg)++  -- Sleep for a bit, then do it all again+  threadDelay 500000    -- 500 ms+  monitorProcessorLoad gauge var time load_inst load_avg+--}++-- Exponential moving average for irregular time series+--+ema :: Double -> Double -> Double -> Double -> Double -> Double+ema !alpha !dt !old_ema !old_sample !new_sample =+  let+      a = dt / alpha+      u = exp ( -a )+      v = ( 1 - u ) / a+  in+  (u * old_ema) + ((v-u) * old_sample) + ((1-v) * new_sample)++#endif+++-- Monitoring variables+-- --------------------++-- Number of nanoseconds a backend has spent doing real work since the last+-- check. This is an integer amount because there are no built-in functions for+-- atomic memory access on double precision (as specified by the Intel docs).+--+foreign import ccall "&__active_ns_llvm_native"           __active_ns_llvm_native           :: Atomic+foreign import ccall "&__active_ns_llvm_ptx"              __active_ns_llvm_ptx              :: Atomic++foreign import ccall "&__current_bytes_remote"            __current_bytes_remote            :: Atomic -- current working size of the remote memory space (active memory)+foreign import ccall "&__current_bytes_nursery"           __current_bytes_nursery           :: Atomic -- current size of the remote nursery (inactive memory)++foreign import ccall "&__total_bytes_allocated_local"     __total_bytes_allocated_local     :: Atomic -- bytes allocated in the local (CPU) memory space+foreign import ccall "&__total_bytes_allocated_remote"    __total_bytes_allocated_remote    :: Atomic -- bytes allocated in the remote memory space (if it is separate, e.g. GPU)+foreign import ccall "&__total_bytes_copied_to_remote"    __total_bytes_copied_to_remote    :: Atomic -- bytes copied to the remote memory space+foreign import ccall "&__total_bytes_copied_from_remote"  __total_bytes_copied_from_remote  :: Atomic -- bytes copied from the remote memory space+foreign import ccall "&__total_bytes_evicted_from_remote" __total_bytes_evicted_from_remote :: Atomic -- total bytes copied from the remote due to evictions+foreign import ccall "&__num_remote_gcs"                  __num_remote_gcs                  :: Atomic -- number of times the remote memory space was forcibly garbage collected+foreign import ccall "&__num_evictions"                   __num_evictions                   :: Atomic -- number of LRU eviction events+
+ src/Data/Array/Accelerate/Debug/Stats.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-unused-binds   #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+-- |+-- Module      : Data.Array.Accelerate.Debug.Simpl+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Tick-count statistics collection of the compiler passes, for debugging+-- purposes.+--++module Data.Array.Accelerate.Debug.Stats (++  simplCount, resetSimplCount,+  inline, ruleFired, knownBranch, betaReduce, substitution, simplifierDone, fusionDone,++) where++import Data.Array.Accelerate.Debug.Flags++import Data.Function                            ( on )+import Data.IORef+import Data.List                                ( groupBy, sortBy )+import Data.Ord                                 ( comparing )+import Data.Map                                 ( Map )+import Text.PrettyPrint.ANSI.Leijen+import System.IO.Unsafe++import qualified Data.Map                       as Map+++-- Recording statistics+-- --------------------++ruleFired, inline, knownBranch, betaReduce, substitution :: String -> a -> a+inline          = annotate Inline+ruleFired       = annotate RuleFired+knownBranch     = annotate KnownBranch+betaReduce      = annotate BetaReduce+substitution    = annotate Substitution++simplifierDone, fusionDone :: a -> a+simplifierDone  = tick SimplifierDone+fusionDone      = tick FusionDone++-- Add an entry to the statistics counters+--+tick :: Tick -> a -> a+#ifdef ACCELERATE_DEBUG+{-# NOINLINE tick #-}+tick t expr = unsafeDupablePerformIO $ do+  modifyIORef' statistics (simplTick t)+  return expr+#else+{-# INLINE tick #-}+tick _ expr = expr+#endif++-- Add an entry to the statistics counters with an annotation+--+annotate :: (Id -> Tick) -> String -> a -> a+annotate name ctx = tick (name (Id ctx))+++-- Simplifier counts+-- -----------------++data SimplStats+  = Simple         {-# UNPACK #-} !Int          -- when we don't want detailed stats++  | Detail {+      ticks     :: {-# UNPACK #-} !Int,         -- total ticks+      details   :: !TickCount                   -- how many of each type+    }++instance Show SimplStats where+  show = show . pprSimplCount+++-- Stores the current statistics counters+--+{-# NOINLINE statistics #-}+statistics :: IORef SimplStats+statistics = unsafePerformIO $ newIORef =<< initSimplCount++-- Initialise the statistics counters. If we are dumping the stats+-- (-ddump-simpl-stats) record extra information, else just a total tick count.+--+initSimplCount :: IO SimplStats+#ifdef ACCELERATE_DEBUG+initSimplCount = do+  d <- getFlag dump_simpl_stats+  return $! if d then Detail { ticks = 0, details = Map.empty }+                 else Simple 0+#else+initSimplCount = return $! Simple 0+#endif+++-- Reset the statistics counters. Do this at the beginning at each HOAS -> de+-- Bruijn conversion + optimisation pass.+--+resetSimplCount :: IO ()+#ifdef ACCELERATE_DEBUG+resetSimplCount = writeIORef statistics =<< initSimplCount+#else+resetSimplCount = return ()+#endif+++-- Tick a counter+--+simplTick :: Tick -> SimplStats -> SimplStats+simplTick _ (Simple n)     = Simple (n+1)+simplTick t (Detail n dts) = Detail (n+1) (dts `addTick` t)++-- Pretty print the tick counts. Remarkably reminiscent of GHC style...+--+pprSimplCount :: SimplStats -> Doc+pprSimplCount (Simple n)     = text "Total ticks:" <+> int n+pprSimplCount (Detail n dts)+  = vcat [ text "Total ticks:" <+> int n+         , text ""+         , pprTickCount dts+         ]++simplCount :: IO Doc+simplCount = pprSimplCount `fmap` readIORef statistics+++-- Ticks+-- -----++type TickCount = Map Tick Int++data Id = Id String+  deriving (Eq, Ord)++data Tick+  = Inline              Id+  | RuleFired           Id+  | KnownBranch         Id+  | BetaReduce          Id+  | Substitution        Id++  -- tick at each iteration+  | SimplifierDone+  | FusionDone+  deriving (Eq, Ord)+++addTick :: TickCount -> Tick -> TickCount+addTick tc t =+  Map.alter f t tc+  where+    f Nothing  = Just 1+    f (Just x) = let x' = x+1 in x' `seq` Just x'++pprTickCount :: TickCount -> Doc+pprTickCount counts =+  vcat (map pprTickGroup groups)+  where+    groups  = groupBy sameTag (Map.toList counts)+    sameTag = (==) `on` tickToTag . fst++pprTickGroup :: [(Tick,Int)] -> Doc+pprTickGroup []  = error "pprTickGroup"+pprTickGroup grp =+  hang 2 (vcat $ (int groupTotal <+> text groupName)+               : [ int n <+> pprTickCtx t | (t,n) <- sortBy (flip (comparing snd)) grp ])+  where+    groupName  = tickToStr (fst (head grp))+    groupTotal = sum [n | (_,n) <- grp]++tickToTag :: Tick -> Int+tickToTag Inline{}              = 0+tickToTag RuleFired{}           = 1+tickToTag KnownBranch{}         = 2+tickToTag BetaReduce{}          = 3+tickToTag Substitution{}        = 4+tickToTag SimplifierDone        = 99+tickToTag FusionDone            = 100++tickToStr :: Tick -> String+tickToStr Inline{}              = "Inline"+tickToStr RuleFired{}           = "RuleFired"+tickToStr KnownBranch{}         = "KnownBranch"+tickToStr BetaReduce{}          = "BetaReduce"+tickToStr Substitution{}        = "Substitution"+tickToStr SimplifierDone        = "SimplifierDone"+tickToStr FusionDone            = "FusionDone"++pprTickCtx :: Tick -> Doc+pprTickCtx (Inline v)           = pprId v+pprTickCtx (RuleFired v)        = pprId v+pprTickCtx (KnownBranch v)      = pprId v+pprTickCtx (BetaReduce v)       = pprId v+pprTickCtx (Substitution v)     = pprId v+pprTickCtx SimplifierDone       = empty+pprTickCtx FusionDone           = empty++pprId :: Id -> Doc+pprId (Id s) = text s+
+ src/Data/Array/Accelerate/Debug/Timed.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-- |+-- Module      : Data.Array.Accelerate.Debug.Timed+-- Copyright   : [2016..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.Debug.Timed (++  timed,+  elapsed,++) where++import Data.Array.Accelerate.Debug.Trace+import Data.Array.Accelerate.Debug.Flags++import Control.Monad.Trans                              ( MonadIO )+import Text.Printf++#if ACCELERATE_DEBUG+import Control.Applicative+import Control.Monad.Trans                              ( liftIO )+import Data.List+import System.CPUTime+import Prelude++import GHC.Stats+#endif+++-- | Execute an action and time the results. If GC stats have been enabled (with+-- @+RTS -t@ for example) then timing and memory usage information is displayed,+-- otherwise only timing information is shown.+--+{-# INLINEABLE timed #-}+timed :: MonadIO m => Flag -> (Double -> Double -> String) -> m a -> m a+#ifdef ACCELERATE_DEBUG+timed f fmt action = do+  enabled <- liftIO $ getFlag f+  if enabled+    then do+      with_gc <- liftIO $ (&&) <$> getRTSStatsEnabled <*> getFlag verbose+      if with_gc+        then timed_gc    fmt action+        else timed_simpl fmt action+    else+      action+#else+timed _ _ action = action+#endif++#ifdef ACCELERATE_DEBUG+{-# INLINEABLE timed_simpl #-}+timed_simpl :: MonadIO m => (Double -> Double -> String) -> m a -> m a+timed_simpl fmt action = do+  wall0 <- liftIO getMonotonicTime+  cpu0  <- liftIO getCPUTime+  res   <- action+  wall1 <- liftIO getMonotonicTime+  cpu1  <- liftIO getCPUTime+  --+  let wallTime = wall1 - wall0+      cpuTime  = fromIntegral (cpu1 - cpu0) * 1E-12+  --+  liftIO $ putTraceMsg (fmt wallTime cpuTime)+  return res++foreign import ccall unsafe "clock_gettime_monotonic_seconds" getMonotonicTime :: IO Double+++{-# INLINEABLE timed_gc #-}+timed_gc :: MonadIO m => (Double -> Double -> String) -> m a -> m a+timed_gc fmt action = do+#if __GLASGOW_HASKELL__ < 802+  gc0   <- liftIO getGCStats+  res   <- action+  gc1   <- liftIO getGCStats+#else+  rts0  <- liftIO getRTSStats+  res   <- action+  rts1  <- liftIO getRTSStats+#endif+  --+  let toDouble :: Integral a => a -> Double+      toDouble = fromIntegral+      --+#if __GLASGOW_HASKELL__ < 802+      allocated   = toDouble (bytesAllocated gc1 - bytesAllocated gc0)+      copied      = toDouble (bytesCopied gc1 - bytesCopied gc0)+      totalWall   = wallSeconds gc1 - wallSeconds gc0+      totalCPU    = cpuSeconds gc1 - cpuSeconds gc0+      mutatorWall = mutatorWallSeconds gc1 - mutatorWallSeconds gc0+      mutatorCPU  = mutatorCpuSeconds gc1 - mutatorCpuSeconds gc0+      gcWall      = gcWallSeconds gc1 - gcWallSeconds gc0+      gcCPU       = gcCpuSeconds gc1 - gcCpuSeconds gc0+      totalGCs    = numGcs gc1 - numGcs gc0+#else+      allocated   = toDouble (allocated_bytes rts1 - allocated_bytes rts0)+      copied      = toDouble (copied_bytes rts1 - copied_bytes rts0)+      totalWall   = toDouble (elapsed_ns rts1 - elapsed_ns rts0) * 1.0E-9+      totalCPU    = toDouble (cpu_ns rts1 - cpu_ns rts0) * 1.0E-9+      mutatorWall = toDouble (mutator_elapsed_ns rts1 - mutator_elapsed_ns rts0) * 1.0E-9+      mutatorCPU  = toDouble (mutator_cpu_ns rts1 - mutator_cpu_ns rts0) * 1.0E-9+      gcWall      = toDouble (gc_elapsed_ns rts1 - gc_elapsed_ns rts0) * 1.0E-9+      gcCPU       = toDouble (gc_cpu_ns rts1 - gc_cpu_ns rts0) * 1.0E-9+      totalGCs    = gcs rts1 - gcs rts0+#endif++  liftIO . putTraceMsg $ intercalate "\n"+    [ fmt totalWall totalCPU+    , printf "    %s allocated on the heap" (showFFloatSIBase (Just 1) 1024 allocated "B")+    , printf "    %s copied during GC (%d collections)" (showFFloatSIBase (Just 1) 1024 copied "B") totalGCs+    , printf "    MUT: %s" (elapsed mutatorWall mutatorCPU)+    , printf "    GC:  %s" (elapsed gcWall gcCPU)+    ]+  --+  return res++#if __GLASGOW_HASKELL__ < 802+getRTSStatsEnabled :: IO Bool+getRTSStatsEnabled = getGCStatsEnabled+#endif+#endif++elapsed :: Double -> Double -> String+elapsed wallTime cpuTime =+  printf "%s (wall), %s (cpu)"+    (showFFloatSIBase (Just 3) 1000 wallTime "s")+    (showFFloatSIBase (Just 3) 1000 cpuTime  "s")+
+ src/Data/Array/Accelerate/Debug/Trace.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE BangPatterns             #-}+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-- |+-- Module      : Data.Array.Accelerate.Debug.Trace+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Functions for tracing and monitoring execution. These are useful for+-- investigating bugs and performance problems, but by default are not enabled+-- in performance code.+--++module Data.Array.Accelerate.Debug.Trace (++  showFFloatSIBase,++  putTraceMsg,+  trace, traceIO,+  traceEvent, traceEventIO,++) where++import Data.Array.Accelerate.Debug.Flags++import Numeric++#ifdef ACCELERATE_DEBUG+import System.IO.Unsafe+import Text.Printf+import qualified Debug.Trace                            as D+#endif+++-- | Show a signed 'RealFloat' value using SI unit prefixes. In the call to:+--+-- > showFFloatSIBase prec base val+--+-- If @prec@ is @'Nothing'@ the value is shown to full precision, and if @prec@+-- is @'Just' d@, then at most @d@ digits are shown after the decimal place.+-- Here @base@ represents the increment size between multiples of the original+-- unit. For measures in base-10 this will be 1000 and for values in base-2 this+-- is usually 1024, for example when measuring seconds versus bytes,+-- respectively.+--+showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> ShowS+showFFloatSIBase prec !base !k+  = showString+  $ case pow of+      4   -> with "T"+      3   -> with "G"+      2   -> with "M"+      1   -> with "k"+      -1  -> with "m"+      -2  -> with "µ"+      -3  -> with "n"+      -4  -> with "p"+      _   -> showGFloat prec k " "      -- no unit or unhandled SI prefix+  where+    !k'         = k / (base ^^ pow)+    !pow        = floor (logBase base k) :: Int+    with unit   = showFFloat prec k' (' ':unit)+++-- | The 'trace' function outputs the message given as its second argument when+-- the debug mode indicated by the first argument is enabled, before returning+-- the third argument as its result. The message is prefixed with a time stamp.+--+trace :: Flag -> String -> a -> a+#ifdef ACCELERATE_DEBUG+{-# NOINLINE trace #-}+trace f msg expr = unsafePerformIO $ do+  traceIO f msg+  return expr+#else+{-# INLINE trace #-}+trace _ _ expr = expr+#endif+++-- | The 'traceIO' function outputs the trace message together with a time stamp+-- from the IO monad. This sequences the output with respect to other IO+-- actions.++-- TLM: Perhaps we should automatically format the log messages. Namely:+--        * prefix with a description of the mode (e.g. "gc: foo")+--        * align multi-line messages+--+traceIO :: Flag -> String -> IO ()+#ifdef ACCELERATE_DEBUG+traceIO f msg = when f $ putTraceMsg msg+#else+{-# INLINE traceIO #-}+traceIO _ _   = return ()+#endif+++-- | The 'traceEvent' function behaves like 'trace' with the difference that the+-- message is emitted to the eventlog, if eventlog profiling is enabled at+-- runtime.+--+traceEvent :: Flag -> String -> a -> a+#ifdef ACCELERATE_DEBUG+{-# NOINLINE traceEvent #-}+traceEvent f msg expr = unsafePerformIO $ do+  traceEventIO f msg+  return expr+#else+{-# INLINE traceEvent #-}+traceEvent _ _ expr = expr+#endif+++-- | Print a message prefixed with the current elapsed wall-clock time.+--+putTraceMsg :: String -> IO ()+#ifdef ACCELERATE_DEBUG+putTraceMsg msg = do+  timestamp <- getProgramTime+  D.traceIO  $ printf "[%8.3f] %s" timestamp msg+#else+putTraceMsg _   = return ()+#endif+++-- | The 'traceEventIO' function emits a message to the eventlog, if eventlog+-- profiling is available and enabled at runtime.+--+-- Compared to 'traceEvent', 'traceEventIO' sequences the event with respect to+-- other IO actions.+--+traceEventIO :: Flag -> String -> IO ()+#ifdef ACCELERATE_DEBUG+traceEventIO f msg = do+  when f $ D.traceEventIO msg+#else+{-# INLINE traceEventIO #-}+traceEventIO _ _ = return ()+#endif++#ifdef ACCELERATE_DEBUG+foreign import ccall unsafe "clock_gettime_elapsed_seconds" getProgramTime :: IO Double+#endif+
+ src/Data/Array/Accelerate/Error.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Error+-- Copyright   : [2009..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.Error (++  internalError,   boundsError,   unsafeError,+  internalCheck,   boundsCheck,   unsafeCheck,   indexCheck,+  internalWarning, boundsWarning, unsafeWarning,++) where++import Data.List+import Debug.Trace+import Language.Haskell.TH                              hiding ( Unsafe )++data Check = Bounds | Unsafe | Internal+++-- | Issue an internal error message+--+--   $internalError :: String -> String -> a+--+internalError :: Q Exp+internalError = appE errorQ [| Internal |]++boundsError :: Q Exp+boundsError = appE errorQ [| Bounds |]++unsafeError :: Q Exp+unsafeError = appE errorQ [| Unsafe |]+++-- | Throw an error if the condition evaluates to False, otherwise evaluate the+-- result.+--+--   $internalCheck :: String -> String -> Bool -> a -> a+--+internalCheck :: Q Exp+internalCheck = appE checkQ [| Internal |]++boundsCheck :: Q Exp+boundsCheck = appE checkQ [| Bounds |]++unsafeCheck :: Q Exp+unsafeCheck = appE checkQ [| Unsafe |]+++-- | Throw an error if the index is not in range, otherwise evaluate the result.+--+--   $boundsCheck :: String -> Int -> Int -> a -> a+--+indexCheck :: Q Exp+indexCheck = withLocation+  [| \format fn i n x ->+        case not (doChecks Bounds) || (i >= 0 && i < n) of+           True  -> x+           False -> errorWithoutStackTrace (format Bounds (call fn ("index out of bounds: " ++ show (i,n)))) x |]+++-- | Print a warning message if the condition evaluates to False.+--+--   $internalWarning :: String -> String -> Bool -> a -> a+--+internalWarning :: Q Exp+internalWarning = appE warningQ [| Internal |]++boundsWarning :: Q Exp+boundsWarning = appE warningQ [| Bounds |]++unsafeWarning :: Q Exp+unsafeWarning = appE warningQ [| Unsafe |]+++-- Template Haskell implementation+-- -------------------------------++call :: String -> String -> String+call f m = concat ["(", f, "): ", m]++errorQ :: Q Exp+errorQ = withLocation+  [| \format kind fn msg -> errorWithoutStackTrace (format kind (call fn msg)) |]++checkQ :: Q Exp+checkQ = withLocation+  [| \format kind fn msg cond x ->+        case not (doChecks kind) || cond of+          True  -> x+          False -> errorWithoutStackTrace (format kind (call fn msg)) |]++warningQ :: Q Exp+warningQ = withLocation+  [| \format kind fn msg cond x ->+        case not (doChecks kind) || cond of+          True  -> x+          False -> trace (format kind (call fn msg)) x |]++withLocation :: Q Exp -> Q Exp+withLocation f =+  appE f (locatedMessage =<< location)++locatedMessage :: Loc -> Q Exp+locatedMessage loc =+  [| \kind msg -> message kind ($(litE (stringL (formatLoc loc))) ++ msg) |]++formatLoc :: Loc -> String+formatLoc loc =+  let   file            = loc_filename loc+        (line,col)      = loc_start loc+  in+  intercalate ":" [file, show line, show col, " "]++message :: Check -> String -> String+message kind msg = unlines header ++ msg+  where+    header =+      case kind of+        Internal -> [""+                    ,"*** Internal error in package accelerate ***"+                    ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"]+        _        -> []++#if __GLASGOW_HASKELL__ < 800+errorWithoutStackTrace :: String -> a+errorWithoutStackTrace = error+#endif+++-- CPP malarky+-- -----------++{-# INLINE doChecks #-}+doChecks :: Check -> Bool+doChecks Bounds   = doBoundsChecks+doChecks Unsafe   = doUnsafeChecks+doChecks Internal = doInternalChecks++doBoundsChecks :: Bool+#ifdef ACCELERATE_BOUNDS_CHECKS+doBoundsChecks = True+#else+doBoundsChecks = False+#endif++doUnsafeChecks :: Bool+#ifdef ACCELERATE_UNSAFE_CHECKS+doUnsafeChecks = True+#else+doUnsafeChecks = False+#endif++doInternalChecks :: Bool+#ifdef ACCELERATE_INTERNAL_CHECKS+doInternalChecks = True+#else+doInternalChecks = False+#endif+
+ src/Data/Array/Accelerate/Interpreter.hs view
@@ -0,0 +1,2094 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_HADDOCK prune #-}+-- |+-- Module      : Data.Array.Accelerate.Interpreter+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+--               [2014..2014] Frederik M. Madsen+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- This interpreter is meant to be a reference implementation of the semantics+-- of the embedded array language. The emphasis is on defining the semantics+-- clearly, not on performance.+--++-- [/Surface types versus representation types:/]+--+-- As a general rule, we perform all computations on representation types and we+-- store all data as values of representation types. To guarantee the type+-- safety of the interpreter, this currently implies a lot of conversions+-- between surface and representation types. Optimising the code by eliminating+-- back and forth conversions is fine, but only where it doesn't negatively+-- affects clarity---after all, the main purpose of the interpreter is to serve+-- as an executable specification.+--++module Data.Array.Accelerate.Interpreter (++  -- * Interpret an array expression+  Sugar.Acc, Arrays,+  run, run1, runN,++  -- Internal (hidden)+  evalPrj,+  evalPrim, evalPrimConst, evalUndef, evalCoerce,++) where++-- standard libraries+import Control.DeepSeq+import Control.Exception+import Control.Monad+import Data.Bits+import Data.Char                                                    ( chr, ord )+import Data.Constraint+import Data.Typeable+import Foreign.C.Types+import Foreign.ForeignPtr+import System.IO.Unsafe                                             ( unsafePerformIO )+import Text.Printf                                                  ( printf )+import Prelude                                                      hiding ( sum )++-- friends+import Data.Array.Accelerate.AST                                    hiding ( Boundary, PreBoundary(..) )+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Analysis.Type+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Representation                   ( SliceIndex(..) )+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Trafo                                  hiding ( Delayed )+import Data.Array.Accelerate.Type+import qualified Data.Array.Accelerate.AST                          as AST+import qualified Data.Array.Accelerate.Array.Representation         as R+import qualified Data.Array.Accelerate.Smart                        as Sugar+import qualified Data.Array.Accelerate.Trafo                        as AST++import qualified Data.Array.Accelerate.Debug                        as D+++-- Program execution+-- -----------------++-- | Run a complete embedded array program using the reference interpreter.+--+run :: Arrays a => Sugar.Acc a -> a+run a = unsafePerformIO execute+  where+    !acc    = convertAccWith config a+    execute = do+      D.dumpGraph $!! acc+      D.dumpSimplStats+      phase "execute" D.elapsed (evaluate (evalOpenAcc acc Empty))++-- | This is 'runN' specialised to an array program of one argument.+--+run1 :: (Arrays a, Arrays b) => (Sugar.Acc a -> Sugar.Acc b) -> a -> b+run1 = runN++-- | Prepare and execute an embedded array program.+--+runN :: Afunction f => f -> AfunctionR f+runN f = go+  where+    !acc    = convertAfunWith config f+    !afun   = unsafePerformIO $ do+                D.dumpGraph $!! acc+                D.dumpSimplStats+                return acc+    !go     = eval afun Empty+    --+    eval :: DelayedOpenAfun aenv f -> Val aenv -> f+    eval (Alam f)  aenv = \a -> eval f (aenv `Push` a)+    eval (Abody b) aenv = unsafePerformIO $ phase "execute" D.elapsed (evaluate (evalOpenAcc b aenv))+++-- -- | Stream a lazily read list of input arrays through the given program,+-- -- collecting results as we go+-- --+-- streamOut :: Arrays a => Sugar.Seq [a] -> [a]+-- streamOut seq = let seq' = convertSeqWith config seq+--                 in evalDelayedSeq defaultSeqConfig seq'+++config :: Phase+config =  Phase+  { recoverAccSharing      = True+  , recoverExpSharing      = True+  , recoverSeqSharing      = True+  , floatOutAccFromExp     = True+  , enableAccFusion        = True+  , convertOffsetOfSegment = False+  -- , vectoriseSequences     = True+  }++-- Debugging+-- ---------++phase :: String -> (Double -> Double -> String) -> IO a -> IO a+phase n fmt go = D.timed D.dump_phases (\wall cpu -> printf "phase %s: %s" n (fmt wall cpu)) go+++-- Delayed Arrays+-- --------------++-- Note that in contrast to the representation used in the optimised AST, the+-- delayed array representation used here is _only_ for delayed arrays --- we do+-- not require an optional Manifest|Delayed data type to evaluate the program.+--+data Delayed a where+  Delayed :: (Shape sh, Elt e)+          => sh+          -> (sh -> e)+          -> (Int -> e)+          -> Delayed (Array sh e)+++-- Array expression evaluation+-- ---------------------------++type EvalAcc acc = forall aenv a. acc aenv a -> Val aenv -> a++-- Evaluate an open array function+--+evalOpenAfun :: DelayedOpenAfun aenv f -> Val aenv -> f+evalOpenAfun (Alam  f) aenv = \a -> evalOpenAfun f (aenv `Push` a)+evalOpenAfun (Abody b) aenv = evalOpenAcc b aenv+++-- The core interpreter for optimised array programs+--+evalOpenAcc+    :: forall aenv a.+       DelayedOpenAcc aenv a+    -> Val aenv+    -> a+evalOpenAcc AST.Delayed{}       _    = $internalError "evalOpenAcc" "expected manifest array"+evalOpenAcc (AST.Manifest pacc) aenv =+  let+      manifest :: Arrays a' => DelayedOpenAcc aenv a' -> a'+      manifest acc =+        let a' = evalOpenAcc acc aenv+        in  rnfArrays (arrays a') (fromArr a') `seq` a'++      delayed :: DelayedOpenAcc aenv (Array sh e) -> Delayed (Array sh e)+      delayed AST.Manifest{}  = $internalError "evalOpenAcc" "expected delayed array"+      delayed AST.Delayed{..} = Delayed (evalE extentD) (evalF indexD) (evalF linearIndexD)++      evalE :: DelayedExp aenv t -> t+      evalE exp = evalPreExp evalOpenAcc exp aenv++      evalF :: DelayedFun aenv f -> f+      evalF fun = evalPreFun evalOpenAcc fun aenv++      evalB :: AST.PreBoundary DelayedOpenAcc aenv t -> Boundary t+      evalB bnd = evalPreBoundary evalOpenAcc bnd aenv+  in+  case pacc of+    Avar ix                     -> prj ix aenv+    Alet acc1 acc2              -> evalOpenAcc acc2 (aenv `Push` manifest acc1)+    Atuple atup                 -> toAtuple $ evalAtuple atup aenv+    Aprj ix atup                -> evalPrj ix . fromAtuple $ manifest atup+    Apply afun acc              -> evalOpenAfun afun aenv  $ manifest acc+    Aforeign _ afun acc         -> evalOpenAfun afun Empty $ manifest acc+    Acond p acc1 acc2+      | evalE p                 -> manifest acc1+      | otherwise               -> manifest acc2++    Awhile cond body acc        -> go (manifest acc)+      where+        p       = evalOpenAfun cond aenv+        f       = evalOpenAfun body aenv+        go !x+          | p x ! Z     = go (f x)+          | otherwise   = x++    Use arr                     -> toArr arr+    Unit e                      -> unitOp (evalE e)+    -- Collect s                   -> evalSeq defaultSeqConfig s aenv++    -- Producers+    -- ---------+    Map f acc                   -> mapOp (evalF f) (delayed acc)+    Generate sh f               -> generateOp (evalE sh) (evalF f)+    Transform sh p f acc        -> transformOp (evalE sh) (evalF p) (evalF f) (delayed acc)+    Backpermute sh p acc        -> backpermuteOp (evalE sh) (evalF p) (delayed acc)+    Reshape sh acc              -> reshapeOp (evalE sh) (manifest acc)++    ZipWith f acc1 acc2         -> zipWithOp (evalF f) (delayed acc1) (delayed acc2)+    Replicate slice slix acc    -> replicateOp slice (evalE slix) (manifest acc)+    Slice slice acc slix        -> sliceOp slice (manifest acc) (evalE slix)++    -- Consumers+    -- ---------+    Fold f z acc                -> foldOp (evalF f) (evalE z) (delayed acc)+    Fold1 f acc                 -> fold1Op (evalF f) (delayed acc)+    FoldSeg f z acc seg         -> foldSegOp (evalF f) (evalE z) (delayed acc) (delayed seg)+    Fold1Seg f acc seg          -> fold1SegOp (evalF f) (delayed acc) (delayed seg)+    Scanl f z acc               -> scanlOp (evalF f) (evalE z) (delayed acc)+    Scanl' f z acc              -> scanl'Op (evalF f) (evalE z) (delayed acc)+    Scanl1 f acc                -> scanl1Op (evalF f) (delayed acc)+    Scanr f z acc               -> scanrOp (evalF f) (evalE z) (delayed acc)+    Scanr' f z acc              -> scanr'Op (evalF f) (evalE z) (delayed acc)+    Scanr1 f acc                -> scanr1Op (evalF f) (delayed acc)+    Permute f def p acc         -> permuteOp (evalF f) (manifest def) (evalF p) (delayed acc)+    Stencil sten b acc          -> stencilOp (evalF sten) (evalB b) (delayed acc)+    Stencil2 sten b1 a1 b2 a2   -> stencil2Op (evalF sten) (evalB b1) (delayed a1) (evalB b2) (delayed a2)++-- Array tuple construction and projection+--+evalAtuple :: Atuple (DelayedOpenAcc aenv) t -> Val aenv -> t+evalAtuple NilAtup        _    = ()+evalAtuple (SnocAtup t a) aenv = (evalAtuple t aenv, evalOpenAcc a aenv)+++-- Array primitives+-- ----------------++unitOp :: Elt e => e -> Scalar e+unitOp e = fromFunction Z (const e)+++generateOp+    :: (Shape sh, Elt e)+    => sh+    -> (sh -> e)+    -> Array sh e+generateOp = fromFunction+++transformOp+    :: (Shape sh', Elt b)+    => sh'+    -> (sh' -> sh)+    -> (a -> b)+    -> Delayed (Array sh a)+    -> Array sh' b+transformOp sh' p f (Delayed _ xs _)+  = fromFunction sh' (\ix -> f (xs $ p ix))+++reshapeOp+    :: (Shape sh, Shape sh', Elt e)+    => sh+    -> Array sh' e+    -> Array sh  e+reshapeOp newShape arr@(Array _ adata)+  = $boundsCheck "reshape" "shape mismatch" (size newShape == size (shape arr))+  $ Array (fromElt newShape) adata+++replicateOp+    :: (Shape sh, Shape sl, Elt slix, Elt e)+    => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+    -> slix+    -> Array sl e+    -> Array sh e+replicateOp slice slix arr+  = fromFunction (toElt sh) (\ix -> arr ! liftToElt pf ix)+  where+    (sh, pf) = extend slice (fromElt slix) (fromElt (shape arr))++    extend :: SliceIndex slix sl co dim+           -> slix+           -> sl+           -> (dim, dim -> sl)+    extend SliceNil              ()        ()+      = ((), const ())+    extend (SliceAll sliceIdx)   (slx, ()) (sl, sz)+      = let (dim', f') = extend sliceIdx slx sl+        in  ((dim', sz), \(ix, i) -> (f' ix, i))+    extend (SliceFixed sliceIdx) (slx, sz) sl+      = let (dim', f') = extend sliceIdx slx sl+        in  ((dim', sz), \(ix, _) -> f' ix)+++sliceOp+    :: (Shape sh, Shape sl, Elt slix, Elt e)+    => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+    -> Array sh e+    -> slix+    -> Array sl e+sliceOp slice arr slix+  = fromFunction (toElt sh') (\ix -> arr ! liftToElt pf ix)+  where+    (sh', pf) = restrict slice (fromElt slix) (fromElt (shape arr))++    restrict :: SliceIndex slix sl co sh+             -> slix+             -> sh+             -> (sl, sl -> sh)+    restrict SliceNil              ()        ()+      = ((), const ())+    restrict (SliceAll sliceIdx)   (slx, ()) (sl, sz)+      = let (sl', f') = restrict sliceIdx slx sl+        in  ((sl', sz), \(ix, i) -> (f' ix, i))+    restrict (SliceFixed sliceIdx) (slx, i)  (sl, sz)+      = let (sl', f') = restrict sliceIdx slx sl+        in  $indexCheck "slice" i sz $ (sl', \ix -> (f' ix, i))+++mapOp :: (Shape sh, Elt b)+      => (a -> b)+      -> Delayed (Array sh a)+      -> Array sh b+mapOp f (Delayed sh xs _)+  = fromFunction sh (\ix -> f (xs ix))+++zipWithOp+    :: (Shape sh, Elt c)+    => (a -> b -> c)+    -> Delayed (Array sh a)+    -> Delayed (Array sh b)+    -> Array sh c+zipWithOp f (Delayed shx xs _) (Delayed shy ys _)+  = fromFunction (shx `intersect` shy) (\ix -> f (xs ix) (ys ix))++-- zipWith'Op+--     :: (Shape sh, Elt a)+--     => (a -> a -> a)+--     -> Delayed (Array sh a)+--     -> Delayed (Array sh a)+--     -> Array sh a+-- zipWith'Op f (Delayed shx xs _) (Delayed shy ys _)+--   = fromFunction (shx `union` shy) (\ix -> if ix `outside` shx+--                                            then ys ix+--                                            else if ix `outside` shy+--                                            then xs ix+--                                            else f (xs ix) (ys ix))+--   where+--     a `outside` b = or $ zipWith (>=) (shapeToList a) (shapeToList b)+++foldOp+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Delayed (Array (sh :. Int) e)+    -> Array sh e+foldOp f z (Delayed (sh :. n) arr _)+  = fromFunction sh (\ix -> iter (Z:.n) (\(Z:.i) -> arr (ix :. i)) f z)+++fold1Op+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> Delayed (Array (sh :. Int) e)+    -> Array sh e+fold1Op f (Delayed (sh :. n) arr _)+  = $boundsCheck "fold1" "empty array" (n > 0)+  $ fromFunction sh (\ix -> iter1 (Z:.n) (\(Z:.i) -> arr (ix :. i)) f)+++foldSegOp+    :: forall sh e i. (Elt e, Elt i, IsIntegral i)+    => (e -> e -> e)+    -> e+    -> Delayed (Array (sh :. Int) e)+    -> Delayed (Segments i)+    -> Array (sh :. Int) e+foldSegOp f z (Delayed (sh :. _) arr _) seg@(Delayed (Z :. n) _ _)+  | IntegralDict <- integralDict (integralType :: IntegralType i)+  = fromFunction (sh :. n)+  $ \(sz :. ix) -> let start = fromIntegral $ offset ! (Z :. ix)+                       end   = fromIntegral $ offset ! (Z :. ix+1)+                   in+                   iter (Z :. end-start) (\(Z:.i) -> arr (sz :. start+i)) f z+  where+    offset      = scanlOp (+) 0 seg+++fold1SegOp+    :: forall sh e i. (Shape sh, Elt e, Elt i, IsIntegral i)+    => (e -> e -> e)+    -> Delayed (Array (sh :. Int) e)+    -> Delayed (Segments i)+    -> Array (sh :. Int) e+fold1SegOp f (Delayed (sh :. _) arr _) seg@(Delayed (Z :. n) _ _)+  | IntegralDict <- integralDict (integralType :: IntegralType i)+  = fromFunction (sh :. n)+  $ \(sz :. ix) -> let start = fromIntegral $ offset ! (Z :. ix)+                       end   = fromIntegral $ offset ! (Z :. ix+1)+                   in+                   $boundsCheck "fold1Seg" "empty segment" (end > start)+                   $ iter1 (Z :. end-start) (\(Z:.i) -> arr (sz :. start+i)) f+  where+    offset      = scanlOp (+) 0 seg+++scanl1Op+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> Delayed (Array (sh:.Int) e)+    -> Array (sh:.Int) e+scanl1Op f (Delayed sh@(_ :. n) ain _)+  = $boundsCheck "scanl1" "empty array" (n > 0)+  $ adata `seq` Array (fromElt sh) adata+  where+    f'          = sinkFromElt2 f+    --+    (adata, _)  = runArrayData $ do+      aout <- newArrayData (size sh)++      let write (sz:.0) = unsafeWriteArrayData aout (toIndex sh (sz:.0)) (fromElt (ain (sz:.0)))+          write (sz:.i) = do+            x <- unsafeReadArrayData aout (toIndex sh (sz:.i-1))+            y <- return $ fromElt (ain (sz:.i))+            unsafeWriteArrayData aout (toIndex sh (sz:.i)) (f' x y)++      iter sh write (>>) (return ())+      return (aout, undefined)+++scanlOp+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Delayed (Array (sh:.Int) e)+    -> Array (sh:.Int) e+scanlOp f z (Delayed (sh :. n) ain _)+  = adata `seq` Array (fromElt sh') adata+  where+    sh'         = sh :. n+1+    f'          = sinkFromElt2 f+    --+    (adata, _)  = runArrayData $ do+      aout <- newArrayData (size sh')++      let write (sz:.0) = unsafeWriteArrayData aout (toIndex sh' (sz:.0)) (fromElt z)+          write (sz:.i) = do+            x <- unsafeReadArrayData aout (toIndex sh' (sz:.i-1))+            y <- return $ fromElt (ain (sz:.i-1))+            unsafeWriteArrayData aout (toIndex sh' (sz:.i)) (f' x y)++      iter sh' write (>>) (return ())+      return (aout, undefined)+++scanl'Op+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Delayed (Array (sh:.Int) e)+    -> (Array (sh:.Int) e, Array sh e)+scanl'Op f z (Delayed (sh :. n) ain _)+  = aout `seq` asum `seq` ( Array (fromElt (sh:.n)) aout+                          , Array (fromElt sh)      asum )+  where+    f'          = sinkFromElt2 f+    --+    (AD_Pair aout asum, _) = runArrayData $ do+      aout <- newArrayData (size (sh:.n))+      asum <- newArrayData (size sh)++      let write (sz:.0)+            | n == 0    = unsafeWriteArrayData asum (toIndex sh sz) (fromElt z)+            | otherwise = unsafeWriteArrayData aout (toIndex (sh:.n) (sz:.0)) (fromElt z)+          write (sz:.i) = do+            x <- unsafeReadArrayData aout (toIndex (sh:.n) (sz:.i-1))+            y <- return $ fromElt (ain (sz:.i-1))+            if i == n+              then unsafeWriteArrayData asum (toIndex sh      sz)      (f' x y)+              else unsafeWriteArrayData aout (toIndex (sh:.n) (sz:.i)) (f' x y)++      iter (sh:.n+1) write (>>) (return ())+      return (AD_Pair aout asum, undefined)+++scanrOp+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Delayed (Array (sh:.Int) e)+    -> Array (sh:.Int) e+scanrOp f z (Delayed (sz :. n) ain _)+  = adata `seq` Array (fromElt sh') adata+  where+    sh'         = sz :. n+1+    f'          = sinkFromElt2 f+    --+    (adata, _)  = runArrayData $ do+      aout <- newArrayData (size sh')++      let write (sz:.0) = unsafeWriteArrayData aout (toIndex sh' (sz:.n)) (fromElt z)+          write (sz:.i) = do+            x <- return $ fromElt (ain (sz:.n-i))+            y <- unsafeReadArrayData aout (toIndex sh' (sz:.n-i+1))+            unsafeWriteArrayData aout (toIndex sh' (sz:.n-i)) (f' x y)++      iter sh' write (>>) (return ())+      return (aout, undefined)+++scanr1Op+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> Delayed (Array (sh:.Int) e)+    -> Array (sh:.Int) e+scanr1Op f (Delayed sh@(_ :. n) ain _)+  = $boundsCheck "scanr1" "empty array" (n > 0)+  $ adata `seq` Array (fromElt sh) adata+  where+    f'          = sinkFromElt2 f+    --+    (adata, _)  = runArrayData $ do+      aout <- newArrayData (size sh)++      let write (sz:.0) = unsafeWriteArrayData aout (toIndex sh (sz:.n-1)) (fromElt (ain (sz:.n-1)))+          write (sz:.i) = do+            x <- return $ fromElt (ain (sz:.n-i-1))+            y <- unsafeReadArrayData aout (toIndex sh (sz:.n-i))+            unsafeWriteArrayData aout (toIndex sh (sz:.n-i-1)) (f' x y)++      iter sh write (>>) (return ())+      return (aout, undefined)+++scanr'Op+    :: forall sh e. (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Delayed (Array (sh:.Int) e)+    -> (Array (sh:.Int) e, Array sh e)+scanr'Op f z (Delayed (sh :. n) ain _)+  = aout `seq` asum `seq` ( Array (fromElt (sh:.n)) aout+                          , Array (fromElt sh)      asum )+  where+    f'          = sinkFromElt2 f+    --+    (AD_Pair aout asum, _) = runArrayData $ do+      aout <- newArrayData (size (sh:.n))+      asum <- newArrayData (size sh)++      let write (sz:.0)+            | n == 0    = unsafeWriteArrayData asum (toIndex sh sz) (fromElt z)+            | otherwise = unsafeWriteArrayData aout (toIndex (sh:.n) (sz:.n-1)) (fromElt z)++          write (sz:.i) = do+            x <- return $ fromElt (ain (sz:.n-i))+            y <- unsafeReadArrayData aout (toIndex (sh:.n) (sz:.n-i))+            if i == n+              then unsafeWriteArrayData asum (toIndex sh      sz)          (f' x y)+              else unsafeWriteArrayData aout (toIndex (sh:.n) (sz:.n-i-1)) (f' x y)++      iter (sh:.n+1) write (>>) (return ())+      return (AD_Pair aout asum, undefined)+++permuteOp+    :: (Shape sh, Shape sh', Elt e)+    => (e -> e -> e)+    -> Array sh' e+    -> (sh -> sh')+    -> Delayed (Array sh  e)+    -> Array sh' e+permuteOp f def@(Array _ adef) p (Delayed sh _ ain)+  = adata `seq` Array (fromElt sh') adata+  where+    sh'         = shape def+    n'          = size sh'+    f'          = sinkFromElt2 f+    --+    (adata, _)  = runArrayData $ do+      aout <- newArrayData n'++      let -- initialise array with default values+          init i+            | i >= n'   = return ()+            | otherwise = do+                x <- unsafeReadArrayData adef i+                unsafeWriteArrayData aout i x+                init (i+1)++          -- project each element onto the destination array and update+          update src+            = let dst   = p src+                  i     = toIndex sh  src+                  j     = toIndex sh' dst+              in+              unless (fromElt dst == R.ignore) $ do+                x <- return . fromElt $  ain  i+                y <- unsafeReadArrayData aout j+                unsafeWriteArrayData aout j (f' x y)++      init 0+      iter sh update (>>) (return ())+      return (aout, undefined)+++backpermuteOp+    :: (Shape sh', Elt e)+    => sh'+    -> (sh' -> sh)+    -> Delayed (Array sh e)+    -> Array sh' e+backpermuteOp sh' p (Delayed _ arr _)+  = fromFunction sh' (\ix -> arr $ p ix)+++stencilOp+    :: (Stencil sh a stencil, Elt b)+    => (stencil -> b)+    -> Boundary (Array sh a)+    -> Delayed  (Array sh a)+    -> Array sh b+stencilOp stencil bnd arr@(Delayed sh _ _)+  = fromFunction sh+  $ stencil . stencilAccess (bounded bnd arr)+++stencil2Op+    :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c)+    => (stencil1 -> stencil2 -> c)+    -> Boundary (Array sh a)+    -> Delayed  (Array sh a)+    -> Boundary (Array sh b)+    -> Delayed  (Array sh b)+    -> Array sh c+stencil2Op stencil bnd1 arr1@(Delayed sh1 _ _) bnd2 arr2@(Delayed sh2 _ _)+  = fromFunction (sh1 `intersect` sh2) f+  where+    f ix  = stencil (stencilAccess (bounded bnd1 arr1) ix)+                    (stencilAccess (bounded bnd2 arr2) ix)++stencilAccess+    :: Stencil sh e stencil+    => (sh -> e)+    -> sh+    -> stencil+stencilAccess = goR stencil+  where+    -- Base cases, nothing interesting to do here since we know the lower+    -- dimension is Z.+    --+    goR :: StencilR sh e stencil -> (sh -> e) -> sh -> stencil+    goR StencilRunit3 rf ix =+      let+          z :. i = ix+          rf' d  = rf (z :. i+d)+      in+      ( rf' (-1)+      , rf'   0+      , rf'   1+      )++    goR StencilRunit5 rf ix =+      let z :. i = ix+          rf' d  = rf (z :. i+d)+      in+      ( rf' (-2)+      , rf' (-1)+      , rf'   0+      , rf'   1+      , rf'   2+      )++    goR StencilRunit7 rf ix =+      let z :. i = ix+          rf' d  = rf (z :. i+d)+      in+      ( rf' (-3)+      , rf' (-2)+      , rf' (-1)+      , rf'   0+      , rf'   1+      , rf'   2+      , rf'   3+      )++    goR StencilRunit9 rf ix =+      let z :. i = ix+          rf' d  = rf (z :. i+d)+      in+      ( rf' (-4)+      , rf' (-3)+      , rf' (-2)+      , rf' (-1)+      , rf'   0+      , rf'   1+      , rf'   2+      , rf'   3+      , rf'   4+      )++    -- Recursive cases. Note that because the stencil pattern is defined with+    -- cons ordering, whereas shapes (and indices) are defined as a snoc-list,+    -- when we recurse on the stencil structure we must manipulate the+    -- _left-most_ index component.+    --+    goR (StencilRtup3 s1 s2 s3) rf ix =+      let (i, ix') = uncons ix+          rf' d ds = rf (cons (i+d) ds)+      in+      ( goR s1 (rf' (-1)) ix'+      , goR s2 (rf'   0)  ix'+      , goR s3 (rf'   1)  ix'+      )++    goR (StencilRtup5 s1 s2 s3 s4 s5) rf ix =+      let (i, ix') = uncons ix+          rf' d ds = rf (cons (i+d) ds)+      in+      ( goR s1 (rf' (-2)) ix'+      , goR s2 (rf' (-1)) ix'+      , goR s3 (rf'   0)  ix'+      , goR s4 (rf'   1)  ix'+      , goR s5 (rf'   2)  ix'+      )++    goR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) rf ix =+      let (i, ix') = uncons ix+          rf' d ds = rf (cons (i+d) ds)+      in+      ( goR s1 (rf' (-3)) ix'+      , goR s2 (rf' (-2)) ix'+      , goR s3 (rf' (-1)) ix'+      , goR s4 (rf'   0)  ix'+      , goR s5 (rf'   1)  ix'+      , goR s6 (rf'   2)  ix'+      , goR s7 (rf'   3)  ix'+      )++    goR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) rf ix =+      let (i, ix') = uncons ix+          rf' d ds = rf (cons (i+d) ds)+      in+      ( goR s1 (rf' (-4)) ix'+      , goR s2 (rf' (-3)) ix'+      , goR s3 (rf' (-2)) ix'+      , goR s4 (rf' (-1)) ix'+      , goR s5 (rf'   0)  ix'+      , goR s6 (rf'   1)  ix'+      , goR s7 (rf'   2)  ix'+      , goR s8 (rf'   3)  ix'+      , goR s9 (rf'   4)  ix'+      )++    -- Add a left-most component to an index+    --+    cons :: forall sh. Shape sh => Int -> sh -> (sh :. Int)+    cons ix extent = toElt $ go (eltType (undefined::sh)) (fromElt extent)+      where+        go :: TupleType t -> t -> (t, Int)+        go TypeRunit         ()       = ((), ix)+        go (TypeRpair th tz) (sh, sz)+          | TypeRscalar t <- tz+          , Just Refl     <- matchScalarType t (scalarType :: ScalarType Int)+          = (go th sh, sz)+        go _ _+          = $internalError "cons" "expected index with Int components"++    -- Remove the left-most index of an index, and return the remainder+    --+    uncons :: forall sh. Shape sh => sh :. Int -> (Int, sh)+    uncons extent = let (i,ix) = go (eltType (undefined::(sh:.Int))) (fromElt extent)+                    in  (i, toElt ix)+      where+        go :: TupleType (t, Int) -> (t, Int) -> (Int, t)+        go (TypeRpair TypeRunit _)           ((), v) = (v, ())+        go (TypeRpair t1@(TypeRpair _ t2) _) (v1,v3)+          | TypeRscalar t <- t2+          , Just Refl     <- matchScalarType t (scalarType :: ScalarType Int)+          = let (i, v1') = go t1 v1+            in  (i, (v1', v3))+        go _ _+          = $internalError "uncons" "expected index with Int components"+++bounded+    :: (Shape sh, Elt e)+    => Boundary (Array sh e)+    -> Delayed (Array sh e)+    -> sh+    -> e+bounded bnd (Delayed sh f _) ix =+  if inside sh ix+    then f ix+    else+      case bnd of+        Function g -> g ix+        Constant v -> toElt v+        _          -> f (bound sh ix)++  where+    -- Whether the index (second argument) is inside the bounds of the given+    -- shape (first argument).+    --+    inside :: forall sh. Shape sh => sh -> sh -> Bool+    inside sh1 ix1 = go (eltType (undefined::sh)) (fromElt sh1) (fromElt ix1)+      where+        go :: TupleType t -> t -> t -> Bool+        go TypeRunit          ()       ()      = True+        go (TypeRpair tsh ti) (sh, sz) (ih,iz)+          = if go ti sz iz+              then go tsh sh ih+              else False+        go (TypeRscalar t) sz iz+          | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+          = if iz < 0 || iz >= sz+              then False+              else True+          --+          | otherwise+          = $internalError "inside" "expected index with Int components"++    -- Return the index (second argument), updated to obey the given boundary+    -- conditions when outside the bounds of the given shape (first argument)+    --+    bound :: forall sh. Shape sh => sh -> sh -> sh+    bound sh1 ix1 = toElt $ go (eltType (undefined::sh)) (fromElt sh1) (fromElt ix1)+      where+        go :: TupleType t -> t -> t -> t+        go TypeRunit          ()       ()       = ()+        go (TypeRpair tsh ti) (sh, sz) (ih, iz) = (go tsh sh ih, go ti sz iz)+        go (TypeRscalar t)    sz       iz+          | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+          = let i | iz < 0    = case bnd of+                                  Clamp  -> 0+                                  Mirror -> -iz+                                  Wrap   -> sz + iz+                                  _      -> $internalError "bound" "unexpected boundary condition"+                  | iz >= sz  = case bnd of+                                  Clamp  -> sz - 1+                                  Mirror -> sz - (iz - sz + 2)+                                  Wrap   -> iz - sz+                                  _      -> $internalError "bound" "unexpected boundary condition"+                  | otherwise = iz+            in i+          | otherwise+          = $internalError "bound" "expected index with Int components"+++-- toSeqOp :: forall slix sl dim co e proxy. (Elt slix, Shape sl, Shape dim, Elt e)+--         => SliceIndex (EltRepr slix)+--                       (EltRepr sl)+--                       co+--                       (EltRepr dim)+--         -> proxy slix+--         -> Array dim e+--         -> [Array sl e]+-- toSeqOp sliceIndex _ arr = map (sliceOp sliceIndex arr :: slix -> Array sl e)+--                                (enumSlices sliceIndex (shape arr))+++-- Stencil boundary conditions+-- ---------------------------++data Boundary t where+  Clamp    :: Boundary t+  Mirror   :: Boundary t+  Wrap     :: Boundary t+  Constant :: Elt t => EltRepr t -> Boundary (Array sh t)+  Function :: (Shape sh, Elt e) => (sh -> e) -> Boundary (Array sh e)+++evalPreBoundary :: EvalAcc acc -> AST.PreBoundary acc aenv t -> Val aenv -> Boundary t+evalPreBoundary evalAcc bnd aenv =+  case bnd of+    AST.Clamp      -> Clamp+    AST.Mirror     -> Mirror+    AST.Wrap       -> Wrap+    AST.Constant v -> Constant v+    AST.Function f -> Function (evalPreFun evalAcc f aenv)+++-- Scalar expression evaluation+-- ----------------------------++-- Evaluate a closed scalar expression+--+evalPreExp :: EvalAcc acc -> PreExp acc aenv t -> Val aenv -> t+evalPreExp evalAcc e aenv = evalPreOpenExp evalAcc e EmptyElt aenv++-- Evaluate a closed scalar function+--+evalPreFun :: EvalAcc acc -> PreFun acc aenv t -> Val aenv -> t+evalPreFun evalAcc f aenv = evalPreOpenFun evalAcc f EmptyElt aenv++-- Evaluate an open scalar function+--+evalPreOpenFun :: EvalAcc acc -> PreOpenFun acc env aenv t -> ValElt env -> Val aenv -> t+evalPreOpenFun evalAcc (Body e) env aenv = evalPreOpenExp evalAcc e env aenv+evalPreOpenFun evalAcc (Lam f)  env aenv =+  \x -> evalPreOpenFun evalAcc f (env `PushElt` fromElt x) aenv+++-- Evaluate an open scalar expression+--+-- NB: The implementation of 'Index' and 'Shape' demonstrate clearly why+--     array expressions must be hoisted out of scalar expressions before code+--     execution. If these operations are in the body of a function that gets+--     mapped over an array, the array argument would be evaluated many times+--     leading to a large amount of wasteful recomputation.+--+evalPreOpenExp+    :: forall acc env aenv t.+       EvalAcc acc+    -> PreOpenExp acc env aenv t+    -> ValElt env+    -> Val aenv+    -> t+evalPreOpenExp evalAcc pexp env aenv =+  let+      evalE :: PreOpenExp acc env aenv t' -> t'+      evalE e = evalPreOpenExp evalAcc e env aenv++      evalF :: PreOpenFun acc env aenv f' -> f'+      evalF f = evalPreOpenFun evalAcc f env aenv++      evalA :: acc aenv a -> a+      evalA a = evalAcc a aenv+  in+  case pexp of+    Let exp1 exp2               -> let !v1  = evalE exp1+                                       env' = env `PushElt` fromElt v1+                                   in  evalPreOpenExp evalAcc exp2 env' aenv+    Var ix                      -> prjElt ix env+    Const c                     -> toElt c+    Undef                       -> evalUndef+    PrimConst c                 -> evalPrimConst c+    PrimApp f x                 -> evalPrim f (evalE x)+    Tuple tup                   -> toTuple $ evalTuple evalAcc tup env aenv+    Prj ix tup                  -> evalPrj ix . fromTuple $ evalE tup+    IndexNil                    -> Z+    IndexAny                    -> Any+    IndexCons sh sz             -> evalE sh :. evalE sz+    IndexHead sh                -> let _  :. ix = evalE sh in ix+    IndexTail sh                -> let ix :. _  = evalE sh in ix+    IndexSlice slice slix sh    -> toElt $ restrict slice (fromElt (evalE slix))+                                                          (fromElt (evalE sh))+      where+        restrict :: SliceIndex slix sl co sh -> slix -> sh -> sl+        restrict SliceNil              ()        ()         = ()+        restrict (SliceAll sliceIdx)   (slx, ()) (sl, sz)   =+          let sl' = restrict sliceIdx slx sl+          in  (sl', sz)+        restrict (SliceFixed sliceIdx) (slx, _i)  (sl, _sz) =+          restrict sliceIdx slx sl++    IndexFull slice slix sh     -> toElt $ extend slice (fromElt (evalE slix))+                                                        (fromElt (evalE sh))+      where+        extend :: SliceIndex slix sl co sh -> slix -> sl -> sh+        extend SliceNil              ()        ()       = ()+        extend (SliceAll sliceIdx)   (slx, ()) (sl, sz) =+          let sh' = extend sliceIdx slx sl+          in  (sh', sz)+        extend (SliceFixed sliceIdx) (slx, sz) sl       =+          let sh' = extend sliceIdx slx sl+          in  (sh', sz)++    ToIndex sh ix               -> toIndex (evalE sh) (evalE ix)+    FromIndex sh ix             -> fromIndex (evalE sh) (evalE ix)+    Cond c t e+      | evalE c                 -> evalE t+      | otherwise               -> evalE e++    While cond body seed        -> go (evalE seed)+      where+        f       = evalF body+        p       = evalF cond+        go !x+          | p x         = go (f x)+          | otherwise   = x++    Index acc ix                -> evalA acc ! evalE ix+    LinearIndex acc i           -> let a  = evalA acc+                                       ix = fromIndex (shape a) (evalE i)+                                   in a ! ix+    Shape acc                   -> shape (evalA acc)+    ShapeSize sh                -> size (evalE sh)+    Intersect sh1 sh2           -> intersect (evalE sh1) (evalE sh2)+    Union sh1 sh2               -> union (evalE sh1) (evalE sh2)+    Foreign _ f e               -> evalPreOpenFun evalAcc f EmptyElt Empty $ evalE e+    Coerce e                    -> evalCoerce (evalE e)+++-- Constant values+-- ---------------++evalUndef :: forall a. Elt a => a+evalUndef = toElt (undef (eltType (undefined::a)))+  where+    undef :: TupleType t -> t+    undef TypeRunit       = ()+    undef (TypeRpair a b) = (undef a, undef b)+    undef (TypeRscalar t) = scalar t++    scalar :: ScalarType t -> t+    scalar (SingleScalarType t) = single t+    scalar (VectorScalarType t) = vector t++    single :: SingleType t -> t+    single (NumSingleType    t) = num t+    single (NonNumSingleType t) = nonnum t++    vector :: VectorType t -> t+    vector (Vector2Type t)  = let x = single t in V2 x x+    vector (Vector3Type t)  = let x = single t in V3 x x x+    vector (Vector4Type t)  = let x = single t in V4 x x x x+    vector (Vector8Type t)  = let x = single t in V8 x x x x x x x x+    vector (Vector16Type t) = let x = single t in V16 x x x x x x x x x x x x x x x x++    num :: NumType t -> t+    num (IntegralNumType t) | IntegralDict <- integralDict t = 0+    num (FloatingNumType t) | FloatingDict <- floatingDict t = 0++    nonnum :: NonNumType t -> t+    nonnum TypeBool{}   = False+    nonnum TypeChar{}   = chr 0+    nonnum TypeCChar{}  = CChar 0+    nonnum TypeCSChar{} = CSChar 0+    nonnum TypeCUChar{} = CUChar 0+++-- Coercions+-- ---------++evalCoerce :: forall a b. (Elt a, Elt b) => a -> b+evalCoerce = toElt . go (eltType (undefined::a)) (eltType (undefined::b)) . fromElt+  where+    go :: TupleType s -> TupleType t -> s -> t+    go TypeRunit        TypeRunit          ()    = ()+    go (TypeRscalar s)   (TypeRscalar t)   x     = evalCoerceScalar s t x+    go (TypeRpair s1 s2) (TypeRpair t1 t2) (x,y) = (go s1 t1 x, go s2 t2 y)+    --+    -- newtype wrappers are typically declared similarly to `EltRepr (T a) = ((), EltRepr a)'+    --+    go (TypeRpair TypeRunit s) t@TypeRscalar{}         ((), x) = go s t x+    go s@TypeRscalar{}         (TypeRpair TypeRunit t) x       = ((), go s t x)+    --+    go _ _ _+      = error $ printf "could not coerce type `%s' to `%s'"+                  (show (typeOf (undefined::a)))+                  (show (typeOf (undefined::b)))+++-- Coerce a value by writing that data into memory and reading it back at+-- a different type. This seems the most robust way to do it in the presence of+-- packed vector types (which Haskell does not represent in the same way as+-- C due to alignment of the fields, even at specialised UNPACKed types).+--+evalCoerceScalar :: ScalarType a -> ScalarType b -> a -> b+evalCoerceScalar ta tb a+  = $internalCheck "evalCoerce" "sizes not equal" (sizeOf (TypeRscalar ta) == sizeOf (TypeRscalar tb))+  $ withDict (scalar ta)+  $ withDict (scalar tb)+  $ let (adata, _)  = runArrayData $ do+                        arr <- newArrayData 1+                        unsafeWriteArrayData arr 0 a+                        return (arr, undefined)+        adata'      = fromUA arrayElt (toUA arrayElt adata)+    in+    unsafeIndexArrayData adata' 0+  where++    toUA :: ArrayEltR e -> ArrayData e -> UniqueArray ()+    toUA ArrayEltRint       (AD_Int ua)     = castUniqueArray ua+    toUA ArrayEltRint8      (AD_Int8 ua)    = castUniqueArray ua+    toUA ArrayEltRint16     (AD_Int16 ua)   = castUniqueArray ua+    toUA ArrayEltRint32     (AD_Int32 ua)   = castUniqueArray ua+    toUA ArrayEltRint64     (AD_Int64 ua)   = castUniqueArray ua+    toUA ArrayEltRword      (AD_Word ua)    = castUniqueArray ua+    toUA ArrayEltRword8     (AD_Word8 ua)   = castUniqueArray ua+    toUA ArrayEltRword16    (AD_Word16 ua)  = castUniqueArray ua+    toUA ArrayEltRword32    (AD_Word32 ua)  = castUniqueArray ua+    toUA ArrayEltRword64    (AD_Word64 ua)  = castUniqueArray ua+    toUA ArrayEltRcshort    (AD_CShort ua)  = castUniqueArray ua+    toUA ArrayEltRcushort   (AD_CUShort ua) = castUniqueArray ua+    toUA ArrayEltRcint      (AD_CInt ua)    = castUniqueArray ua+    toUA ArrayEltRcuint     (AD_CUInt ua)   = castUniqueArray ua+    toUA ArrayEltRclong     (AD_CLong ua)   = castUniqueArray ua+    toUA ArrayEltRculong    (AD_CULong ua)  = castUniqueArray ua+    toUA ArrayEltRcllong    (AD_CLLong ua)  = castUniqueArray ua+    toUA ArrayEltRcullong   (AD_CULLong ua) = castUniqueArray ua+    toUA ArrayEltRhalf      (AD_Half ua)    = castUniqueArray ua+    toUA ArrayEltRfloat     (AD_Float ua)   = castUniqueArray ua+    toUA ArrayEltRdouble    (AD_Double ua)  = castUniqueArray ua+    toUA ArrayEltRcfloat    (AD_CFloat ua)  = castUniqueArray ua+    toUA ArrayEltRcdouble   (AD_CDouble ua) = castUniqueArray ua+    toUA ArrayEltRbool      (AD_Bool ua)    = castUniqueArray ua+    toUA ArrayEltRchar      (AD_Char ua)    = castUniqueArray ua+    toUA ArrayEltRcchar     (AD_CChar ua)   = castUniqueArray ua+    toUA ArrayEltRcschar    (AD_CSChar ua)  = castUniqueArray ua+    toUA ArrayEltRcuchar    (AD_CUChar ua)  = castUniqueArray ua+    toUA (ArrayEltRvec2 r)  (AD_V2 a)       = toUA r a+    toUA (ArrayEltRvec3 r)  (AD_V3 a)       = toUA r a+    toUA (ArrayEltRvec4 r)  (AD_V4 a)       = toUA r a+    toUA (ArrayEltRvec8 r)  (AD_V8 a)       = toUA r a+    toUA (ArrayEltRvec16 r) (AD_V16 a)      = toUA r a+    --+    toUA ArrayEltRunit      _               = error "What sane person could live in this world and not be crazy?"+    toUA ArrayEltRpair{}    _               = error "  --- Ursula K. Le Guin"++    fromUA :: ArrayEltR e -> UniqueArray () -> ArrayData e+    fromUA ArrayEltRint       = AD_Int     . castUniqueArray+    fromUA ArrayEltRint8      = AD_Int8    . castUniqueArray+    fromUA ArrayEltRint16     = AD_Int16   . castUniqueArray+    fromUA ArrayEltRint32     = AD_Int32   . castUniqueArray+    fromUA ArrayEltRint64     = AD_Int64   . castUniqueArray+    fromUA ArrayEltRword      = AD_Word    . castUniqueArray+    fromUA ArrayEltRword8     = AD_Word8   . castUniqueArray+    fromUA ArrayEltRword16    = AD_Word16  . castUniqueArray+    fromUA ArrayEltRword32    = AD_Word32  . castUniqueArray+    fromUA ArrayEltRword64    = AD_Word64  . castUniqueArray+    fromUA ArrayEltRcshort    = AD_CShort  . castUniqueArray+    fromUA ArrayEltRcushort   = AD_CUShort . castUniqueArray+    fromUA ArrayEltRcint      = AD_CInt    . castUniqueArray+    fromUA ArrayEltRcuint     = AD_CUInt   . castUniqueArray+    fromUA ArrayEltRclong     = AD_CLong   . castUniqueArray+    fromUA ArrayEltRculong    = AD_CULong  . castUniqueArray+    fromUA ArrayEltRcllong    = AD_CLLong  . castUniqueArray+    fromUA ArrayEltRcullong   = AD_CULLong . castUniqueArray+    fromUA ArrayEltRhalf      = AD_Half    . castUniqueArray+    fromUA ArrayEltRfloat     = AD_Float   . castUniqueArray+    fromUA ArrayEltRdouble    = AD_Double  . castUniqueArray+    fromUA ArrayEltRcfloat    = AD_CFloat  . castUniqueArray+    fromUA ArrayEltRcdouble   = AD_CDouble . castUniqueArray+    fromUA ArrayEltRbool      = AD_Bool    . castUniqueArray+    fromUA ArrayEltRchar      = AD_Char    . castUniqueArray+    fromUA ArrayEltRcchar     = AD_CChar   . castUniqueArray+    fromUA ArrayEltRcschar    = AD_CSChar  . castUniqueArray+    fromUA ArrayEltRcuchar    = AD_CUChar  . castUniqueArray+    fromUA (ArrayEltRvec2 r)  = AD_V2      . fromUA r+    fromUA (ArrayEltRvec3 r)  = AD_V3      . fromUA r+    fromUA (ArrayEltRvec4 r)  = AD_V4      . fromUA r+    fromUA (ArrayEltRvec8 r)  = AD_V8      . fromUA r+    fromUA (ArrayEltRvec16 r) = AD_V16     . fromUA r+    --+    fromUA ArrayEltRunit      = error "I talk about the gods, I am an atheist. But I am an artist too, and therefore a liar. Distrust everything I say. I am telling the truth."+    fromUA ArrayEltRpair{}    = error "  --- Ursula K. Le Guin, The Left Hand of Darkness"++    castUniqueArray :: UniqueArray x -> UniqueArray y+    castUniqueArray (UniqueArray uid (Lifetime r w p)) =+      UniqueArray uid (Lifetime r w (castForeignPtr p))++    scalar :: ScalarType e -> Dict (ArrayElt e)+    scalar (SingleScalarType t) = single t+    scalar (VectorScalarType t) = vector t++    single :: SingleType e -> Dict (ArrayElt e)+    single (NumSingleType t)    = num t+    single (NonNumSingleType t) = nonnum t++    vector :: VectorType e -> Dict (ArrayElt e)+    vector (Vector2Type t)  = withDict (single t) Dict+    vector (Vector3Type t)  = withDict (single t) Dict+    vector (Vector4Type t)  = withDict (single t) Dict+    vector (Vector8Type t)  = withDict (single t) Dict+    vector (Vector16Type t) = withDict (single t) Dict++    num :: NumType e -> Dict (ArrayElt e)+    num (IntegralNumType t) = integral t+    num (FloatingNumType t) = floating t++    integral :: IntegralType e -> Dict (ArrayElt e)+    integral TypeInt{}     = Dict+    integral TypeInt8{}    = Dict+    integral TypeInt16{}   = Dict+    integral TypeInt32{}   = Dict+    integral TypeInt64{}   = Dict+    integral TypeWord{}    = Dict+    integral TypeWord8{}   = Dict+    integral TypeWord16{}  = Dict+    integral TypeWord32{}  = Dict+    integral TypeWord64{}  = Dict+    integral TypeCShort{}  = Dict+    integral TypeCUShort{} = Dict+    integral TypeCInt{}    = Dict+    integral TypeCUInt{}   = Dict+    integral TypeCLong{}   = Dict+    integral TypeCULong{}  = Dict+    integral TypeCLLong{}  = Dict+    integral TypeCULLong{} = Dict++    floating :: FloatingType e -> Dict (ArrayElt e)+    floating TypeHalf{}    = Dict+    floating TypeFloat{}   = Dict+    floating TypeDouble{}  = Dict+    floating TypeCFloat{}  = Dict+    floating TypeCDouble{} = Dict++    nonnum :: NonNumType e -> Dict (ArrayElt e)+    nonnum TypeBool{}   = Dict+    nonnum TypeChar{}   = Dict+    nonnum TypeCChar{}  = Dict+    nonnum TypeCSChar{} = Dict+    nonnum TypeCUChar{} = Dict+++-- Scalar primitives+-- -----------------++evalPrimConst :: PrimConst a -> a+evalPrimConst (PrimMinBound ty) = evalMinBound ty+evalPrimConst (PrimMaxBound ty) = evalMaxBound ty+evalPrimConst (PrimPi       ty) = evalPi ty++evalPrim :: (Elt a, Elt r) => PrimFun (a -> r) -> (a -> r)+evalPrim (PrimAdd                ty) = evalAdd ty+evalPrim (PrimSub                ty) = evalSub ty+evalPrim (PrimMul                ty) = evalMul ty+evalPrim (PrimNeg                ty) = evalNeg ty+evalPrim (PrimAbs                ty) = evalAbs ty+evalPrim (PrimSig                ty) = evalSig ty+evalPrim (PrimQuot               ty) = evalQuot ty+evalPrim (PrimRem                ty) = evalRem ty+evalPrim (PrimQuotRem            ty) = evalQuotRem ty+evalPrim (PrimIDiv               ty) = evalIDiv ty+evalPrim (PrimMod                ty) = evalMod ty+evalPrim (PrimDivMod             ty) = evalDivMod ty+evalPrim (PrimBAnd               ty) = evalBAnd ty+evalPrim (PrimBOr                ty) = evalBOr ty+evalPrim (PrimBXor               ty) = evalBXor ty+evalPrim (PrimBNot               ty) = evalBNot ty+evalPrim (PrimBShiftL            ty) = evalBShiftL ty+evalPrim (PrimBShiftR            ty) = evalBShiftR ty+evalPrim (PrimBRotateL           ty) = evalBRotateL ty+evalPrim (PrimBRotateR           ty) = evalBRotateR ty+evalPrim (PrimPopCount           ty) = evalPopCount ty+evalPrim (PrimCountLeadingZeros  ty) = evalCountLeadingZeros ty+evalPrim (PrimCountTrailingZeros ty) = evalCountTrailingZeros ty+evalPrim (PrimFDiv               ty) = evalFDiv ty+evalPrim (PrimRecip              ty) = evalRecip ty+evalPrim (PrimSin                ty) = evalSin ty+evalPrim (PrimCos                ty) = evalCos ty+evalPrim (PrimTan                ty) = evalTan ty+evalPrim (PrimAsin               ty) = evalAsin ty+evalPrim (PrimAcos               ty) = evalAcos ty+evalPrim (PrimAtan               ty) = evalAtan ty+evalPrim (PrimSinh               ty) = evalSinh ty+evalPrim (PrimCosh               ty) = evalCosh ty+evalPrim (PrimTanh               ty) = evalTanh ty+evalPrim (PrimAsinh              ty) = evalAsinh ty+evalPrim (PrimAcosh              ty) = evalAcosh ty+evalPrim (PrimAtanh              ty) = evalAtanh ty+evalPrim (PrimExpFloating        ty) = evalExpFloating ty+evalPrim (PrimSqrt               ty) = evalSqrt ty+evalPrim (PrimLog                ty) = evalLog ty+evalPrim (PrimFPow               ty) = evalFPow ty+evalPrim (PrimLogBase            ty) = evalLogBase ty+evalPrim (PrimTruncate        ta tb) = evalTruncate ta tb+evalPrim (PrimRound           ta tb) = evalRound ta tb+evalPrim (PrimFloor           ta tb) = evalFloor ta tb+evalPrim (PrimCeiling         ta tb) = evalCeiling ta tb+evalPrim (PrimAtan2              ty) = evalAtan2 ty+evalPrim (PrimIsNaN              ty) = evalIsNaN ty+evalPrim (PrimIsInfinite         ty) = evalIsInfinite ty+evalPrim (PrimLt                 ty) = evalLt ty+evalPrim (PrimGt                 ty) = evalGt ty+evalPrim (PrimLtEq               ty) = evalLtEq ty+evalPrim (PrimGtEq               ty) = evalGtEq ty+evalPrim (PrimEq                 ty) = evalEq ty+evalPrim (PrimNEq                ty) = evalNEq ty+evalPrim (PrimMax                ty) = evalMax ty+evalPrim (PrimMin                ty) = evalMin ty+evalPrim PrimLAnd                    = evalLAnd+evalPrim PrimLOr                     = evalLOr+evalPrim PrimLNot                    = evalLNot+evalPrim PrimOrd                     = evalOrd+evalPrim PrimChr                     = evalChr+evalPrim PrimBoolToInt               = evalBoolToInt+evalPrim (PrimFromIntegral ta tb)    = evalFromIntegral ta tb+evalPrim (PrimToFloating ta tb)      = evalToFloating ta tb+++-- Tuple construction and projection+-- ---------------------------------++evalTuple :: EvalAcc acc -> Tuple (PreOpenExp acc env aenv) t -> ValElt env -> Val aenv -> t+evalTuple _       NilTup            _env _aenv = ()+evalTuple evalAcc (tup `SnocTup` e) env  aenv  =+  (evalTuple evalAcc tup env aenv, evalPreOpenExp evalAcc e env aenv)++evalPrj :: TupleIdx t e -> t -> e+evalPrj ZeroTupIdx       (!_, v)   = v+evalPrj (SuccTupIdx idx) (tup, !_) = evalPrj idx tup+  -- FIXME: Strictly speaking, we ought to force all components of a tuples;+  --        not only those that we happen to encounter during the recursive+  --        walk.+++-- Implementation of scalar primitives+-- -----------------------------------++evalLAnd :: (Bool, Bool) -> Bool+evalLAnd (x, y) = x && y++evalLOr  :: (Bool, Bool) -> Bool+evalLOr (x, y) = x || y++evalLNot :: Bool -> Bool+evalLNot = not++evalOrd :: Char -> Int+evalOrd = ord++evalChr :: Int -> Char+evalChr = chr++evalBoolToInt :: Bool -> Int+evalBoolToInt True  = 1+evalBoolToInt False = 0++evalFromIntegral :: IntegralType a -> NumType b -> a -> b+evalFromIntegral ta (IntegralNumType tb)+  | IntegralDict <- integralDict ta+  , IntegralDict <- integralDict tb+  = fromIntegral++evalFromIntegral ta (FloatingNumType tb)+  | IntegralDict <- integralDict ta+  , FloatingDict <- floatingDict tb+  = fromIntegral++evalToFloating :: NumType a -> FloatingType b -> a -> b+evalToFloating (IntegralNumType ta) tb+  | IntegralDict <- integralDict ta+  , FloatingDict <- floatingDict tb+  = realToFrac++evalToFloating (FloatingNumType ta) tb+  | FloatingDict <- floatingDict ta+  , FloatingDict <- floatingDict tb+  = realToFrac+++-- Extract methods from reified dictionaries+--++-- Constant methods of Bounded+--++evalMinBound :: BoundedType a -> a+evalMinBound (IntegralBoundedType ty)+  | IntegralDict <- integralDict ty+  = minBound++evalMinBound (NonNumBoundedType   ty)+  | NonNumDict   <- nonNumDict ty+  = minBound++evalMaxBound :: BoundedType a -> a+evalMaxBound (IntegralBoundedType ty)+  | IntegralDict <- integralDict ty+  = maxBound++evalMaxBound (NonNumBoundedType   ty)+  | NonNumDict   <- nonNumDict ty+  = maxBound++-- Constant method of floating+--++evalPi :: FloatingType a -> a+evalPi ty | FloatingDict <- floatingDict ty = pi++evalSin :: FloatingType a -> (a -> a)+evalSin ty | FloatingDict <- floatingDict ty = sin++evalCos :: FloatingType a -> (a -> a)+evalCos ty | FloatingDict <- floatingDict ty = cos++evalTan :: FloatingType a -> (a -> a)+evalTan ty | FloatingDict <- floatingDict ty = tan++evalAsin :: FloatingType a -> (a -> a)+evalAsin ty | FloatingDict <- floatingDict ty = asin++evalAcos :: FloatingType a -> (a -> a)+evalAcos ty | FloatingDict <- floatingDict ty = acos++evalAtan :: FloatingType a -> (a -> a)+evalAtan ty | FloatingDict <- floatingDict ty = atan++evalSinh :: FloatingType a -> (a -> a)+evalSinh ty | FloatingDict <- floatingDict ty = sinh++evalCosh :: FloatingType a -> (a -> a)+evalCosh ty | FloatingDict <- floatingDict ty = cosh++evalTanh :: FloatingType a -> (a -> a)+evalTanh ty | FloatingDict <- floatingDict ty = tanh++evalAsinh :: FloatingType a -> (a -> a)+evalAsinh ty | FloatingDict <- floatingDict ty = asinh++evalAcosh :: FloatingType a -> (a -> a)+evalAcosh ty | FloatingDict <- floatingDict ty = acosh++evalAtanh :: FloatingType a -> (a -> a)+evalAtanh ty | FloatingDict <- floatingDict ty = atanh++evalExpFloating :: FloatingType a -> (a -> a)+evalExpFloating ty | FloatingDict <- floatingDict ty = exp++evalSqrt :: FloatingType a -> (a -> a)+evalSqrt ty | FloatingDict <- floatingDict ty = sqrt++evalLog :: FloatingType a -> (a -> a)+evalLog ty | FloatingDict <- floatingDict ty = log++evalFPow :: FloatingType a -> ((a, a) -> a)+evalFPow ty | FloatingDict <- floatingDict ty = uncurry (**)++evalLogBase :: FloatingType a -> ((a, a) -> a)+evalLogBase ty | FloatingDict <- floatingDict ty = uncurry logBase++evalTruncate :: FloatingType a -> IntegralType b -> (a -> b)+evalTruncate ta tb+  | FloatingDict <- floatingDict ta+  , IntegralDict <- integralDict tb+  = truncate++evalRound :: FloatingType a -> IntegralType b -> (a -> b)+evalRound ta tb+  | FloatingDict <- floatingDict ta+  , IntegralDict <- integralDict tb+  = round++evalFloor :: FloatingType a -> IntegralType b -> (a -> b)+evalFloor ta tb+  | FloatingDict <- floatingDict ta+  , IntegralDict <- integralDict tb+  = floor++evalCeiling :: FloatingType a -> IntegralType b -> (a -> b)+evalCeiling ta tb+  | FloatingDict <- floatingDict ta+  , IntegralDict <- integralDict tb+  = ceiling++evalAtan2 :: FloatingType a -> ((a, a) -> a)+evalAtan2 ty | FloatingDict <- floatingDict ty = uncurry atan2++evalIsNaN :: FloatingType a -> (a -> Bool)+evalIsNaN ty | FloatingDict <- floatingDict ty = isNaN++evalIsInfinite :: FloatingType a -> (a -> Bool)+evalIsInfinite ty | FloatingDict <- floatingDict ty = isInfinite+++-- Methods of Num+--++evalAdd :: NumType a -> ((a, a) -> a)+evalAdd (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (+)+evalAdd (FloatingNumType ty) | FloatingDict <- floatingDict ty = uncurry (+)++evalSub :: NumType a -> ((a, a) -> a)+evalSub (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (-)+evalSub (FloatingNumType ty) | FloatingDict <- floatingDict ty = uncurry (-)++evalMul :: NumType a -> ((a, a) -> a)+evalMul (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (*)+evalMul (FloatingNumType ty) | FloatingDict <- floatingDict ty = uncurry (*)++evalNeg :: NumType a -> (a -> a)+evalNeg (IntegralNumType ty) | IntegralDict <- integralDict ty = negate+evalNeg (FloatingNumType ty) | FloatingDict <- floatingDict ty = negate++evalAbs :: NumType a -> (a -> a)+evalAbs (IntegralNumType ty) | IntegralDict <- integralDict ty = abs+evalAbs (FloatingNumType ty) | FloatingDict <- floatingDict ty = abs++evalSig :: NumType a -> (a -> a)+evalSig (IntegralNumType ty) | IntegralDict <- integralDict ty = signum+evalSig (FloatingNumType ty) | FloatingDict <- floatingDict ty = signum++evalQuot :: IntegralType a -> ((a, a) -> a)+evalQuot ty | IntegralDict <- integralDict ty = uncurry quot++evalRem :: IntegralType a -> ((a, a) -> a)+evalRem ty | IntegralDict <- integralDict ty = uncurry rem++evalQuotRem :: IntegralType a -> ((a, a) -> (a, a))+evalQuotRem ty | IntegralDict <- integralDict ty = uncurry quotRem++evalIDiv :: IntegralType a -> ((a, a) -> a)+evalIDiv ty | IntegralDict <- integralDict ty = uncurry div++evalMod :: IntegralType a -> ((a, a) -> a)+evalMod ty | IntegralDict <- integralDict ty = uncurry mod++evalDivMod :: IntegralType a -> ((a, a) -> (a, a))+evalDivMod ty | IntegralDict <- integralDict ty = uncurry divMod++evalBAnd :: IntegralType a -> ((a, a) -> a)+evalBAnd ty | IntegralDict <- integralDict ty = uncurry (.&.)++evalBOr :: IntegralType a -> ((a, a) -> a)+evalBOr ty | IntegralDict <- integralDict ty = uncurry (.|.)++evalBXor :: IntegralType a -> ((a, a) -> a)+evalBXor ty | IntegralDict <- integralDict ty = uncurry xor++evalBNot :: IntegralType a -> (a -> a)+evalBNot ty | IntegralDict <- integralDict ty = complement++evalBShiftL :: IntegralType a -> ((a, Int) -> a)+evalBShiftL ty | IntegralDict <- integralDict ty = uncurry shiftL++evalBShiftR :: IntegralType a -> ((a, Int) -> a)+evalBShiftR ty | IntegralDict <- integralDict ty = uncurry shiftR++evalBRotateL :: IntegralType a -> ((a, Int) -> a)+evalBRotateL ty | IntegralDict <- integralDict ty = uncurry rotateL++evalBRotateR :: IntegralType a -> ((a, Int) -> a)+evalBRotateR ty | IntegralDict <- integralDict ty = uncurry rotateR++evalPopCount :: IntegralType a -> (a -> Int)+evalPopCount ty | IntegralDict <- integralDict ty = popCount++evalCountLeadingZeros :: IntegralType a -> (a -> Int)+#if __GLASGOW_HASKELL__ >= 710+evalCountLeadingZeros ty | IntegralDict <- integralDict ty = countLeadingZeros+#else+evalCountLeadingZeros ty | IntegralDict <- integralDict ty = clz+  where+    clz x = (w-1) - go (w-1)+      where+        go i | i < 0       = i  -- no bit set+             | testBit x i = i+             | otherwise   = go (i-1)+        w = finiteBitSize x+#endif++evalCountTrailingZeros :: IntegralType a -> (a -> Int)+#if __GLASGOW_HASKELL__ >= 710+evalCountTrailingZeros ty | IntegralDict <- integralDict ty = countTrailingZeros+#else+evalCountTrailingZeros ty | IntegralDict <- integralDict ty = ctz+  where+    ctz x = go 0+      where+        go i | i >= w      = i+             | testBit x i = i+             | otherwise   = go (i+1)+        w = finiteBitSize x+#endif+++evalFDiv :: FloatingType a -> ((a, a) -> a)+evalFDiv ty | FloatingDict <- floatingDict ty = uncurry (/)++evalRecip :: FloatingType a -> (a -> a)+evalRecip ty | FloatingDict <- floatingDict ty = recip+++evalLt :: SingleType a -> ((a, a) -> Bool)+evalLt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (<)+evalLt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (<)+evalLt (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (<)++evalGt :: SingleType a -> ((a, a) -> Bool)+evalGt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (>)+evalGt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (>)+evalGt (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (>)++evalLtEq :: SingleType a -> ((a, a) -> Bool)+evalLtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (<=)+evalLtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (<=)+evalLtEq (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (<=)++evalGtEq :: SingleType a -> ((a, a) -> Bool)+evalGtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (>=)+evalGtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (>=)+evalGtEq (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (>=)++evalEq :: SingleType a -> ((a, a) -> Bool)+evalEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (==)+evalEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (==)+evalEq (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (==)++evalNEq :: SingleType a -> ((a, a) -> Bool)+evalNEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry (/=)+evalNEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry (/=)+evalNEq (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = uncurry (/=)++evalMax :: SingleType a -> ((a, a) -> a)+evalMax (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry max+evalMax (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry max+evalMax (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = uncurry max++evalMin :: SingleType a -> ((a, a) -> a)+evalMin (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry min+evalMin (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = uncurry min+evalMin (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = uncurry min+++{--+-- Sequence evaluation+-- ---------------++-- Position in sequence.+--+type SeqPos = Int++-- Configuration for sequence evaluation.+--+data SeqConfig = SeqConfig+  { chunkSize :: Int -- Allocation limit for a sequence in+                     -- words. Actual runtime allocation should be the+                     -- maximum of this size and the size of the+                     -- largest element in the sequence.+  }++-- Default sequence evaluation configuration for testing purposes.+--+defaultSeqConfig :: SeqConfig+defaultSeqConfig = SeqConfig { chunkSize = 2 }++type Chunk a = Vector' a++-- The empty chunk. O(1).+emptyChunk :: Arrays a => Chunk a+emptyChunk = empty'++-- Number of arrays in chunk. O(1).+--+clen :: Arrays a => Chunk a -> Int+clen = length'++elemsPerChunk :: SeqConfig -> Int -> Int+elemsPerChunk conf n+  | n < 1 = chunkSize conf+  | otherwise =+    let (a,b) = chunkSize conf `quotRem` n+    in a + signum b++-- Drop a number of arrays from a chunk. O(1). Note: Require keeping a+-- scan of element sizes.+--+cdrop :: Arrays a => Int -> Chunk a -> Chunk a+cdrop = drop' dropOp (fst . offsetsOp)++-- Get all the shapes of a chunk of arrays. O(1).+--+chunkShapes :: Chunk (Array sh a) -> Vector sh+chunkShapes = shapes'++-- Get all the elements of a chunk of arrays. O(1).+--+chunkElems :: Chunk (Array sh a) -> Vector a+chunkElems = elements'++-- Convert a vector to a chunk of scalars.+--+vec2Chunk :: Elt e => Vector e -> Chunk (Scalar e)+vec2Chunk = vec2Vec'++-- Convert a list of arrays to a chunk.+--+fromListChunk :: Arrays a => [a] -> Vector' a+fromListChunk = fromList' concatOp++-- Convert a chunk to a list of arrays.+--+toListChunk :: Arrays a => Vector' a -> [a]+toListChunk = toList' fetchAllOp++-- fmap for Chunk. O(n).+--   TODO: Use vectorised function.+mapChunk :: (Arrays a, Arrays b)+         => (a -> b)+         -> Chunk a -> Chunk b+mapChunk f c = fromListChunk $ map f (toListChunk c)++-- zipWith for Chunk. O(n).+--  TODO: Use vectorised function.+zipWithChunk :: (Arrays a, Arrays b, Arrays c)+             => (a -> b -> c)+             -> Chunk a -> Chunk b -> Chunk c+zipWithChunk f c1 c2 = fromListChunk $ zipWith f (toListChunk c1) (toListChunk c2)++-- A window on a sequence.+--+data Window a = Window+  { chunk :: Chunk a   -- Current allocated chunk.+  , wpos  :: SeqPos    -- Position of the window on the sequence, given+                       -- in number of elements.+  }++-- The initial empty window.+--+window0 :: Arrays a => Window a+window0 = Window { chunk = emptyChunk, wpos = 0 }++-- Index the given window by the given index on the sequence.+--+(!#) :: Arrays a => Window a -> SeqPos -> Chunk a+w !# i+  | j <- i - wpos w+  , j >= 0+  = cdrop j (chunk w)+  --+  | otherwise+  = error $ "Window indexed before position. wpos = " ++ show (wpos w) ++ " i = " ++ show i++-- Move the give window by supplying the next chunk.+--+moveWin :: Arrays a => Window a -> Chunk a -> Window a+moveWin w c = w { chunk = c+                , wpos = wpos w + clen (chunk w)+                }++-- A cursor on a sequence.+--+data Cursor senv a = Cursor+  { ref  :: Idx senv a -- Reference to the sequence.+  , cpos :: SeqPos     -- Position of the cursor on the sequence,+                       -- given in number of elements.+  }++-- Initial cursor.+--+cursor0 :: Idx senv a -> Cursor senv a+cursor0 x = Cursor { ref = x, cpos = 0 }++-- Advance cursor by a relative amount.+--+moveCursor :: Int -> Cursor senv a -> Cursor senv a+moveCursor k c = c { cpos = cpos c + k }++-- Valuation for an environment of sequence windows.+--+data Val' senv where+  Empty' :: Val' ()+  Push'  :: Val' senv -> Window t -> Val' (senv, t)++-- Projection of a window from a window valuation using a de Bruijn+-- index.+--+prj' :: Idx senv t -> Val' senv -> Window 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 chunk from a window valuation using a sequence+-- cursor.+--+prjChunk :: Arrays a => Cursor senv a -> Val' senv -> Chunk a+prjChunk c senv = prj' (ref c) senv !# cpos c++-- An executable sequence.+--+data ExecSeq senv arrs where+  ExecP :: Arrays a => Window a -> ExecP senv a -> ExecSeq (senv, a) arrs -> ExecSeq senv  arrs+  ExecC :: Arrays a =>             ExecC senv a ->                           ExecSeq senv  a+  ExecR :: Arrays a =>             Cursor senv a ->                          ExecSeq senv  [a]++-- An executable producer.+--+data ExecP senv a where+  ExecStreamIn :: Int+               -> [a]+               -> ExecP senv a++  ExecMap :: Arrays a+          => (Chunk a -> Chunk b)+          -> Cursor senv a+          -> ExecP senv b++  ExecZipWith :: (Arrays a, Arrays b)+              => (Chunk a -> Chunk b -> Chunk c)+              -> Cursor senv a+              -> Cursor senv b+              -> ExecP senv c++  -- Stream scan skeleton.+  ExecScan :: Arrays a+           => (s -> Chunk a -> (Chunk r, s)) -- Chunk scanner.+           -> s                              -- Accumulator (internal state).+           -> Cursor senv a                  -- Input stream.+           -> ExecP senv r++-- An executable consumer.+--+data ExecC senv a where++  -- Stream reduction skeleton.+  ExecFold :: Arrays a+           => (s -> Chunk a -> s) -- Chunk consumer function.+           -> (s -> r)            -- Finalizer function.+           -> s                   -- Accumulator (internal state).+           -> Cursor senv a       -- Input stream.+           -> ExecC senv r++  ExecStuple :: IsAtuple a+             => Atuple (ExecC senv) (TupleRepr a)+             -> ExecC senv a++minCursor :: ExecSeq senv a -> SeqPos+minCursor s = travS s 0+  where+    travS :: ExecSeq senv a -> Int -> SeqPos+    travS s i =+      case s of+        ExecP _ p s' -> travP p i `min` travS s' (i+1)+        ExecC   c    -> travC c i+        ExecR   _    -> maxBound++    k :: Cursor senv a -> Int -> SeqPos+    k c i+      | i == idxToInt (ref c) = cpos c+      | otherwise             = maxBound++    travP :: ExecP senv a -> Int -> SeqPos+    travP p i =+      case p of+        ExecStreamIn _ _ -> maxBound+        ExecMap _ c -> k c i+        ExecZipWith _ c1 c2 -> k c1 i `min` k c2 i+        ExecScan _ _ c -> k c i++    travT :: Atuple (ExecC senv) t -> Int -> SeqPos+    travT NilAtup        _ = maxBound+    travT (SnocAtup t c) i = travT t i `min` travC c i++    travC :: ExecC senv a -> Int -> SeqPos+    travC c i =+      case c of+        ExecFold _ _ _ cu -> k cu i+        ExecStuple t      -> travT t i+++evalDelayedSeq+    :: SeqConfig+    -> DelayedSeq arrs+    -> arrs+evalDelayedSeq cfg (DelayedSeq aenv s) | aenv' <- evalExtend aenv Empty+                                       = evalSeq cfg s aenv'++evalSeq :: forall aenv arrs.+            SeqConfig+         -> PreOpenSeq DelayedOpenAcc aenv () arrs+         -> Val aenv -> arrs+evalSeq conf s aenv = evalSeq' s+  where+    evalSeq' :: PreOpenSeq DelayedOpenAcc aenv senv arrs -> arrs+    evalSeq' (Producer _ s) = evalSeq' s+    evalSeq' (Consumer _)   = loop (initSeq aenv s)+    evalSeq' (Reify _)      = reify (initSeq aenv s)++    -- Initialize the producers and the accumulators of the consumers+    -- with the given array enviroment.+    initSeq :: forall senv arrs'.+                Val aenv+             -> PreOpenSeq DelayedOpenAcc aenv senv arrs'+             -> ExecSeq senv arrs'+    initSeq aenv s =+      case s of+        Producer   p s' -> ExecP window0 (initProducer p) (initSeq aenv s')+        Consumer   c    -> ExecC         (initConsumer c)+        Reify      ix   -> ExecR (cursor0 ix)++    -- Generate a list from the sequence.+    reify :: forall arrs. ExecSeq () [arrs]+          -> [arrs]+    reify s = case step s Empty' of+                (Just s', a) -> a ++ reify s'+                (Nothing, a) -> a++    -- Iterate the given sequence until it terminates.+    -- A sequence only terminates when one of the producers are exhausted.+    loop :: Arrays arrs+         => ExecSeq () arrs+         -> arrs+    loop s =+      case step' s of+        (Nothing, arrs) -> arrs+        (Just s', _)    -> loop s'++      where+        step' :: ExecSeq () arrs -> (Maybe (ExecSeq () arrs), arrs)+        step' s = step s Empty'++    -- One iteration of a sequence.+    step :: forall senv arrs'.+            ExecSeq senv arrs'+         -> Val' senv+         -> (Maybe (ExecSeq senv arrs'), arrs')+    step s senv =+      case s of+        ExecP w p s' ->+          let (c, mp')  = produce p senv+              finished  = 0 == clen (w !# minCursor s')+              w'        = if finished then moveWin w c else w+              (ms'', a) = step s' (senv `Push'` w')+          in case ms'' of+            Nothing  -> (Nothing, a)+            Just s'' | finished+                     , Just p' <- mp'+                     -> (Just (ExecP w' p' s''), a)+                     | not finished+                     -> (Just (ExecP w' p  s''), a)+                     | otherwise+                     -> (Nothing, a)+        ExecC   c    -> let (c', acc) = consume c senv+                        in (Just (ExecC c'), acc)+        ExecR ix     -> let c = prjChunk ix senv in (Just (ExecR (moveCursor (clen c) ix)), toListChunk c)++    evalA :: DelayedOpenAcc aenv a -> a+    evalA acc = evalOpenAcc acc aenv++    evalAF :: DelayedOpenAfun aenv f -> f+    evalAF f = evalOpenAfun f aenv++    evalE :: DelayedExp aenv t -> t+    evalE exp = evalPreExp evalOpenAcc exp aenv++    evalF :: DelayedFun aenv f -> f+    evalF fun = evalPreFun evalOpenAcc fun aenv++    initProducer :: forall a senv.+                    Producer DelayedOpenAcc aenv senv a+                 -> ExecP senv a+    initProducer p =+      case p of+        StreamIn arrs -> ExecStreamIn 1 arrs+        ToSeq sliceIndex slix (delayed -> Delayed sh ix _) ->+          let n   = R.size (R.sliceShape sliceIndex (fromElt sh))+              k   = elemsPerChunk conf n+          in ExecStreamIn k (toSeqOp sliceIndex slix (fromFunction sh ix))+        MapSeq     f x       -> ExecMap     (mapChunk (evalAF f)) (cursor0 x)+        ChunkedMapSeq f x    -> ExecMap     (evalAF f) (cursor0 x)+        ZipWithSeq f x y     -> ExecZipWith (zipWithChunk (evalAF f)) (cursor0 x) (cursor0 y)+        ScanSeq    f e x     -> ExecScan scanner (evalE e) (cursor0 x)+          where+            scanner a c =+              let v0 = chunkElems c+                  (v1, a') = scanl'Op (evalF f) a (delayArray v0)+              in (vec2Chunk v1, fromScalar a')++    initConsumer :: forall a senv.+                    Consumer DelayedOpenAcc aenv senv a+                 -> ExecC senv a+    initConsumer c =+      case c of+        FoldSeq f e x ->+          let f' = evalF f+              a0 = fromFunction (Z :. chunkSize conf) (const (evalE e))+              consumer v c = zipWith'Op f' (delayArray v) (delayArray (chunkElems c))+              finalizer = fold1Op f' . delayArray+          in ExecFold consumer finalizer a0 (cursor0 x)+        FoldSeqFlatten f acc x ->+          let f' = evalAF f+              a0 = evalA acc+              consumer a c = f' a (chunkShapes c) (chunkElems c)+          in ExecFold consumer id a0 (cursor0 x)+        Stuple t ->+          let initTup :: Atuple (Consumer DelayedOpenAcc aenv senv) t -> Atuple (ExecC senv) t+              initTup NilAtup        = NilAtup+              initTup (SnocAtup t c) = SnocAtup (initTup t) (initConsumer c)+          in ExecStuple (initTup t)++    delayed :: DelayedOpenAcc aenv (Array sh e) -> Delayed (Array sh e)+    delayed AST.Manifest{}  = $internalError "evalOpenAcc" "expected delayed array"+    delayed AST.Delayed{..} = Delayed (evalPreExp evalOpenAcc extentD aenv)+                                      (evalPreFun evalOpenAcc indexD aenv)+                                      (evalPreFun evalOpenAcc linearIndexD aenv)++produce :: Arrays a => ExecP senv a -> Val' senv -> (Chunk a, Maybe (ExecP senv a))+produce p senv =+  case p of+    ExecStreamIn k xs ->+      let (xs', xs'') = (take k xs, drop k xs)+          c           = fromListChunk xs'+          mp          = if null xs''+                        then Nothing+                        else Just (ExecStreamIn k xs'')+      in (c, mp)+    ExecMap f x ->+      let c = prjChunk x senv+      in (f c, Just $ ExecMap f (moveCursor (clen c) x))+    ExecZipWith f x y ->+      let c1 = prjChunk x senv+          c2 = prjChunk y senv+          k = clen c1 `min` clen c2+      in (f c1 c2, Just $ ExecZipWith f (moveCursor k x) (moveCursor k y))+    ExecScan scanner a x ->+      let c = prjChunk x senv+          (c', a') = scanner a c+          k = clen c+      in (c', Just $ ExecScan scanner a' (moveCursor k x))++consume :: forall senv a. ExecC senv a -> Val' senv -> (ExecC senv a, a)+consume c senv =+  case c of+    ExecFold f g acc x ->+      let c    = prjChunk x senv+          acc' = f acc c+      -- Even though we call g here, lazy evaluation should guarantee it is+      -- only ever called once.+      in (ExecFold f g acc' (moveCursor (clen c) x), g acc')+    ExecStuple t ->+      let consT :: Atuple (ExecC senv) t -> (Atuple (ExecC senv) t, t)+          consT NilAtup        = (NilAtup, ())+          consT (SnocAtup t c) | (c', acc) <- consume c senv+                               , (t', acc') <- consT t+                               = (SnocAtup t' c', (acc', acc))+          (t', acc) = consT t+      in (ExecStuple t', toAtuple acc)++evalExtend :: Extend DelayedOpenAcc aenv aenv' -> Val aenv -> Val aenv'+evalExtend BaseEnv aenv = aenv+evalExtend (PushEnv ext1 ext2) aenv | aenv' <- evalExtend ext1 aenv+                                    = Push aenv' (evalOpenAcc ext2 aenv')++delayArray :: Array sh e -> Delayed (Array sh e)+delayArray arr@(Array _ adata) = Delayed (shape arr) (arr!) (toElt . unsafeIndexArrayData adata)++fromScalar :: Scalar a -> a+fromScalar = (!Z)++concatOp :: forall e. Elt e => [Vector e] -> Vector e+concatOp = concatVectors++fetchAllOp :: (Shape sh, Elt e) => Segments sh -> Vector e -> [Array sh e]+fetchAllOp segs elts+  | (offsets, n) <- offsetsOp segs+  , (n ! Z) <= size (shape elts)+  = [fetch (segs ! (Z :. i)) (offsets ! (Z :. i)) | i <- [0 .. size (shape segs) - 1]]+  | otherwise = error $ "illegal argument to fetchAllOp"+  where+    fetch sh offset = fromFunction sh (\ ix -> elts ! (Z :. ((toIndex sh ix) + offset)))++dropOp :: Elt e => Int -> Vector e -> Vector e+dropOp i v   -- TODO+             --  * Implement using C-style pointer-plus.+             --    ; dropOp is used often (from prjChunk),+             --      so it ought to be efficient O(1).+  | n <- size (shape v)+  , i <= n+  , i >= 0+  = fromFunction (Z :. n - i) (\ (Z :. j) -> v ! (Z :. i + j))+  | otherwise = error $ "illegal argument to drop"++offsetsOp :: Shape sh => Segments sh -> (Vector Int, Scalar Int)+offsetsOp segs = scanl'Op (+) 0 $ delayArray (mapOp size (delayArray segs))+--}+
+ src/Data/Array/Accelerate/Language.hs view
@@ -0,0 +1,1449 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.Language+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+--               [2014..2014] Frederik M. Madsen+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- We use the dictionary view of overloaded operations (such as arithmetic and+-- bit manipulation) to reify such expressions.  With non-overloaded+-- operations (such as, the logical connectives) and partially overloaded+-- operations (such as comparisons), we use the standard operator names with a+-- \'*\' attached.  We keep the standard alphanumeric names as they can be+-- easily qualified.+--++module Data.Array.Accelerate.Language (++  -- * Array and scalar expressions+  Acc, Exp,                                 -- re-exporting from 'Smart'++  -- * Scalar introduction+  constant,                                 -- re-exporting from 'Smart'++  -- * Array construction+  use, unit, replicate, generate,++  -- * Shape manipulation+  reshape,++  -- * Extraction of sub-arrays+  slice,++  -- * Map-like functions+  map, zipWith,++  -- -- * Sequence collection+  -- collect,++  -- -- * Sequence producers+  -- streamIn, toSeq,++  -- -- * Sequence transducers+  -- mapSeq, zipWithSeq, scanSeq,++  -- -- * Sequence consumers+  -- foldSeq, foldSeqFlatten,++  -- * Reductions+  fold, fold1, foldSeg, fold1Seg,++  -- * Scan functions+  scanl, scanl', scanl1, scanr, scanr', scanr1,++  -- * Permutations+  permute, backpermute,++  -- * Stencil operations+  stencil, stencil2,++  -- ** Stencil specification+  Boundary, Stencil,+  clamp, mirror, wrap, function,+++  -- ** Common stencil types+  Stencil3, Stencil5, Stencil7, Stencil9,+  Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5,+  Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,+  Stencil3x5x5, Stencil5x5x5,++  -- * Foreign functions+  foreignAcc,+  foreignExp,++  -- * Pipelining+  (>->),++  -- * Index construction and destruction+  indexHead, indexTail, toIndex, fromIndex,+  intersect, union,++  -- * Flow-control+  acond, awhile,+  cond,  while,++  -- * Array operations with a scalar result+  (!), (!!), shape, size, shapeSize,++  -- * Numeric functions+  subtract, even, odd, gcd, lcm, (^), (^^),++  -- * Conversions+  ord, chr, boolToInt, bitcast,++  -- * Constants+  ignore++) where++-- friends+import Data.Array.Accelerate.Array.Sugar                            hiding ( (!), (!!), ignore, shape, reshape, size, toIndex, fromIndex, intersect, union )+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type+import qualified Data.Array.Accelerate.Array.Sugar                  as Sugar++import Data.Array.Accelerate.Classes.Eq+import Data.Array.Accelerate.Classes.Fractional+import Data.Array.Accelerate.Classes.Integral+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Ord++-- standard libraries+import Prelude                                                      ( ($), (.) )++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XScopedTypeVariables+-- >>> :seti -XTypeOperators+-- >>> :seti -XViewPatterns+-- >>> import Data.Array.Accelerate+-- >>> import Data.Array.Accelerate.Interpreter+-- >>> :{+--   let runExp :: Elt e => Exp e -> e+--       runExp e = indexArray (run (unit e)) Z+-- :}++-- Array introduction+-- ------------------++-- | Make an array from vanilla Haskell available for processing within embedded+-- Accelerate computations.+--+-- Depending upon which backend is used to eventually execute array+-- computations, 'use' may entail data transfer (e.g. to a GPU).+--+-- 'use' is overloaded so that it can accept tuples of 'Arrays':+--+-- >>> let vec = fromList (Z:.10) [0..] :: Vector Int+-- >>> vec+-- Vector (Z :. 10) [0,1,2,3,4,5,6,7,8,9]+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> let vec' = use vec         :: Acc (Vector Int)+-- >>> let mat' = use mat         :: Acc (Matrix Int)+-- >>> let tup  = use (vec, mat)  :: Acc (Vector Int, Matrix Int)+--+use :: Arrays arrays => arrays -> Acc arrays+use = Acc . Use++-- | Construct a singleton (one element) array from a scalar value (or tuple of+-- scalar values).+--+unit :: Elt e => Exp e -> Acc (Scalar e)+unit = Acc . Unit++-- | Replicate an array across one or more dimensions as specified by the+-- /generalised/ array index provided as the first argument.+--+-- For example, given the following vector:+--+-- >>> let vec = fromList (Z:.10) [0..] :: Vector Int+-- >>> vec+-- Vector (Z :. 10) [0,1,2,3,4,5,6,7,8,9]+--+-- ...we can replicate these elements to form a two-dimensional array either by+-- replicating those elements as new rows:+--+-- >>> run $ replicate (constant (Z :. (4::Int) :. All)) (use vec)+-- Matrix (Z :. 4 :. 10)+--   [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,+--     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,+--     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,+--     0, 1, 2, 3, 4, 5, 6, 7, 8, 9]+--+-- ...or as columns:+--+-- >>> run $ replicate (lift (Z :. All :. (4::Int))) (use vec)+-- Matrix (Z :. 10 :. 4)+--   [ 0, 0, 0, 0,+--     1, 1, 1, 1,+--     2, 2, 2, 2,+--     3, 3, 3, 3,+--     4, 4, 4, 4,+--     5, 5, 5, 5,+--     6, 6, 6, 6,+--     7, 7, 7, 7,+--     8, 8, 8, 8,+--     9, 9, 9, 9]+--+-- Replication along more than one dimension is also possible. Here we replicate+-- twice across the first dimension and three times across the third dimension:+--+-- >>> run $ replicate (constant (Z :. (2::Int) :. All :. (3::Int))) (use vec)+-- Array (Z :. 2 :. 10 :. 3) [0,0,0,1,1,1,2,2,2,3,3,3,4,4,4,5,5,5,6,6,6,7,7,7,8,8,8,9,9,9,0,0,0,1,1,1,2,2,2,3,3,3,4,4,4,5,5,5,6,6,6,7,7,7,8,8,8,9,9,9]+--+-- The marker 'Any' can be used in the slice specification to match against some+-- arbitrary dimension. For example, here 'Any' matches against whatever shape+-- type variable @sh@ takes.+--+-- >>> :{+--   let rep0 :: (Shape sh, Elt e) => Exp Int -> Acc (Array sh e) -> Acc (Array (sh :. Int) e)+--       rep0 n a = replicate (lift (Any :. n)) a+-- :}+--+-- >>> let x = unit 42 :: Acc (Scalar Int)+-- >>> run $ rep0 10 x+-- Vector (Z :. 10) [42,42,42,42,42,42,42,42,42,42]+--+-- >>> run $ rep0 5 (use vec)+-- Matrix (Z :. 10 :. 5)+--   [ 0, 0, 0, 0, 0,+--     1, 1, 1, 1, 1,+--     2, 2, 2, 2, 2,+--     3, 3, 3, 3, 3,+--     4, 4, 4, 4, 4,+--     5, 5, 5, 5, 5,+--     6, 6, 6, 6, 6,+--     7, 7, 7, 7, 7,+--     8, 8, 8, 8, 8,+--     9, 9, 9, 9, 9]+--+-- Of course, 'Any' and 'All' can be used together.+--+-- >>> :{+--   let rep1 :: (Shape sh, Elt e) => Exp Int -> Acc (Array (sh :. Int) e) -> Acc (Array (sh :. Int :. Int) e)+--       rep1 n a = replicate (lift (Any :. n :. All)) a+-- :}+--+-- >>> run $ rep1 5 (use vec)+-- Matrix (Z :. 5 :. 10)+--   [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,+--     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,+--     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,+--     0, 1, 2, 3, 4, 5, 6, 7, 8, 9,+--     0, 1, 2, 3, 4, 5, 6, 7, 8, 9]+--+replicate+    :: (Slice slix, Elt e)+    => Exp slix+    -> Acc (Array (SliceShape slix) e)+    -> Acc (Array (FullShape  slix) e)+replicate = Acc $$ Replicate++-- | Construct a new array by applying a function to each index.+--+-- For example, the following will generate a one-dimensional array+-- (`Vector`) of three floating point numbers:+--+-- >>> run $ generate (index1 3) (\_ -> 1.2) :: Vector Float+-- Vector (Z :. 3) [1.2,1.2,1.2]+--+-- Or equivalently:+--+-- >>> run $ fill (constant (Z :. 3)) 1.2 :: Vector Float+-- Vector (Z :. 3) [1.2,1.2,1.2]+--+-- The following will create a vector with the elements @[1..10]@:+--+-- >>> run $ generate (index1 10) (\ix -> unindex1 ix + 1) :: Vector Int+-- Vector (Z :. 10) [1,2,3,4,5,6,7,8,9,10]+--+-- [/NOTE:/]+--+-- Using 'generate', it is possible to introduce nested data parallelism, which+-- will cause the program to fail.+--+-- If the index given by the scalar function is then used to dispatch further+-- parallel work, whose result is returned into 'Exp' terms by array indexing+-- operations such as ('!') or 'Data.Array.Accelerate.Prelude.the', the program+-- will fail with the error:+-- @.\/Data\/Array\/Accelerate\/Trafo\/Sharing.hs:447 (convertSharingExp): inconsistent valuation \@ shared \'Exp\' tree ...@.+--+generate+    :: (Shape sh, Elt a)+    => Exp sh+    -> (Exp sh -> Exp a)+    -> Acc (Array sh a)+generate = Acc $$ Generate++-- Shape manipulation+-- ------------------++-- | Change the shape of an array without altering its contents. The 'size' of+-- the source and result arrays must be identical.+--+-- > precondition: shapeSize sh == shapeSize sh'+--+-- If the argument array is manifest in memory, 'reshape' is a no-op. If the+-- argument is to be fused into a subsequent operation, 'reshape' corresponds to+-- an index transformation in the fused code.+--+reshape+    :: (Shape sh, Shape sh', Elt e)+    => Exp sh+    -> Acc (Array sh' e)+    -> Acc (Array sh e)+reshape = Acc $$ Reshape++-- Extraction of sub-arrays+-- ------------------------++-- | Index an array with a /generalised/ array index, supplied as the second+-- argument. The result is a new array (possibly a singleton) containing the+-- selected dimensions ('All's) in their entirety.+--+-- 'slice' is the opposite of 'replicate', and can be used to /cut out/ entire+-- dimensions. For example, for the two dimensional array 'mat':+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- ...will can select a specific row to yield a one dimensional result by fixing+-- the row index (2) while allowing the column index to vary (via 'All'):+--+-- >>> run $ slice (use mat) (constant (Z :. (2::Int) :. All))+-- Vector (Z :. 10) [20,21,22,23,24,25,26,27,28,29]+--+-- A fully specified index (with no 'All's) returns a single element (zero+-- dimensional array).+--+-- >>> run $ slice (use mat) (constant (Z :. 4 :. 2 :: DIM2))+-- Scalar Z [42]+--+-- The marker 'Any' can be used in the slice specification to match against some+-- arbitrary (lower) dimension. Here 'Any' matches whatever shape type variable+-- @sh@ takes:+--+-- >>> :{+--   let+--       sl0 :: (Shape sh, Elt e) => Acc (Array (sh:.Int) e) -> Exp Int -> Acc (Array sh e)+--       sl0 a n = slice a (lift (Any :. n))+-- :}+--+-- >>> let vec = fromList (Z:.10) [0..] :: Vector Int+-- >>> run $ sl0 (use vec) 4+-- Scalar Z [4]+--+-- >>> run $ sl0 (use mat) 4+-- Vector (Z :. 5) [4,14,24,34,44]+--+-- Of course, 'Any' and 'All' can be used together.+--+-- >>> :{+--   let sl1 :: (Shape sh, Elt e) => Acc (Array (sh:.Int:.Int) e) -> Exp Int -> Acc (Array (sh:.Int) e)+--       sl1 a n = slice a (lift (Any :. n :. All))+-- :}+--+-- >>> run $ sl1 (use mat) 4+-- Vector (Z :. 10) [40,41,42,43,44,45,46,47,48,49]+--+-- >>> let cube = fromList (Z:.3:.4:.5) [0..] :: Array DIM3 Int+-- >>> cube+-- Array (Z :. 3 :. 4 :. 5) [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59]+--+-- >>> run $ sl1 (use cube) 2+-- Matrix (Z :. 3 :. 5)+--   [ 10, 11, 12, 13, 14,+--     30, 31, 32, 33, 34,+--     50, 51, 52, 53, 54]+--+slice :: (Slice slix, Elt e)+      => Acc (Array (FullShape slix) e)+      -> Exp slix+      -> Acc (Array (SliceShape slix) e)+slice = Acc $$ Slice++-- Map-like functions+-- ------------------++-- | Apply the given function element-wise to an array. Denotationally we have:+--+-- > map f [x1, x2, ... xn] = [f x1, f x2, ... f xn]+--+-- >>> let xs = fromList (Z:.10) [0..] :: Vector Int+-- >>> xs+-- Vector (Z :. 10) [0,1,2,3,4,5,6,7,8,9]+--+-- >>> run $ map (+1) (use xs)+-- Vector (Z :. 10) [1,2,3,4,5,6,7,8,9,10]+--+map :: (Shape sh, Elt a, Elt b)+    => (Exp a -> Exp b)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+map = Acc $$ Map++-- | Apply the given binary function element-wise to the two arrays. The extent+-- of the resulting array is the intersection of the extents of the two source+-- arrays.+--+-- >>> let xs = fromList (Z:.3:.5) [0..] :: Matrix Int+-- >>> xs+-- Matrix (Z :. 3 :. 5)+--   [  0,  1,  2,  3,  4,+--      5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14]+--+-- >>> let ys = fromList (Z:.5:.10) [1..] :: Matrix Int+-- >>> ys+-- Matrix (Z :. 5 :. 10)+--   [  1,  2,  3,  4,  5,  6,  7,  8,  9, 10,+--     11, 12, 13, 14, 15, 16, 17, 18, 19, 20,+--     21, 22, 23, 24, 25, 26, 27, 28, 29, 30,+--     31, 32, 33, 34, 35, 36, 37, 38, 39, 40,+--     41, 42, 43, 44, 45, 46, 47, 48, 49, 50]+--+-- >>> run $ zipWith (+) (use xs) (use ys)+-- Matrix (Z :. 3 :. 5)+--   [  1,  3,  5,  7,  9,+--     16, 18, 20, 22, 24,+--     31, 33, 35, 37, 39]+--+zipWith :: (Shape sh, Elt a, Elt b, Elt c)+        => (Exp a -> Exp b -> Exp c)+        -> Acc (Array sh a)+        -> Acc (Array sh b)+        -> Acc (Array sh c)+zipWith = Acc $$$ ZipWith++-- Reductions+-- ----------++-- | Reduction of the innermost dimension of an array of arbitrary rank.+--+-- The shape of the result obeys the property:+--+-- > shape (fold f z xs) == indexTail (shape xs)+--+-- The first argument needs to be an /associative/ function to enable an+-- efficient parallel implementation. The initial element does not need to be an+-- identity element of the combination function.+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ fold (+) 42 (use mat)+-- Vector (Z :. 5) [87,187,287,387,487]+--+-- Reductions with non-commutative operators are supported. For example, the+-- following computes the maximum segment sum problem along each innermost+-- dimension of the array.+--+-- <https://en.wikipedia.org/wiki/Maximum_subarray_problem>+--+-- >>> :{+--   let maximumSegmentSum+--           :: forall sh e. (Shape sh, Num e, Ord e)+--           => Acc (Array (sh :. Int) e)+--           -> Acc (Array sh e)+--       maximumSegmentSum+--         = map (\v -> let (x,_,_,_) = unlift v :: (Exp e, Exp e, Exp e, Exp e) in x)+--         . fold1 f+--         . map g+--         where+--           f :: (Num a, Ord a) => Exp (a,a,a,a) -> Exp (a,a,a,a) -> Exp (a,a,a,a)+--           f x y =+--             let (mssx, misx, mcsx, tsx) = unlift x+--                 (mssy, misy, mcsy, tsy) = unlift y+--             in+--             lift ( mssx `max` (mssy `max` (mcsx+misy))+--                  , misx `max` (tsx+misy)+--                  , mcsy `max` (mcsx+tsy)+--                  , tsx+tsy+--                  )+--           --+--           g :: (Num a, Ord a) => Exp a -> Exp (a,a,a,a)+--           g x = let y = max x 0+--                 in  lift (y,y,y,x)+-- :}+--+-- >>> let vec = fromList (Z:.10) [-2,1,-3,4,-1,2,1,-5,4,0] :: Vector Int+-- >>> run $ maximumSegmentSum (use vec)+-- Scalar Z [6]+--+-- See also 'Data.Array.Accelerate.Data.Fold.Fold', which can be a useful way to+-- compute multiple results from a single reduction.+--+fold :: (Shape sh, Elt a)+     => (Exp a -> Exp a -> Exp a)+     -> Exp a+     -> Acc (Array (sh:.Int) a)+     -> Acc (Array sh a)+fold = Acc $$$ Fold++-- | Variant of 'fold' that requires the innermost dimension of the array to be+-- non-empty and doesn't need an default value.+--+-- The shape of the result obeys the property:+--+-- > shape (fold f z xs) == indexTail (shape xs)+--+-- The first argument needs to be an /associative/ function to enable an+-- efficient parallel implementation, but does not need to be commutative.+--+fold1 :: (Shape sh, Elt a)+      => (Exp a -> Exp a -> Exp a)+      -> Acc (Array (sh:.Int) a)+      -> Acc (Array sh a)+fold1 = Acc $$ Fold1++-- | Segmented reduction along the innermost dimension of an array. The segment+-- descriptor specifies the lengths of the logical sub-arrays, each of which is+-- reduced independently. The innermost dimension must contain at least as many+-- elements as required by the segment descriptor (sum thereof).+--+-- >>> let seg = fromList (Z:.4) [1,4,0,3] :: Segments Int+-- >>> seg+-- Vector (Z :. 4) [1,4,0,3]+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ foldSeg (+) 0 (use mat) (use seg)+-- Matrix (Z :. 5 :. 4)+--   [  0,  10, 0,  18,+--     10,  50, 0,  48,+--     20,  90, 0,  78,+--     30, 130, 0, 108,+--     40, 170, 0, 138]+--+foldSeg+    :: (Shape sh, Elt a, Elt i, IsIntegral i)+    => (Exp a -> Exp a -> Exp a)+    -> Exp a+    -> Acc (Array (sh:.Int) a)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) a)+foldSeg = Acc $$$$ FoldSeg++-- | Variant of 'foldSeg' that requires /all/ segments of the reduced array to+-- be non-empty and doesn't need a default value. The segment descriptor+-- specifies the length of each of the logical sub-arrays.+--+fold1Seg+    :: (Shape sh, Elt a, Elt i, IsIntegral i)+    => (Exp a -> Exp a -> Exp a)+    -> Acc (Array (sh:.Int) a)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) a)+fold1Seg = Acc $$$ Fold1Seg++-- Scan functions+-- --------------++-- | Data.List style left-to-right scan along the innermost dimension of an+-- arbitrary rank array. The first argument needs to be an /associative/+-- function to enable efficient parallel implementation. The initial value+-- (second argument) may be arbitrary.+--+-- >>> let vec = fromList (Z :. 10) [0..] :: Vector Int+-- >>> run $ scanl (+) 10 (use vec)+-- Vector (Z :. 11) [10,10,11,13,16,20,25,31,38,46,55]+--+-- >>> let mat = fromList (Z :. 4 :. 10) [0..] :: Matrix Int+-- >>> run $ scanl (+) 0 (use mat)+-- Matrix (Z :. 4 :. 11)+--   [ 0,  0,  1,  3,   6,  10,  15,  21,  28,  36,  45,+--     0, 10, 21, 33,  46,  60,  75,  91, 108, 126, 145,+--     0, 20, 41, 63,  86, 110, 135, 161, 188, 216, 245,+--     0, 30, 61, 93, 126, 160, 195, 231, 268, 306, 345]+--+scanl :: (Shape sh, Elt a)+      => (Exp a -> Exp a -> Exp a)+      -> Exp a+      -> Acc (Array (sh:.Int) a)+      -> Acc (Array (sh:.Int) a)+scanl = Acc $$$ Scanl++-- | Variant of 'scanl', where the last element (final reduction result) along+-- each dimension is returned separately. Denotationally we have:+--+-- > scanl' f e arr = (init res, unit (res!len))+-- >   where+-- >     len = shape arr+-- >     res = scanl f e arr+--+-- >>> let vec       = fromList (Z:.10) [0..] :: Vector Int+-- >>> let (res,sum) = run $ scanl' (+) 0 (use vec)+-- >>> res+-- Vector (Z :. 10) [0,0,1,3,6,10,15,21,28,36]+-- >>> sum+-- Scalar Z [45]+--+-- >>> let mat        = fromList (Z:.4:.10) [0..] :: Matrix Int+-- >>> let (res,sums) = run $ scanl' (+) 0 (use mat)+-- >>> res+-- Matrix (Z :. 4 :. 10)+--   [ 0,  0,  1,  3,   6,  10,  15,  21,  28,  36,+--     0, 10, 21, 33,  46,  60,  75,  91, 108, 126,+--     0, 20, 41, 63,  86, 110, 135, 161, 188, 216,+--     0, 30, 61, 93, 126, 160, 195, 231, 268, 306]+-- >>> sums+-- Vector (Z :. 4) [45,145,245,345]+--+scanl' :: (Shape sh, Elt a)+       => (Exp a -> Exp a -> Exp a)+       -> Exp a+       -> Acc (Array (sh:.Int) a)+       -> Acc (Array (sh:.Int) a, Array sh a)+scanl' = Acc $$$ Scanl'++-- | Data.List style left-to-right scan along the innermost dimension without an+-- initial value (aka inclusive scan). The innermost dimension of the array must+-- not be empty. The first argument must be an /associative/ function.+--+-- >>> let mat = fromList (Z:.4:.10) [0..] :: Matrix Int+-- >>> run $ scanl1 (+) (use mat)+-- Matrix (Z :. 4 :. 10)+--   [  0,  1,  3,   6,  10,  15,  21,  28,  36,  45,+--     10, 21, 33,  46,  60,  75,  91, 108, 126, 145,+--     20, 41, 63,  86, 110, 135, 161, 188, 216, 245,+--     30, 61, 93, 126, 160, 195, 231, 268, 306, 345]+--+scanl1 :: (Shape sh, Elt a)+       => (Exp a -> Exp a -> Exp a)+       -> Acc (Array (sh:.Int) a)+       -> Acc (Array (sh:.Int) a)+scanl1 = Acc $$ Scanl1++-- | Right-to-left variant of 'scanl'.+--+scanr :: (Shape sh, Elt a)+      => (Exp a -> Exp a -> Exp a)+      -> Exp a+      -> Acc (Array (sh:.Int) a)+      -> Acc (Array (sh:.Int) a)+scanr = Acc $$$ Scanr++-- | Right-to-left variant of 'scanl''.+--+scanr' :: (Shape sh, Elt a)+       => (Exp a -> Exp a -> Exp a)+       -> Exp a+       -> Acc (Array (sh:.Int) a)+       -> Acc (Array (sh:.Int) a, Array sh a)+scanr' = Acc $$$ Scanr'++-- | Right-to-left variant of 'scanl1'.+--+scanr1 :: (Shape sh, Elt a)+       => (Exp a -> Exp a -> Exp a)+       -> Acc (Array (sh:.Int) a)+       -> Acc (Array (sh:.Int) a)+scanr1 = Acc $$ Scanr1++-- Permutations+-- ------------++-- | Generalised forward permutation operation (array scatter).+--+-- Forward permutation specified by a function mapping indices from the source+-- array to indices in the result array. The result array is initialised with+-- the given defaults and any further values that are permuted into the result+-- array are added to the current value using the given combination function.+--+-- The combination function must be /associative/ and /commutative/. Elements+-- that are mapped to the magic index 'ignore' by the permutation function are+-- dropped.+--+-- The combination function is given the new value being permuted as its first+-- argument, and the current value of the array as its second.+--+-- For example, we can use 'permute' to compute the occurrence count (histogram)+-- for an array of values in the range @[0,10)@:+--+-- >>> :{+--   let histogram :: Acc (Vector Int) -> Acc (Vector Int)+--       histogram xs =+--         let zeros = fill (constant (Z:.10)) 0+--             ones  = fill (shape xs)         1+--         in+--         permute (+) zeros (\ix -> index1 (xs!ix)) ones+-- :}+--+-- >>> let xs = fromList (Z :. 20) [0,0,1,2,1,1,2,4,8,3,4,9,8,3,2,5,5,3,1,2] :: Vector Int+-- >>> run $ histogram (use xs)+-- Vector (Z :. 10) [2,4,4,3,2,2,0,0,2,1]+--+-- As a second example, note that the dimensionality of the source and+-- destination arrays can differ. In this way, we can use 'permute' to create an+-- identity matrix by overwriting elements along the diagonal:+--+-- >>> :{+--   let identity :: Num a => Exp Int -> Acc (Matrix a)+--       identity n =+--         let zeros = fill (index2 n n) 0+--             ones  = fill (index1 n)   1+--         in+--         permute const zeros (\(unindex1 -> i) -> index2 i i) ones+-- :}+--+-- >>> run $ identity 5 :: Matrix Int+-- Matrix (Z :. 5 :. 5)+--   [ 1, 0, 0, 0, 0,+--     0, 1, 0, 0, 0,+--     0, 0, 1, 0, 0,+--     0, 0, 0, 1, 0,+--     0, 0, 0, 0, 1]+--+-- [/Note:/]+--+-- Regarding array fusion:+--+--   1. The 'permute' operation will always be evaluated; it can not be fused+--      into a later step.+--+--   2. Since the index permutation function might not cover all positions in+--      the output array (the function is not surjective), the array of default+--      values must be evaluated. However, other operations may fuse into this.+--+--   3. The array of source values can fuse into the permutation operation.+--+--   4. If the array of default values is only used once, it will be updated+--      in-place.+--+-- Regarding the defaults array:+--+-- If you are sure that the default values are not necessary---they are not used+-- by the combination function and every element will be overwritten---a default+-- array created by 'Data.Array.Accelerate.Prelude.fill'ing with the value+-- 'Data.Array.Accelerate.Unsafe.undef' will give you a new uninitialised array.+--+permute+    :: (Shape sh, Shape sh', Elt a)+    => (Exp a -> Exp a -> Exp a)        -- ^ combination function+    -> Acc (Array sh' a)                -- ^ array of default values+    -> (Exp sh -> Exp sh')              -- ^ index permutation function+    -> Acc (Array sh  a)                -- ^ array of source values to be permuted+    -> Acc (Array sh' a)+permute = Acc $$$$ Permute++-- | Generalised backward permutation operation (array gather).+--+-- Backward permutation specified by a function mapping indices in the+-- destination array to indices in the source array. Elements of the output+-- array are thus generated by reading from the corresponding index in the+-- source array.+--+-- For example, backpermute can be used to+-- 'Data.Array.Accelerate.Prelude.transpose' a matrix; at every index @Z:.y:.x@+-- in the result array, we get the value at that index by reading from the+-- source array at index @Z:.x:.y@:+--+-- >>> :{+--   let swap :: Exp DIM2 -> Exp DIM2+--       swap = lift1 f+--         where+--           f :: Z :. Exp Int :. Exp Int -> Z :. Exp Int :. Exp Int+--           f (Z:.y:.x) = Z :. x :. y+-- :}+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> let mat' = use mat+-- >>> run $ backpermute (swap (shape mat')) swap mat'+-- Matrix (Z :. 10 :. 5)+--   [ 0, 10, 20, 30, 40,+--     1, 11, 21, 31, 41,+--     2, 12, 22, 32, 42,+--     3, 13, 23, 33, 43,+--     4, 14, 24, 34, 44,+--     5, 15, 25, 35, 45,+--     6, 16, 26, 36, 46,+--     7, 17, 27, 37, 47,+--     8, 18, 28, 38, 48,+--     9, 19, 29, 39, 49]+--+backpermute+    :: (Shape sh, Shape sh', Elt a)+    => Exp sh'                          -- ^ shape of the result array+    -> (Exp sh' -> Exp sh)              -- ^ index permutation function+    -> Acc (Array sh  a)                -- ^ source array+    -> Acc (Array sh' a)+backpermute = Acc $$$ Backpermute+++-- Stencil operations+-- ------------------++-- Common stencil types+--++-- DIM1 stencil type+type Stencil3 a = (Exp a, Exp a, Exp a)+type Stencil5 a = (Exp a, Exp a, Exp a, Exp a, Exp a)+type Stencil7 a = (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)+type Stencil9 a = (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)++-- DIM2 stencil type+type Stencil3x3 a = (Stencil3 a, Stencil3 a, Stencil3 a)+type Stencil5x3 a = (Stencil5 a, Stencil5 a, Stencil5 a)+type Stencil3x5 a = (Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a)+type Stencil5x5 a = (Stencil5 a, Stencil5 a, Stencil5 a, Stencil5 a, Stencil5 a)++-- DIM3 stencil type+type Stencil3x3x3 a = (Stencil3x3 a, Stencil3x3 a, Stencil3x3 a)+type Stencil5x3x3 a = (Stencil5x3 a, Stencil5x3 a, Stencil5x3 a)+type Stencil3x5x3 a = (Stencil3x5 a, Stencil3x5 a, Stencil3x5 a)+type Stencil3x3x5 a = (Stencil3x3 a, Stencil3x3 a, Stencil3x3 a, Stencil3x3 a, Stencil3x3 a)+type Stencil5x5x3 a = (Stencil5x5 a, Stencil5x5 a, Stencil5x5 a)+type Stencil5x3x5 a = (Stencil5x3 a, Stencil5x3 a, Stencil5x3 a, Stencil5x3 a, Stencil5x3 a)+type Stencil3x5x5 a = (Stencil3x5 a, Stencil3x5 a, Stencil3x5 a, Stencil3x5 a, Stencil3x5 a)+type Stencil5x5x5 a = (Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, Stencil5x5 a)+++-- | Map a stencil over an array. In contrast to 'map', the domain of a stencil+-- function is an entire /neighbourhood/ of each array element. Neighbourhoods+-- are sub-arrays centred around a focal point. They are not necessarily+-- rectangular, but they are symmetric and have an extent of at least three+-- along each axis. Due to the symmetry requirement the extent is necessarily+-- odd. The focal point is the array position that is determined by the stencil.+--+-- For those array positions where the neighbourhood extends past the boundaries+-- of the source array, a boundary condition determines the contents of the+-- out-of-bounds neighbourhood positions.+--+-- Stencil neighbourhoods are specified via nested tuples, where the nesting+-- depth is equal to the dimensionality of the array. For example, a 3x1 stencil+-- for a one-dimensional array:+--+-- > s31 :: Stencil3 a -> Exp a+-- > s31 (l,c,r) = ...+--+-- ...where @c@ is the focal point of the stencil, and @l@ and @r@ represent the+-- elements to the left and right of the focal point, respectively. Similarly,+-- a 3x3 stencil for a two-dimensional array:+--+-- > s33 :: Stencil3x3 a -> Exp a+-- > s33 ((_,t,_)+-- >     ,(l,c,r)+-- >     ,(_,b,_)) = ...+--+-- ...where @c@ is again the focal point and @t@, @b@, @l@ and @r@ are the+-- elements to the top, bottom, left, and right of the focal point, respectively+-- (the diagonal elements have been elided).+--+-- For example, the following computes a 5x5+-- <https://en.wikipedia.org/wiki/Gaussian_blur Gaussian blur> as a separable+-- 2-pass operation.+--+-- > type Stencil5x1 a = (Stencil3 a, Stencil5 a, Stencil3 a)+-- > type Stencil1x5 a = (Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a)+-- >+-- > convolve5x1 :: Num a => [Exp a] -> Stencil5x1 a -> Exp a+-- > convolve5x1 kernel (_, (a,b,c,d,e), _)+-- >   = Prelude.sum $ Prelude.zipWith (*) kernel [a,b,c,d,e]+-- >+-- > convolve1x5 :: Num a => [Exp a] -> Stencil1x5 a -> Exp a+-- > convolve1x5 kernel ((_,a,_), (_,b,_), (_,c,_), (_,d,_), (_,e,_))+-- >   = Prelude.sum $ Prelude.zipWith (*) kernel [a,b,c,d,e]+-- >+-- > gaussian = [0.06136,0.24477,0.38774,0.24477,0.06136]+-- >+-- > blur :: Num a => Acc (Matrix a) -> Acc (Matrix a)+-- > blur = stencil (convolve5x1 gaussian) clamp+-- >      . stencil (convolve1x5 gaussian) clamp+--+stencil+    :: (Stencil sh a stencil, Elt b)+    => (stencil -> Exp b)                     -- ^ stencil function+    -> Boundary (Array sh a)                  -- ^ boundary condition+    -> Acc (Array sh a)                       -- ^ source array+    -> Acc (Array sh b)                       -- ^ destination array+stencil f (Boundary b) a = Acc $ Stencil f b a++-- | Map a binary stencil of an array. The extent of the resulting array is the+-- intersection of the extents of the two source arrays. This is the stencil+-- equivalent of 'zipWith'.+--+stencil2+    :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c)+    => (stencil1 -> stencil2 -> Exp c)        -- ^ binary stencil function+    -> Boundary (Array sh a)                  -- ^ boundary condition #1+    -> Acc (Array sh a)                       -- ^ source array #1+    -> Boundary (Array sh b)                  -- ^ boundary condition #2+    -> Acc (Array sh b)                       -- ^ source array #2+    -> Acc (Array sh c)                       -- ^ destination array+stencil2 f (Boundary b1) a1 (Boundary b2) a2 = Acc $ Stencil2 f b1 a1 b2 a2++-- | Boundary condition where elements of the stencil which would be+-- out-of-bounds are instead clamped to the edges of the array.+--+-- In the following 3x3 stencil, the out-of-bounds element @b@ will instead+-- return the value at position @c@:+--+-- >   +------------++-- >   |a           |+-- >  b|cd          |+-- >   |e           |+-- >   +------------++--+clamp :: Boundary (Array sh e)+clamp = Boundary Clamp++-- | Stencil boundary condition where coordinates beyond the array extent are+-- instead mirrored+--+-- In the following 5x3 stencil, the out-of-bounds element @c@ will instead+-- return the value at position @d@, and similarly the element at @b@ will+-- return the value at @e@:+--+-- >   +------------++-- >   |a           |+-- > bc|def         |+-- >   |g           |+-- >   +------------++--+mirror :: Boundary (Array sh e)+mirror = Boundary Mirror++-- | Stencil boundary condition where coordinates beyond the array extent+-- instead wrap around the array (circular boundary conditions).+--+-- In the following 3x3 stencil, the out of bounds elements will be read as in+-- the pattern on the right.+--+-- >  a bc+-- >   +------------+      +------------++-- >  d|ef          |      |ef         d|+-- >  g|hi          |  ->  |hi         g|+-- >   |            |      |bc         a|+-- >   +------------+      +------------++--+wrap :: Boundary (Array sh e)+wrap = Boundary Wrap++-- | Stencil boundary condition where the given function is applied to any+-- outlying coordinates.+--+-- The function is passed the out-of-bounds index, so you can use it to specify+-- different boundary conditions at each side. For example, the following would+-- clamp out-of-bounds elements in the y-direction to zero, while having+-- circular boundary conditions in the x-direction.+--+-- > ring :: Acc (Matrix Float) -> Acc (Matrix Float)+-- > ring xs = stencil f boundary xs+-- >   where+-- >     boundary :: Boundary (Matrix Float)+-- >     boundary = function $ \(unlift -> Z :. y :. x) ->+-- >       if y < 0 || y >= height+-- >         then 0+-- >         else if x < 0+-- >                then xs ! index2 y (width+x)+-- >                else xs ! index2 y (x-width)+-- >+-- >     f :: Stencil3x3 Float -> Exp Float+-- >     f = ...+-- >+-- >     Z :. height :. width = unlift (shape xs)+--+function+    :: (Shape sh, Elt e)+    => (Exp sh -> Exp e)+    -> Boundary (Array sh e)+function = Boundary . Function+++{--+-- Sequence operations+-- ------------------++-- Common sequence types+--++streamIn :: Arrays a+         => [a]+         -> Seq [a]+streamIn arrs = Seq (StreamIn arrs)++-- | Convert the given array to a sequence by dividing the array up into subarrays.+-- The first argument captures how to the division should be performed. The+-- presence of `All` in the division descriptor indicates that elements in the+-- corresponding dimension should be retained in the subarrays, whereas `Split`+-- indicates that the input array should divided along this dimension.+--+toSeq :: (Division slsix, Elt a)+      => slsix+      -> Acc (Array (FullShape (DivisionSlice slsix)) a)+      -> Seq [Array (SliceShape (DivisionSlice slsix)) a]+toSeq spec acc = Seq (ToSeq spec acc)++-- | Apply the given array function element-wise to the given sequence.+--+mapSeq :: (Arrays a, Arrays b)+       => (Acc a -> Acc b)+       -> Seq [a]+       -> Seq [b]+mapSeq = Seq $$ MapSeq++-- | Apply the given binary function element-wise to the two sequences.  The length of the resulting+-- sequence is the minumum of the lengths of the two source sequences.+--+zipWithSeq :: (Arrays a, Arrays b, Arrays c)+           => (Acc a -> Acc b -> Acc c)+           -> Seq [a]+           -> Seq [b]+           -> Seq [c]+zipWithSeq = Seq $$$ ZipWithSeq++-- | scanSeq (+) a0 x seq. 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 a+        => (Exp a -> Exp a -> Exp a)+        -> Exp a+        -> Seq [Scalar a]+        -> Seq [Scalar a]+scanSeq = Seq $$$ ScanSeq++-- | foldSeq (+) a0 x seq. 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+        => (Exp a -> Exp a -> Exp a)+        -> Exp a+        -> Seq [Scalar a]+        -> Seq (Scalar a)+foldSeq = Seq $$$ FoldSeq++-- | foldSeqFlatten f a0 x seq. 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 jx, Elt b)+               => (Acc a -> Acc (Vector jx) -> Acc (Vector b) -> Acc a)+               -> Acc a+               -> Seq [Array jx b]+               -> Seq a+foldSeqFlatten = Seq $$$ FoldSeqFlatten++collect :: Arrays arrs => Seq arrs -> Acc arrs+collect = Acc . Collect+--}++-- Foreign function calling+-- ------------------------++-- | Call a foreign array function.+--+-- The form the first argument takes is dependent on the backend being targeted.+-- Note that the foreign function only has access to the input array(s) passed+-- in as its argument.+--+-- In case the operation is being executed on a backend which does not support+-- this foreign implementation, the fallback implementation is used instead,+-- which itself could be a foreign implementation for a (presumably) different+-- backend, or an implementation in pure Accelerate. In this way, multiple+-- foreign implementations can be supplied, and will be tested for suitability+-- against the target backend in sequence.+--+-- For an example see the <https://hackage.haskell.org/package/accelerate-fft accelerate-fft> package.+--+foreignAcc+    :: (Arrays as, Arrays bs, Foreign asm)+    => asm (as -> bs)+    -> (Acc as -> Acc bs)+    -> Acc as+    -> Acc bs+foreignAcc = Acc $$$ Aforeign++-- | Call a foreign scalar expression.+--+-- The form of the first argument is dependent on the backend being targeted.+-- Note that the foreign function only has access to the input element(s) passed+-- in as its first argument.+--+-- As with 'foreignAcc', the fallback implementation itself may be a (sequence+-- of) foreign implementation(s) for a different backend(s), or implemented+-- purely in Accelerate.+--+foreignExp+    :: (Elt x, Elt y, Foreign asm)+    => asm (x -> y)+    -> (Exp x -> Exp y)+    -> Exp x+    -> Exp y+foreignExp = Exp $$$ Foreign+++-- Composition of array computations+-- ---------------------------------++-- | Pipelining of two array computations. The first argument will be fully+-- evaluated before being passed to the second computation. This can be used to+-- prevent the argument being fused into the function, for example.+--+-- Denotationally, we have+--+-- > (acc1 >-> acc2) arrs = let tmp = acc1 arrs+-- >                        in  tmp `seq` acc2 tmp+--+-- For an example use of this operation see the 'Data.Array.Accelerate.compute'+-- function.+--+infixl 1 >->+(>->) :: (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b) -> (Acc b -> Acc c) -> (Acc a -> Acc c)+(>->) = Acc $$$ Pipe+++-- Flow control constructs+-- -----------------------++-- | An array-level if-then-else construct.+--+-- Enabling the @RebindableSyntax@ extension will allow you to use the standard+-- if-then-else syntax instead.+--+acond :: Arrays a+      => Exp Bool               -- ^ if-condition+      -> Acc a                  -- ^ then-array+      -> Acc a                  -- ^ else-array+      -> Acc a+acond = Acc $$$ Acond++-- | An array-level 'while' construct. Continue to apply the given function,+-- starting with the initial value, until the test function evaluates to+-- 'False'.+--+awhile :: Arrays a+       => (Acc a -> Acc (Scalar Bool))    -- ^ keep evaluating while this returns 'True'+       -> (Acc a -> Acc a)                -- ^ function to apply+       -> Acc a                           -- ^ initial value+       -> Acc a+awhile = Acc $$$ Awhile+++-- Shapes and indices+-- ------------------++-- | Get the innermost dimension of a shape.+--+-- The innermost dimension (right-most component of the shape) is the index of+-- the array which varies most rapidly, and corresponds to elements of the array+-- which are adjacent in memory.+--+-- Another way to think of this is, for example when writing nested loops over+-- an array in C, this index corresponds to the index iterated over by the+-- innermost nested loop.+--+indexHead :: (Slice sh, Elt a) => Exp (sh :. a) -> Exp a+indexHead = Exp . IndexHead++-- | Get all but the innermost element of a shape+--+indexTail :: (Slice sh, Elt a) => Exp (sh :. a) -> Exp sh+indexTail = Exp . IndexTail++-- | Map a multi-dimensional index into a linear, row-major representation of an+-- array.+--+toIndex+    :: Shape sh+    => Exp sh                     -- ^ extent of the array+    -> Exp sh                     -- ^ index to remap+    -> Exp Int+toIndex = Exp $$ ToIndex++-- | Inverse of 'toIndex'+--+fromIndex :: Shape sh => Exp sh -> Exp Int -> Exp sh+fromIndex = Exp $$ FromIndex++-- | Intersection of two shapes+--+intersect :: Shape sh => Exp sh -> Exp sh -> Exp sh+intersect = Exp $$ Intersect++-- | Union of two shapes+--+union :: Shape sh => Exp sh -> Exp sh -> Exp sh+union = Exp $$ Union+++-- Flow-control+-- ------------++-- | A scalar-level if-then-else construct.+--+-- Enabling the @RebindableSyntax@ extension will allow you to use the standard+-- if-then-else syntax instead.+--+cond :: Elt t+     => Exp Bool                -- ^ condition+     -> Exp t                   -- ^ then-expression+     -> Exp t                   -- ^ else-expression+     -> Exp t+cond = Exp $$$ Cond++-- | While construct. Continue to apply the given function, starting with the+-- initial value, until the test function evaluates to 'False'.+--+while :: Elt e+      => (Exp e -> Exp Bool)    -- ^ keep evaluating while this returns 'True'+      -> (Exp e -> Exp e)       -- ^ function to apply+      -> Exp e                  -- ^ initial value+      -> Exp e+while = Exp $$$ While+++-- Array operations with a scalar result+-- -------------------------------------++-- | Multidimensional array indexing. Extract the value from an array at the+-- specified zero-based index.+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> runExp $ use mat ! constant (Z:.1:.2)+-- 12+--+infixl 9 !+(!) :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -> Exp e+(!) = Exp $$ Index++-- | Extract the value from an array at the specified linear index.+-- Multidimensional arrays in Accelerate are stored in row-major order with+-- zero-based indexing.+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> runExp $ use mat !! 12+-- 12+--+infixl 9 !!+(!!) :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp Int -> Exp e+(!!) = Exp $$ LinearIndex++-- | Extract the shape (extent) of an array.+--+shape :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh+shape = Exp . Shape++-- | The number of elements in the array+--+size :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp Int+size = shapeSize . shape++-- | The number of elements that would be held by an array of the given shape.+--+shapeSize :: Shape sh => Exp sh -> Exp Int+shapeSize = Exp . ShapeSize+++-- Numeric functions+-- -----------------++-- | 'subtract' is the same as @'flip' ('-')@.+--+subtract :: Num a => Exp a -> Exp a -> Exp a+subtract x y = y - x++-- | Determine if a number is even+--+even :: Integral a => Exp a -> Exp Bool+even n = n `rem` 2 == 0++-- | Determine if a number is odd+--+odd :: Integral a => Exp a -> Exp Bool+odd n = n `rem` 2 /= 0++-- | @'gcd' x y@ is the non-negative factor of both @x@ and @y@ of which every+-- common factor of both @x@ and @y@ is also a factor; for example:+--+-- > gcd 4 2 = 2+-- > gcd (-4) 6 = 2+-- > gcd 0 4 = 4+-- > gcd 0 0 = 0+--+-- That is, the common divisor that is \"greatest\" in the divisibility+-- preordering.+--+gcd :: Integral a => Exp a -> Exp a -> Exp a+gcd x y = gcd' (abs x) (abs y)+  where+    gcd' :: Integral a => Exp a -> Exp a -> Exp a+    gcd' u v =+      let (r,_) = untup2+                $ while (\(untup2 -> (_,b)) -> b /= 0)+                        (\(untup2 -> (a,b)) -> tup2 (b, a `rem` b))+                        (tup2 (u,v))+      in r+++-- | @'lcm' x y@ is the smallest positive integer that both @x@ and @y@ divide.+--+lcm :: Integral a => Exp a -> Exp a -> Exp a+lcm x y+  = cond (x == 0 || y == 0) 0+  $ abs ((x `quot` (gcd x y)) * y)+++-- | Raise a number to a non-negative integral power+--+infixr 8 ^+(^) :: forall a b. (Num a, Integral b) => Exp a -> Exp b -> Exp a+x0 ^ y0 = cond (y0 <= 0) 1 (f x0 y0)+  where+    f :: Exp a -> Exp b -> Exp a+    f x y =+      let (x',y') = untup2+                  $ while (\(untup2 -> (_,v)) -> even v)+                          (\(untup2 -> (u,v)) -> tup2 (u * u, v `quot` 2))+                          (tup2 (x, y))+      in+      cond (y' == 1) x' (g (x'*x') ((y'-1) `quot` 2) x')++    g :: Exp a -> Exp b -> Exp a -> Exp a+    g x y z =+      let (x',_,z') = untup3+                    $ while (\(untup3 -> (_,v,_)) -> v /= 1)+                            (\(untup3 -> (u,v,w)) ->+                              cond (even v) (tup3 (u*u, v     `quot` 2, w))+                                            (tup3 (u*u, (v-1) `quot` 2, w*u)))+                            (tup3 (x,y,z))+      in+      x' * z'++-- | Raise a number to an integral power+--+infixr 8 ^^+(^^) :: (Fractional a, Integral b) => Exp a -> Exp b -> Exp a+x ^^ n+  = cond (n >= 0)+  {- then -} (x ^ n)+  {- else -} (recip (x ^ (negate n)))+++-- Conversions+-- -----------++-- |Convert a character to an 'Int'.+--+ord :: Exp Char -> Exp Int+ord = mkOrd++-- |Convert an 'Int' into a character.+--+chr :: Exp Int -> Exp Char+chr = mkChr++-- |Convert a Boolean value to an 'Int', where 'False' turns into '0' and 'True'+-- into '1'.+--+boolToInt :: Exp Bool -> Exp Int+boolToInt = mkBoolToInt++-- |Reinterpret a value as another type. The two representations must have the+-- same bit size.+--+bitcast+    :: (Elt a, Elt b, IsScalar (EltRepr a), IsScalar (EltRepr b), BitSizeEq (EltRepr a) (EltRepr b))+    => Exp a+    -> Exp b+bitcast = mkBitcast+++-- Constants+-- ---------++-- | Magic index identifying elements that are ignored in a forward permutation.+--+ignore :: Shape sh => Exp sh+ignore = constant Sugar.ignore+
+ src/Data/Array/Accelerate/Lifetime.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP           #-}+{-# LANGUAGE MagicHash     #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Lifetime+-- Copyright   : [2015..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)+--++module Data.Array.Accelerate.Lifetime (++  Lifetime(..),+  newLifetime, withLifetime, touchLifetime,+  addFinalizer, finalize, mkWeak, mkWeakPtr,++  unsafeGetValue,++) where++import Data.Function                ( on )+import Data.IORef                   ( mkWeakIORef, atomicModifyIORef' )+import Prelude++import GHC.Base                     ( touch#, IO(..))+import GHC.IORef                    ( IORef(.. ), newIORef )+import GHC.Prim                     ( mkWeak# )+import GHC.STRef                    ( STRef(..) )+import GHC.Weak                     ( Weak(..) )+++-- | A lifetime represents a value with attached finalizers. This is similar to+-- the functionality provided by "System.Mem.Weak", but has the following+-- stronger properties:+--+-- * Unless explicitly forced, finalizers will not fire until after the+--   'Lifetime' has become unreachable, where \"reachability\" is the same as+--   defined in "System.Mem.Weak". That is to say, there is no issue with+--   creating a 'Lifetime' for a non-primitve type and finalizers firing while+--   an object is still reachable.+--+-- * Finalizers are fired sequentially in reverse of the order in which they+--   were attached.+--+-- * As the finalizers are attached to the 'Lifetime' and not the underlying+--   value, there is no danger in storing it UNPACKED as part of another+--   structure.+--+type LTF        = IORef [IO ()]+data Lifetime a = Lifetime {-# UNPACK #-} !LTF+                           {-# UNPACK #-} !(Weak LTF)+                           {- LAZY -}     a++instance Eq a => Eq (Lifetime a) where+  (==) = (==) `on` unsafeGetValue++-- | Construct a new 'Lifetime' from the given value.+--+{-# INLINE newLifetime #-}+newLifetime :: a -> IO (Lifetime a)+newLifetime a = do+  ref  <- newIORef []+  weak <- mkWeakIORef ref (finalizer ref)+  return $! Lifetime ref weak a++-- | This provides a way of looking at the value inside a 'Lifetime'. The+-- supplied function is executed immediately and the 'Lifetime' kept alive+-- throughout its execution. It is important to not let the value /leak/ outside+-- the function, either by returning it or by lazy IO.+--+{-# INLINE withLifetime #-}+withLifetime :: Lifetime a -> (a -> IO b) -> IO b+withLifetime (Lifetime ref _ a) f = do+  r <- f a+  touchIORef ref+  return r++-- | Ensure that the lifetime is alive at the given place in a sequence of IO+-- actions. Does not force the payload.+--+{-# INLINE touchLifetime #-}+touchLifetime :: Lifetime a -> IO ()+touchLifetime (Lifetime ref _ _) = touchIORef ref++-- | Attaches a finalizer to a 'Lifetime'. Like in "System.Mem.Weak", there is+-- no guarantee that the finalizers will eventually run. If they do run,+-- they will be executed in the order in which they were supplied.+--+addFinalizer :: Lifetime a -> IO () -> IO ()+addFinalizer (Lifetime ref _ _) f =+  atomicModifyIORef' ref (\fs -> (f:fs,()))++-- | Causes any finalizers associated with the given lifetime to be run+-- immediately on the calling thread.+--+-- Because the finalizer is run on the calling thread. Care should be taken to+-- ensure that the it does not try to acquire any locks the calling thread might+-- already possess. This can result in deadlock and is in contrast to calling+-- 'System.Mem.Weak.finalize' on 'System.Mem.Weak.Weak'.+--+finalize :: Lifetime a -> IO ()+finalize (Lifetime ref _ _) = finalizer ref++-- | Create a weak pointer from a 'Lifetime' to the supplied value.+--+-- Because weak pointers have their own concept of finalizers, it is important+-- to note these behaviours:+--+-- * Calling 'System.Mem.Weak.finalize' causes the finalizers attached to the+--   lifetime to be scheduled, and run in the correct order, but does not+--   guarantee they will execute on the calling thread.+--+-- * If 'deRefWeak' returns Nothing, there is no guarantee that the finalizers+--   have already run.+--+mkWeak :: Lifetime k -> v -> IO (Weak v)+mkWeak (Lifetime ref@(IORef (STRef r#)) _ _) v = go (finalizer ref)+  where+#if __GLASGOW_HASKELL__ >= 800+    go (IO f)  =  -- GHC-8.x+#else+    go f       =  -- GHC-7.x+#endif+      IO $ \s -> case mkWeak# r# v f s of+                   (# s', w# #) -> (# s', Weak w# #)++-- A specialised version of 'mkWeak' where the key and value are the same+-- 'Lifetime'.+--+-- > mkWeakPtr key = mkWeak key key+--+mkWeakPtr :: Lifetime a -> IO (Weak (Lifetime a))+mkWeakPtr l = mkWeak l l++-- | Retrieve the value from a lifetime. This is unsafe because, unless the+-- 'Lifetime' is still reachable, the finalizers may fire, potentially+-- invalidating the value.+--+{-# INLINE unsafeGetValue #-}+unsafeGetValue :: Lifetime a -> a+unsafeGetValue (Lifetime _ _ a) = a++-- The actual finalizer for 'Lifetime's.+--+finalizer :: IORef [IO ()] -> IO ()+finalizer ref = do+  fins <- atomicModifyIORef' ref ([],)+  sequence_ fins++-- Touch an 'IORef', ensuring that it is alive at this point in a sequence of IO+-- actions.+--+{-# INLINE touchIORef #-}+touchIORef :: IORef a -> IO ()+touchIORef r = IO $ \s -> case touch# r s of s' -> (# s', () #)+
+ src/Data/Array/Accelerate/Lift.hs view
@@ -0,0 +1,747 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+#if __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE OverlappingInstances  #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+-- |+-- Module      : Data.Array.Accelerate.Lift+-- Copyright   : [2016..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)+--+-- Lifting and lowering surface expressions through constructors.+--++module Data.Array.Accelerate.Lift (++  -- * Lifting and unlifting+  Lift(..), Unlift(..),++  lift1, lift2, lift3,+  ilift1, ilift2, ilift3,++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type+++-- |Lift a unary function into 'Exp'.+--+lift1 :: (Unlift Exp a, Lift Exp b)+      => (a -> b)+      -> Exp (Plain a)+      -> Exp (Plain b)+lift1 f = lift . f . unlift++-- |Lift a binary function into 'Exp'.+--+lift2 :: (Unlift Exp a, Unlift Exp b, Lift Exp c)+      => (a -> b -> c)+      -> Exp (Plain a)+      -> Exp (Plain b)+      -> Exp (Plain c)+lift2 f x y = lift $ f (unlift x) (unlift y)++-- |Lift a ternary function into 'Exp'.+--+lift3 :: (Unlift Exp a, Unlift Exp b, Unlift Exp c, Lift Exp d)+      => (a -> b -> c -> d)+      -> Exp (Plain a)+      -> Exp (Plain b)+      -> Exp (Plain c)+      -> Exp (Plain d)+lift3 f x y z = lift $ f (unlift x) (unlift y) (unlift z)++-- |Lift a unary function to a computation over rank-1 indices.+--+ilift1 :: (Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1+ilift1 f = lift1 (\(Z:.i) -> Z :. f i)++-- |Lift a binary function to a computation over rank-1 indices.+--+ilift2 :: (Exp Int -> Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 -> Exp DIM1+ilift2 f = lift2 (\(Z:.i) (Z:.j) -> Z :. f i j)++-- |Lift a ternary function to a computation over rank-1 indices.+--+ilift3 :: (Exp Int -> Exp Int -> Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 -> Exp DIM1 -> Exp DIM1+ilift3 f = lift3 (\(Z:.i) (Z:.j) (Z:.k) -> Z :. f i j k)++++-- | The class of types @e@ which can be lifted into @c@.+class Lift c e where+  -- | An associated-type (i.e. a type-level function) that strips all+  --   instances of surface type constructors @c@ from the input type @e@.+  --+  --   For example, the tuple types @(Exp Int, Int)@ and @(Int, Exp+  --   Int)@ have the same \"Plain\" representation.  That is, the+  --   following type equality holds:+  --+  --    @Plain (Exp Int, Int) ~ (Int,Int) ~ Plain (Int, Exp Int)@+  type Plain e++  -- | Lift the given value into a surface type 'c' --- either 'Exp' for scalar+  -- expressions or 'Acc' for array computations. The value may already contain+  -- subexpressions in 'c'.+  --+  lift :: e -> c (Plain e)++-- | A limited subset of types which can be lifted, can also be unlifted.+class Lift c e => Unlift c e where++  -- | Unlift the outermost constructor through the surface type. This is only+  -- possible if the constructor is fully determined by its type - i.e., it is a+  -- singleton.+  --+  unlift :: c (Plain e) -> e+++-- identity instances++instance Lift Exp (Exp e) where+  type Plain (Exp e) = e+  lift = id++instance Unlift Exp (Exp e) where+  unlift = id++instance Lift Acc (Acc a) where+  type Plain (Acc a) = a+  lift = id++instance Unlift Acc (Acc a) where+  unlift = id++-- instance Lift Seq (Seq a) where+--   type Plain (Seq a) = a+--   lift = id++-- instance Unlift Seq (Seq a) where+--   unlift = id+++-- instances for indices++instance Lift Exp () where+  type Plain () = ()+  lift _ = Exp $ Tuple NilTup++instance Unlift Exp () where+  unlift _ = ()++instance Lift Exp Z where+  type Plain Z = Z+  lift _ = Exp $ IndexNil++instance Unlift Exp Z where+  unlift _ = Z++instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Int) where+  type Plain (ix :. Int) = Plain ix :. Int+  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)++instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. All) where+  type Plain (ix :. All) = Plain ix :. All+  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)++instance (Elt e, Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Exp e) where+  type Plain (ix :. Exp e) = Plain ix :. e+  lift (ix:.i) = Exp $ IndexCons (lift ix) i++instance {-# OVERLAPPABLE #-} (Elt e, Slice (Plain ix), Unlift Exp ix) => Unlift Exp (ix :. Exp e) where+  unlift e = unlift (Exp $ IndexTail e) :. Exp (IndexHead e)++instance {-# OVERLAPPABLE #-} (Elt e, Slice ix) => Unlift Exp (Exp ix :. Exp e) where+  unlift e = (Exp $ IndexTail e) :. Exp (IndexHead e)++instance Shape sh => Lift Exp (Any sh) where+ type Plain (Any sh) = Any sh+ lift Any = Exp $ IndexAny++-- instances for numeric types++instance Lift Exp Int where+  type Plain Int = Int+  lift = Exp . Const++instance Lift Exp Int8 where+  type Plain Int8 = Int8+  lift = Exp . Const++instance Lift Exp Int16 where+  type Plain Int16 = Int16+  lift = Exp . Const++instance Lift Exp Int32 where+  type Plain Int32 = Int32+  lift = Exp . Const++instance Lift Exp Int64 where+  type Plain Int64 = Int64+  lift = Exp . Const++instance Lift Exp Word where+  type Plain Word = Word+  lift = Exp . Const++instance Lift Exp Word8 where+  type Plain Word8 = Word8+  lift = Exp . Const++instance Lift Exp Word16 where+  type Plain Word16 = Word16+  lift = Exp . Const++instance Lift Exp Word32 where+  type Plain Word32 = Word32+  lift = Exp . Const++instance Lift Exp Word64 where+  type Plain Word64 = Word64+  lift = Exp . Const++instance Lift Exp CShort where+  type Plain CShort = CShort+  lift = Exp . Const++instance Lift Exp CUShort where+  type Plain CUShort = CUShort+  lift = Exp . Const++instance Lift Exp CInt where+  type Plain CInt = CInt+  lift = Exp . Const++instance Lift Exp CUInt where+  type Plain CUInt = CUInt+  lift = Exp . Const++instance Lift Exp CLong where+  type Plain CLong = CLong+  lift = Exp . Const++instance Lift Exp CULong where+  type Plain CULong = CULong+  lift = Exp . Const++instance Lift Exp CLLong where+  type Plain CLLong = CLLong+  lift = Exp . Const++instance Lift Exp CULLong where+  type Plain CULLong = CULLong+  lift = Exp . Const++instance Lift Exp Float where+  type Plain Float = Float+  lift = Exp . Const++instance Lift Exp Double where+  type Plain Double = Double+  lift = Exp . Const++instance Lift Exp CFloat where+  type Plain CFloat = CFloat+  lift = Exp . Const++instance Lift Exp CDouble where+  type Plain CDouble = CDouble+  lift = Exp . Const++instance Lift Exp Bool where+  type Plain Bool = Bool+  lift = Exp . Const++instance Lift Exp Char where+  type Plain Char = Char+  lift = Exp . Const++instance Lift Exp CChar where+  type Plain CChar = CChar+  lift = Exp . Const++instance Lift Exp CSChar where+  type Plain CSChar = CSChar+  lift = Exp . Const++instance Lift Exp CUChar where+  type Plain CUChar = CUChar+  lift = Exp . Const++-- Instances for tuples++instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b)) => Lift Exp (a, b) where+  type Plain (a, b) = (Plain a, Plain b)+  lift (a, b) = tup2 (lift a, lift b)++instance (Elt a, Elt b) => Unlift Exp (Exp a, Exp b) where+  unlift = untup2++instance (Lift Exp a, Lift Exp b, Lift Exp c,+          Elt (Plain a), Elt (Plain b), Elt (Plain c))+  => Lift Exp (a, b, c) where+  type Plain (a, b, c) = (Plain a, Plain b, Plain c)+  lift (a, b, c) = tup3 (lift a, lift b, lift c)++instance (Elt a, Elt b, Elt c) => Unlift Exp (Exp a, Exp b, Exp c) where+  unlift = untup3++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d))+  => Lift Exp (a, b, c, d) where+  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)+  lift (a, b, c, d) = tup4 (lift a, lift b, lift c, lift d)++instance (Elt a, Elt b, Elt c, Elt d) => Unlift Exp (Exp a, Exp b, Exp c, Exp d) where+  unlift = untup4++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e))+  => Lift Exp (a, b, c, d, e) where+  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)+  lift (a, b, c, d, e) = tup5 (lift a, lift b, lift c, lift d, lift e)++instance (Elt a, Elt b, Elt c, Elt d, Elt e)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e) where+  unlift = untup5++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f))+  => Lift Exp (a, b, c, d, e, f) where+  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)+  lift (a, b, c, d, e, f) = tup6 (lift a, lift b, lift c, lift d, lift e, lift f)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) where+  unlift = untup6++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),+          Elt (Plain g))+  => Lift Exp (a, b, c, d, e, f, g) where+  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)+  lift (a, b, c, d, e, f, g) = tup7 (lift a, lift b, lift c, lift d, lift e, lift f, lift g)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) where+  unlift = untup7++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g, Lift Exp h,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),+          Elt (Plain g), Elt (Plain h))+  => Lift Exp (a, b, c, d, e, f, g, h) where+  type Plain (a, b, c, d, e, f, g, h)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)+  lift (a, b, c, d, e, f, g, h)+    = tup8 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) where+  unlift = untup8++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,+          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),+          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i))+  => Lift Exp (a, b, c, d, e, f, g, h, i) where+  type Plain (a, b, c, d, e, f, g, h, i)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)+  lift (a, b, c, d, e, f, g, h, i)+    = tup9 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) where+  unlift = untup9++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,+          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i, Lift Exp j,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),+          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i), Elt (Plain j))+  => Lift Exp (a, b, c, d, e, f, g, h, i, j) where+  type Plain (a, b, c, d, e, f, g, h, i, j)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j)+  lift (a, b, c, d, e, f, g, h, i, j)+    = tup10 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j) where+  unlift = untup10++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,+          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),+          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k))+  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k)+  lift (a, b, c, d, e, f, g, h, i, j, k)+    = tup11 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k)++instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k) where+  unlift = untup11++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,+          Lift Exp g, Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k, Lift Exp l,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),+          Elt (Plain g), Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k), Elt (Plain l))+  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l)+  lift (a, b, c, d, e, f, g, h, i, j, k, l)+    = tup12 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift 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)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l) where+  unlift = untup12++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,+          Lift Exp g, Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k, Lift Exp l, Lift Exp m,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),+          Elt (Plain g), Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k), Elt (Plain l), Elt (Plain m))+  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m)+  lift (a, b, c, d, e, f, g, h, i, j, k, l, m)+    = tup13 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift 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)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m) where+  unlift = untup13++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,+          Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k, Lift Exp l, Lift Exp m, Lift Exp n,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f), Elt (Plain g),+          Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k), Elt (Plain l), Elt (Plain m), Elt (Plain n))+  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n)+  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+    = tup14 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift 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)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n) where+  unlift = untup14++instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,+          Lift Exp h, Lift Exp i, Lift Exp j, Lift Exp k, Lift Exp l, Lift Exp m, Lift Exp n, Lift Exp o,+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f), Elt (Plain g),+          Elt (Plain h), Elt (Plain i), Elt (Plain j), Elt (Plain k), Elt (Plain l), Elt (Plain m), Elt (Plain n), Elt (Plain o))+  => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n, Plain o)+  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+    = tup15 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift n, lift o)++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)+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o) where+  unlift = untup15++++-- Instances for Arrays class++--instance Lift Acc () where+--  type Plain () = ()+--  lift _ = Acc (Atuple NilAtup)++instance (Shape sh, Elt e) => Lift Acc (Array sh e) where+  type Plain (Array sh e) = Array sh e+  lift = Acc . Use++instance (Lift Acc a, Lift Acc b, Arrays (Plain a), Arrays (Plain b)) => Lift Acc (a, b) where+  type Plain (a, b) = (Plain a, Plain b)+  lift (a, b) = atup2 (lift a, lift b)++instance (Arrays a, Arrays b) => Unlift Acc (Acc a, Acc b) where+  unlift = unatup2++instance (Lift Acc a, Lift Acc b, Lift Acc c,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c))+  => Lift Acc (a, b, c) where+  type Plain (a, b, c) = (Plain a, Plain b, Plain c)+  lift (a, b, c) = atup3 (lift a, lift b, lift c)++instance (Arrays a, Arrays b, Arrays c) => Unlift Acc (Acc a, Acc b, Acc c) where+  unlift = unatup3++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d))+  => Lift Acc (a, b, c, d) where+  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)+  lift (a, b, c, d) = atup4 (lift a, lift b, lift c, lift d)++instance (Arrays a, Arrays b, Arrays c, Arrays d) => Unlift Acc (Acc a, Acc b, Acc c, Acc d) where+  unlift = unatup4++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e))+  => Lift Acc (a, b, c, d, e) where+  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)+  lift (a, b, c, d, e) = atup5 (lift a, lift b, lift c, lift d, lift e)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e) where+  unlift = unatup5++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f))+  => Lift Acc (a, b, c, d, e, f) where+  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)+  lift (a, b, c, d, e, f) = atup6 (lift a, lift b, lift c, lift d, lift e, lift f)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) where+  unlift = unatup6++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g))+  => Lift Acc (a, b, c, d, e, f, g) where+  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)+  lift (a, b, c, d, e, f, g) = atup7 (lift a, lift b, lift c, lift d, lift e, lift f, lift g)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) where+  unlift = unatup7++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g, Lift Acc h,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g), Arrays (Plain h))+  => Lift Acc (a, b, c, d, e, f, g, h) where+  type Plain (a, b, c, d, e, f, g, h)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)+  lift (a, b, c, d, e, f, g, h)+    = atup8 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) where+  unlift = unatup8++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,+          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),+          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i))+  => Lift Acc (a, b, c, d, e, f, g, h, i) where+  type Plain (a, b, c, d, e, f, g, h, i)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)+  lift (a, b, c, d, e, f, g, h, i)+    = atup9 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) where+  unlift = unatup9++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,+          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i, Lift Acc j,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),+          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j))+  => Lift Acc (a, b, c, d, e, f, g, h, i, j) where+  type Plain (a, b, c, d, e, f, g, h, i, j)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j)+  lift (a, b, c, d, e, f, g, h, i, j)+    = atup10 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j) where+  unlift = unatup10++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,+          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),+          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k))+  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k)+  lift (a, b, c, d, e, f, g, h, i, j, k)+    = atup11 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k)++instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k) where+  unlift = unatup11++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,+          Lift Acc g, Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k, Lift Acc l,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l))+  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l)+  lift (a, b, c, d, e, f, g, h, i, j, k, l)+    = atup12 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift 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)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l) where+  unlift = unatup12++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,+          Lift Acc g, Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k, Lift Acc l, Lift Acc m,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m))+  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m)+  lift (a, b, c, d, e, f, g, h, i, j, k, l, m)+    = atup13 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift 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)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m) where+  unlift = unatup13++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,+          Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k, Lift Acc l, Lift Acc m, Lift Acc n,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f), Arrays (Plain g),+          Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m), Arrays (Plain n))+  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n)+  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+    = atup14 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift 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)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n) where+  unlift = unatup14++instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,+          Lift Acc h, Lift Acc i, Lift Acc j, Lift Acc k, Lift Acc l, Lift Acc m, Lift Acc n, Lift Acc o,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f), Arrays (Plain g),+          Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m), Arrays (Plain n), Arrays (Plain o))+  => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n, Plain o)+  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+    = atup15 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift n, lift o)++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)+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o) where+  unlift = unatup15++{--+-- Instances for Seq++instance (Lift Seq a, Lift Seq b, Arrays (Plain a), Arrays (Plain b)) => Lift Seq (a, b) where+  type Plain (a, b) = (Plain a, Plain b)+  lift (a, b) = stup2 (lift a, lift b)++instance (Lift Seq a, Lift Seq b, Lift Seq c,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c))+  => Lift Seq (a, b, c) where+  type Plain (a, b, c) = (Plain a, Plain b, Plain c)+  lift (a, b, c) = stup3 (lift a, lift b, lift c)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d))+  => Lift Seq (a, b, c, d) where+  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)+  lift (a, b, c, d) = stup4 (lift a, lift b, lift c, lift d)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e))+  => Lift Seq (a, b, c, d, e) where+  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)+  lift (a, b, c, d, e) = stup5 (lift a, lift b, lift c, lift d, lift e)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f))+  => Lift Seq (a, b, c, d, e, f) where+  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)+  lift (a, b, c, d, e, f) = stup6 (lift a, lift b, lift c, lift d, lift e, lift f)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f, Lift Seq g,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g))+  => Lift Seq (a, b, c, d, e, f, g) where+  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)+  lift (a, b, c, d, e, f, g) = stup7 (lift a, lift b, lift c, lift d, lift e, lift f, lift g)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f, Lift Seq g, Lift Seq h,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g), Arrays (Plain h))+  => Lift Seq (a, b, c, d, e, f, g, h) where+  type Plain (a, b, c, d, e, f, g, h)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)+  lift (a, b, c, d, e, f, g, h)+    = stup8 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e,+          Lift Seq f, Lift Seq g, Lift Seq h, Lift Seq i,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),+          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i))+  => Lift Seq (a, b, c, d, e, f, g, h, i) where+  type Plain (a, b, c, d, e, f, g, h, i)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)+  lift (a, b, c, d, e, f, g, h, i)+    = stup9 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e,+          Lift Seq f, Lift Seq g, Lift Seq h, Lift Seq i, Lift Seq j,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),+          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j))+  => Lift Seq (a, b, c, d, e, f, g, h, i, j) where+  type Plain (a, b, c, d, e, f, g, h, i, j)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j)+  lift (a, b, c, d, e, f, g, h, i, j)+    = stup10 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e,+          Lift Seq f, Lift Seq g, Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),+          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k))+  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k)+  lift (a, b, c, d, e, f, g, h, i, j, k)+    = stup11 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f,+          Lift Seq g, Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k, Lift Seq l,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l))+  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l)+  lift (a, b, c, d, e, f, g, h, i, j, k, l)+    = stup12 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f,+          Lift Seq g, Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k, Lift Seq l, Lift Seq m,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),+          Arrays (Plain g), Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m))+  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m)+  lift (a, b, c, d, e, f, g, h, i, j, k, l, m)+    = stup13 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f, Lift Seq g,+          Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k, Lift Seq l, Lift Seq m, Lift Seq n,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f), Arrays (Plain g),+          Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m), Arrays (Plain n))+  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n)+  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+    = stup14 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift n)++instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f, Lift Seq g,+          Lift Seq h, Lift Seq i, Lift Seq j, Lift Seq k, Lift Seq l, Lift Seq m, Lift Seq n, Lift Seq o,+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f), Arrays (Plain g),+          Arrays (Plain h), Arrays (Plain i), Arrays (Plain j), Arrays (Plain k), Arrays (Plain l), Arrays (Plain m), Arrays (Plain n), Arrays (Plain o))+  => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i, Plain j, Plain k, Plain l, Plain m, Plain n, Plain o)+  lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+    = stup15 (lift a, lift b, lift c, lift d, lift e, lift f, lift g, lift h, lift i, lift j, lift k, lift l, lift m, lift n, lift o)+--}+
+ src/Data/Array/Accelerate/Prelude.hs view
@@ -0,0 +1,2392 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RebindableSyntax      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+-- |+-- Module      : Data.Array.Accelerate.Prelude+-- Copyright   : [2009..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+--               [2010..2011] Ben Lever+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Standard functions that are not part of the core set (directly represented in+-- the AST), but are instead implemented in terms of the core set.+--++module Data.Array.Accelerate.Prelude (++  -- * Element-wise operations+  indexed,+  imap,++  -- * Zipping+  zipWith3, zipWith4, zipWith5, zipWith6, zipWith7, zipWith8, zipWith9,+  izipWith, izipWith3, izipWith4, izipWith5, izipWith6, izipWith7, izipWith8, izipWith9,+  zip, zip3, zip4, zip5, zip6, zip7, zip8, zip9,++  -- * Unzipping+  unzip, unzip3, unzip4, unzip5, unzip6, unzip7, unzip8, unzip9,++  -- * Reductions+  foldAll, fold1All,++  -- ** Specialised folds+  all, any, and, or, sum, product, minimum, maximum,++  -- * Scans+  prescanl, postscanl, prescanr, postscanr,++  -- ** Segmented scans+  scanlSeg, scanl'Seg, scanl1Seg, prescanlSeg, postscanlSeg,+  scanrSeg, scanr'Seg, scanr1Seg, prescanrSeg, postscanrSeg,++  -- * Shape manipulation+  flatten,++  -- * Enumeration and filling+  fill, enumFromN, enumFromStepN,++  -- * Concatenation+  (++), concatOn,++  -- * Working with predicates+  -- ** Filtering+  filter,++  -- ** Scatter / Gather+  scatter, scatterIf,+  gather,  gatherIf,++  -- * Permutations+  reverse, transpose,+  reverseOn, transposeOn,++  -- * Extracting sub-vectors+  init, tail, take, drop, slit,+  initOn, tailOn, takeOn, dropOn, slitOn,++  -- * Controlling execution+  compute,++  -- * Flow control+  IfThenElse(..),++  -- ** Array-level+  (?|),++  -- ** Expression-level+  (?), caseof,++  -- * Scalar iteration+  iterate,++  -- * Scalar reduction+  sfoldl, -- sfoldr,++  -- * Lifting and unlifting+  Lift(..), Unlift(..),+  lift1, lift2, lift3, ilift1, ilift2, ilift3,++  -- ** Tuple construction and destruction+  fst, afst, snd, asnd, curry, uncurry,++  -- ** Index construction and destruction+  index0, index1, unindex1, index2, unindex2, index3, unindex3,++  -- * Array operations with a scalar result+  the, null, length,++  -- * Sequence operations+  -- fromSeq, fromSeqElems, fromSeqShapes, toSeqInner, toSeqOuter2, toSeqOuter3, generateSeq,++) where++-- avoid clashes with Prelude functions+--+import Control.Lens                                                 ( Lens', (&), (^.), (.~), (+~), (-~), lens, over )+import Data.Typeable                                                ( gcast )+import GHC.Base                                                     ( Constraint )+import Prelude                                                      ( (.), ($), Maybe(..), const, id, flip, undefined )+#if __GLASGOW_HASKELL__ == 800+import Prelude                                                      ( fail )+#endif++-- friends+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Sugar                            hiding ( (!), (!!), ignore, shape, reshape, size, intersect, toIndex, fromIndex )+import Data.Array.Accelerate.Language+import Data.Array.Accelerate.Lift+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.Classes.Eq+import Data.Array.Accelerate.Classes.FromIntegral+import Data.Array.Accelerate.Classes.Integral+import Data.Array.Accelerate.Classes.Num+import Data.Array.Accelerate.Classes.Ord++import Data.Array.Accelerate.Data.Bits++-- $setup+-- >>> import Data.Array.Accelerate+-- >>> import Data.Array.Accelerate.Interpreter+-- >>> :{+--   let runExp :: Elt e => Exp e -> e+--       runExp e = indexArray (run (unit e)) Z+-- :}++-- Element-wise operations+-- -----------------------++-- | Pair each element with its index+--+-- >>> let xs = fromList (Z:.5) [0..] :: Vector Float+-- >>> run $ indexed (use xs)+-- Vector (Z :. 5) [(Z :. 0,0.0),(Z :. 1,1.0),(Z :. 2,2.0),(Z :. 3,3.0),(Z :. 4,4.0)]+--+-- >>> let mat = fromList (Z:.3:.4) [0..] :: Matrix Float+-- >>> run $ indexed (use mat)+-- Matrix (Z :. 3 :. 4)+--   [ (Z :. 0 :. 0,0.0), (Z :. 0 :. 1,1.0),  (Z :. 0 :. 2,2.0),  (Z :. 0 :. 3,3.0),+--     (Z :. 1 :. 0,4.0), (Z :. 1 :. 1,5.0),  (Z :. 1 :. 2,6.0),  (Z :. 1 :. 3,7.0),+--     (Z :. 2 :. 0,8.0), (Z :. 2 :. 1,9.0), (Z :. 2 :. 2,10.0), (Z :. 2 :. 3,11.0)]+--+indexed :: (Shape sh, Elt a) => Acc (Array sh a) -> Acc (Array sh (sh, a))+indexed xs = zip (generate (shape xs) id) xs++-- | Apply a function to every element of an array and its index+--+imap :: (Shape sh, Elt a, Elt b)+     => (Exp sh -> Exp a -> Exp b)+     -> Acc (Array sh a)+     -> Acc (Array sh b)+imap f xs = zipWith f (generate (shape xs) id) xs+++-- | Zip three arrays with the given function, analogous to 'zipWith'.+--+zipWith3+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d)+    => (Exp a -> Exp b -> Exp c -> Exp d)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+zipWith3 f as bs cs+  = generate (shape as `intersect` shape bs `intersect` shape cs)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix))++-- | Zip four arrays with the given function, analogous to 'zipWith'.+--+zipWith4+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)+    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+zipWith4 f as bs cs ds+  = generate (shape as `intersect` shape bs `intersect`+              shape cs `intersect` shape ds)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix))++-- | Zip five arrays with the given function, analogous to 'zipWith'.+--+zipWith5+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+zipWith5 f as bs cs ds es+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix))++-- | Zip six arrays with the given function, analogous to 'zipWith'.+--+zipWith6+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+    -> Acc (Array sh g)+zipWith6 f as bs cs ds es fs+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix))++-- | Zip seven arrays with the given function, analogous to 'zipWith'.+--+zipWith7+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+    -> Acc (Array sh g)+    -> Acc (Array sh h)+zipWith7 f as bs cs ds es fs gs+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs `intersect` shape gs)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix))++-- | Zip eight arrays with the given function, analogous to 'zipWith'.+--+zipWith8+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+    -> Acc (Array sh g)+    -> Acc (Array sh h)+    -> Acc (Array sh i)+zipWith8 f as bs cs ds es fs gs hs+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs `intersect` shape gs+                       `intersect` shape hs)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix))++-- | Zip nine arrays with the given function, analogous to 'zipWith'.+--+zipWith9+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)+    => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+    -> Acc (Array sh g)+    -> Acc (Array sh h)+    -> Acc (Array sh i)+    -> Acc (Array sh j)+zipWith9 f as bs cs ds es fs gs hs is+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs `intersect` shape gs+                       `intersect` shape hs `intersect` shape is)+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix) (is ! ix))+++-- | Zip two arrays with a function that also takes the element index+--+izipWith+    :: (Shape sh, Elt a, Elt b, Elt c)+    => (Exp sh -> Exp a -> Exp b -> Exp c)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+izipWith f as bs+  = generate (shape as `intersect` shape bs)+             (\ix -> f ix (as ! ix) (bs ! ix))++-- | Zip three arrays with a function that also takes the element index,+-- analogous to 'izipWith'.+--+izipWith3+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d)+    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+izipWith3 f as bs cs+  = generate (shape as `intersect` shape bs `intersect` shape cs)+             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix))++-- | Zip four arrays with the given function that also takes the element index,+-- analogous to 'zipWith'.+--+izipWith4+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)+    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+izipWith4 f as bs cs ds+  = generate (shape as `intersect` shape bs `intersect`+              shape cs `intersect` shape ds)+             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix))++-- | Zip five arrays with the given function that also takes the element index,+-- analogous to 'zipWith'.+--+izipWith5+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+izipWith5 f as bs cs ds es+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es)+             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix))++-- | Zip six arrays with the given function that also takes the element index,+-- analogous to 'zipWith'.+--+izipWith6+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+    -> Acc (Array sh g)+izipWith6 f as bs cs ds es fs+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs)+             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix))++-- | Zip seven arrays with the given function that also takes the element+-- index, analogous to 'zipWith'.+--+izipWith7+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+    -> Acc (Array sh g)+    -> Acc (Array sh h)+izipWith7 f as bs cs ds es fs gs+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs `intersect` shape gs)+             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix))++-- | Zip eight arrays with the given function that also takes the element+-- index, analogous to 'zipWith'.+--+izipWith8+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+    -> Acc (Array sh g)+    -> Acc (Array sh h)+    -> Acc (Array sh i)+izipWith8 f as bs cs ds es fs gs hs+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs `intersect` shape gs+                       `intersect` shape hs)+             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix))++-- | Zip nine arrays with the given function that also takes the element index,+-- analogous to 'zipWith'.+--+izipWith9+    :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)+    => (Exp sh -> Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j)+    -> Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh c)+    -> Acc (Array sh d)+    -> Acc (Array sh e)+    -> Acc (Array sh f)+    -> Acc (Array sh g)+    -> Acc (Array sh h)+    -> Acc (Array sh i)+    -> Acc (Array sh j)+izipWith9 f as bs cs ds es fs gs hs is+  = generate (shape as `intersect` shape bs `intersect` shape cs+                       `intersect` shape ds `intersect` shape es+                       `intersect` shape fs `intersect` shape gs+                       `intersect` shape hs `intersect` shape is)+             (\ix -> f ix (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix) (is ! ix))+++-- | Combine the elements of two arrays pairwise. The shape of the result is the+-- intersection of the two argument shapes.+--+-- >>> let m1 = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> let m2 = fromList (Z:.10:.5) [0..] :: Matrix Float+-- >>> run $ zip (use m1) (use m2)+-- Matrix (Z :. 5 :. 5)+--   [   (0,0.0),   (1,1.0),   (2,2.0),   (3,3.0),   (4,4.0),+--      (10,5.0),  (11,6.0),  (12,7.0),  (13,8.0),  (14,9.0),+--     (20,10.0), (21,11.0), (22,12.0), (23,13.0), (24,14.0),+--     (30,15.0), (31,16.0), (32,17.0), (33,18.0), (34,19.0),+--     (40,20.0), (41,21.0), (42,22.0), (43,23.0), (44,24.0)]+--+zip :: (Shape sh, Elt a, Elt b)+    => Acc (Array sh a)+    -> Acc (Array sh b)+    -> Acc (Array sh (a, b))+zip = zipWith (curry lift)++-- | Take three arrays and return an array of triples, analogous to zip.+--+zip3 :: (Shape sh, Elt a, Elt b, Elt c)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh (a, b, c))+zip3 = zipWith3 (\a b c -> lift (a,b,c))++-- | Take four arrays and return an array of quadruples, analogous to zip.+--+zip4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh (a, b, c, d))+zip4 = zipWith4 (\a b c d -> lift (a,b,c,d))++-- | Take five arrays and return an array of five-tuples, analogous to zip.+--+zip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh (a, b, c, d, e))+zip5 = zipWith5 (\a b c d e -> lift (a,b,c,d,e))++-- | Take six arrays and return an array of six-tuples, analogous to zip.+--+zip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh f)+     -> Acc (Array sh (a, b, c, d, e, f))+zip6 = zipWith6 (\a b c d e f -> lift (a,b,c,d,e,f))++-- | Take seven arrays and return an array of seven-tuples, analogous to zip.+--+zip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh f)+     -> Acc (Array sh g)+     -> Acc (Array sh (a, b, c, d, e, f, g))+zip7 = zipWith7 (\a b c d e f g -> lift (a,b,c,d,e,f,g))++-- | Take seven arrays and return an array of seven-tuples, analogous to zip.+--+zip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh f)+     -> Acc (Array sh g)+     -> Acc (Array sh h)+     -> Acc (Array sh (a, b, c, d, e, f, g, h))+zip8 = zipWith8 (\a b c d e f g h -> lift (a,b,c,d,e,f,g,h))++-- | Take seven arrays and return an array of seven-tuples, analogous to zip.+--+zip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+     => Acc (Array sh a)+     -> Acc (Array sh b)+     -> Acc (Array sh c)+     -> Acc (Array sh d)+     -> Acc (Array sh e)+     -> Acc (Array sh f)+     -> Acc (Array sh g)+     -> Acc (Array sh h)+     -> Acc (Array sh i)+     -> Acc (Array sh (a, b, c, d, e, f, g, h, i))+zip9 = zipWith9 (\a b c d e f g h i -> lift (a,b,c,d,e,f,g,h,i))+++-- | The converse of 'zip', but the shape of the two results is identical to the+-- shape of the argument.+--+-- If the argument array is manifest in memory, 'unzip' is a no-op.+--+unzip :: (Shape sh, Elt a, Elt b)+      => Acc (Array sh (a, b))+      -> (Acc (Array sh a), Acc (Array sh b))+unzip arr = (map fst arr, map snd arr)++-- | Take an array of triples and return three arrays, analogous to 'unzip'.+--+unzip3 :: (Shape sh, Elt a, Elt b, Elt c)+       => Acc (Array sh (a, b, c))+       -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c))+unzip3 xs = (map get1 xs, map get2 xs, map get3 xs)+  where+    get1 x = let (a,_,_) = untup3 x in a+    get2 x = let (_,b,_) = untup3 x in b+    get3 x = let (_,_,c) = untup3 x in c+++-- | Take an array of quadruples and return four arrays, analogous to 'unzip'.+--+unzip4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d)+       => Acc (Array sh (a, b, c, d))+       -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d))+unzip4 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs)+  where+    get1 x = let (a,_,_,_) = untup4 x in a+    get2 x = let (_,b,_,_) = untup4 x in b+    get3 x = let (_,_,c,_) = untup4 x in c+    get4 x = let (_,_,_,d) = untup4 x in d++-- | Take an array of 5-tuples and return five arrays, analogous to 'unzip'.+--+unzip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)+       => Acc (Array sh (a, b, c, d, e))+       -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d), Acc (Array sh e))+unzip5 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs, map get5 xs)+  where+    get1 x = let (a,_,_,_,_) = untup5 x in a+    get2 x = let (_,b,_,_,_) = untup5 x in b+    get3 x = let (_,_,c,_,_) = untup5 x in c+    get4 x = let (_,_,_,d,_) = untup5 x in d+    get5 x = let (_,_,_,_,e) = untup5 x in e++-- | Take an array of 6-tuples and return six arrays, analogous to 'unzip'.+--+unzip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+       => Acc (Array sh (a, b, c, d, e, f))+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f))+unzip6 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs, map get5 xs, map get6 xs)+  where+    get1 x = let (a,_,_,_,_,_) = untup6 x in a+    get2 x = let (_,b,_,_,_,_) = untup6 x in b+    get3 x = let (_,_,c,_,_,_) = untup6 x in c+    get4 x = let (_,_,_,d,_,_) = untup6 x in d+    get5 x = let (_,_,_,_,e,_) = untup6 x in e+    get6 x = let (_,_,_,_,_,f) = untup6 x in f++-- | Take an array of 7-tuples and return seven arrays, analogous to 'unzip'.+--+unzip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+       => Acc (Array sh (a, b, c, d, e, f, g))+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)+          , Acc (Array sh g))+unzip7 xs = ( map get1 xs, map get2 xs, map get3 xs+            , map get4 xs, map get5 xs, map get6 xs+            , map get7 xs )+  where+    get1 x = let (a,_,_,_,_,_,_) = untup7 x in a+    get2 x = let (_,b,_,_,_,_,_) = untup7 x in b+    get3 x = let (_,_,c,_,_,_,_) = untup7 x in c+    get4 x = let (_,_,_,d,_,_,_) = untup7 x in d+    get5 x = let (_,_,_,_,e,_,_) = untup7 x in e+    get6 x = let (_,_,_,_,_,f,_) = untup7 x in f+    get7 x = let (_,_,_,_,_,_,g) = untup7 x in g++-- | Take an array of 8-tuples and return eight arrays, analogous to 'unzip'.+--+unzip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+       => Acc (Array sh (a, b, c, d, e, f, g, h))+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)+          , Acc (Array sh g), Acc (Array sh h) )+unzip8 xs = ( map get1 xs, map get2 xs, map get3 xs+            , map get4 xs, map get5 xs, map get6 xs+            , map get7 xs, map get8 xs )+  where+    get1 x = let (a,_,_,_,_,_,_,_) = untup8 x in a+    get2 x = let (_,b,_,_,_,_,_,_) = untup8 x in b+    get3 x = let (_,_,c,_,_,_,_,_) = untup8 x in c+    get4 x = let (_,_,_,d,_,_,_,_) = untup8 x in d+    get5 x = let (_,_,_,_,e,_,_,_) = untup8 x in e+    get6 x = let (_,_,_,_,_,f,_,_) = untup8 x in f+    get7 x = let (_,_,_,_,_,_,g,_) = untup8 x in g+    get8 x = let (_,_,_,_,_,_,_,h) = untup8 x in h++-- | Take an array of 8-tuples and return eight arrays, analogous to 'unzip'.+--+unzip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+       => Acc (Array sh (a, b, c, d, e, f, g, h, i))+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)+          , Acc (Array sh g), Acc (Array sh h), Acc (Array sh i))+unzip9 xs = ( map get1 xs, map get2 xs, map get3 xs+            , map get4 xs, map get5 xs, map get6 xs+            , map get7 xs, map get8 xs, map get9 xs )+  where+    get1 x = let (a,_,_,_,_,_,_,_,_) = untup9 x in a+    get2 x = let (_,b,_,_,_,_,_,_,_) = untup9 x in b+    get3 x = let (_,_,c,_,_,_,_,_,_) = untup9 x in c+    get4 x = let (_,_,_,d,_,_,_,_,_) = untup9 x in d+    get5 x = let (_,_,_,_,e,_,_,_,_) = untup9 x in e+    get6 x = let (_,_,_,_,_,f,_,_,_) = untup9 x in f+    get7 x = let (_,_,_,_,_,_,g,_,_) = untup9 x in g+    get8 x = let (_,_,_,_,_,_,_,h,_) = untup9 x in h+    get9 x = let (_,_,_,_,_,_,_,_,i) = untup9 x in i+++-- Reductions+-- ----------++-- | Reduction of an array of arbitrary rank to a single scalar value. The first+-- argument needs to be an /associative/ function to enable efficient parallel+-- implementation. The initial element does not need to be an identity element.+--+-- >>> let vec = fromList (Z:.10) [0..] :: Vector Float+-- >>> run $ foldAll (+) 42 (use vec)+-- Scalar Z [87.0]+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Float+-- >>> run $ foldAll (+) 0 (use mat)+-- Scalar Z [1225.0]+--+foldAll+    :: (Shape sh, Elt a)+    => (Exp a -> Exp a -> Exp a)+    -> Exp a+    -> Acc (Array sh a)+    -> Acc (Scalar a)+foldAll f e arr = fold f e (flatten arr)++-- | Variant of 'foldAll' that requires the reduced array to be non-empty and+-- does not need a default value. The first argument must be an /associative/+-- function.+--+fold1All+    :: (Shape sh, Elt a)+    => (Exp a -> Exp a -> Exp a)+    -> Acc (Array sh a)+    -> Acc (Scalar a)+fold1All f arr = fold1 f (flatten arr)+++-- Specialised reductions+-- ----------------------+--+-- Leave the results of these as scalar arrays to make it clear that these are+-- array computations, and thus can not be nested.++-- | Check if all elements along the innermost dimension satisfy a predicate.+--+-- >>> let mat = fromList (Z :. 4 :. 10) [1,2,3,4,5,6,7,8,9,10,1,1,1,1,1,2,2,2,2,2,2,4,6,8,10,12,14,16,18,20,1,3,5,7,9,11,13,15,17,19] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 4 :. 10)+--   [ 1, 2, 3, 4,  5,  6,  7,  8,  9, 10,+--     1, 1, 1, 1,  1,  2,  2,  2,  2,  2,+--     2, 4, 6, 8, 10, 12, 14, 16, 18, 20,+--     1, 3, 5, 7,  9, 11, 13, 15, 17, 19]+--+-- >>> run $ all even (use mat)+-- Vector (Z :. 4) [False,False,True,False]+--+all :: (Shape sh, Elt e)+    => (Exp e -> Exp Bool)+    -> Acc (Array (sh:.Int) e)+    -> Acc (Array sh Bool)+all f = and . map f++-- | Check if any element along the innermost dimension satisfies the predicate.+--+-- >>> let mat = fromList (Z :. 4 :. 10) [1,2,3,4,5,6,7,8,9,10,1,1,1,1,1,2,2,2,2,2,2,4,6,8,10,12,14,16,18,20,1,3,5,7,9,11,13,15,17,19] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 4 :. 10)+--   [ 1, 2, 3, 4,  5,  6,  7,  8,  9, 10,+--     1, 1, 1, 1,  1,  2,  2,  2,  2,  2,+--     2, 4, 6, 8, 10, 12, 14, 16, 18, 20,+--     1, 3, 5, 7,  9, 11, 13, 15, 17, 19]+--+-- >>> run $ any even (use mat)+-- Vector (Z :. 4) [True,True,True,False]+--+any :: (Shape sh, Elt e)+    => (Exp e -> Exp Bool)+    -> Acc (Array (sh:.Int) e)+    -> Acc (Array sh Bool)+any f = or . map f++-- | Check if all elements along the innermost dimension are 'True'.+--+and :: Shape sh+    => Acc (Array (sh:.Int) Bool)+    -> Acc (Array sh Bool)+and = fold (&&) (constant True)++-- | Check if any element along the innermost dimension is 'True'.+--+or :: Shape sh+   => Acc (Array (sh:.Int) Bool)+   -> Acc (Array sh Bool)+or = fold (||) (constant False)++-- | Compute the sum of elements along the innermost dimension of the array. To+-- find the sum of the entire array, 'flatten' it first.+--+-- >>> let mat = fromList (Z:.2:.5) [0..] :: Matrix Int+-- >>> run $ sum (use mat)+-- Vector (Z :. 2) [10,35]+--+sum :: (Shape sh, Num e)+    => Acc (Array (sh:.Int) e)+    -> Acc (Array sh e)+sum = fold (+) 0++-- | Compute the product of the elements along the innermost dimension of the+-- array. To find the product of the entire array, 'flatten' it first.+--+-- >>> let mat = fromList (Z:.2:.5) [0..] :: Matrix Int+-- >>> run $ product (use mat)+-- Vector (Z :. 2) [0,15120]+--+product+    :: (Shape sh, Num e)+    => Acc (Array (sh:.Int) e)+    -> Acc (Array sh e)+product = fold (*) 1++-- | Yield the minimum element along the innermost dimension of the array. To+-- find find the minimum element of the entire array, 'flatten' it first.+--+-- The array must not be empty. See also 'fold1'.+--+-- >>> let mat = fromList (Z :. 3 :. 4) [1,4,3,8, 0,2,8,4, 7,9,8,8] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 3 :. 4)+--   [ 1, 4, 3, 8,+--     0, 2, 8, 4,+--     7, 9, 8, 8]+--+-- >>> run $ minimum (use mat)+-- Vector (Z :. 3) [1,0,7]+--+minimum+    :: (Shape sh, Ord e)+    => Acc (Array (sh:.Int) e)+    -> Acc (Array sh e)+minimum = fold1 min++-- | Yield the maximum element along the innermost dimension of the array. To+-- find the maximum element of the entire array, 'flatten' it first.+--+-- The array must not be empty. See also 'fold1'.+--+-- >>> let mat = fromList (Z :. 3 :. 4) [1,4,3,8, 0,2,8,4, 7,9,8,8] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 3 :. 4)+--   [ 1, 4, 3, 8,+--     0, 2, 8, 4,+--     7, 9, 8, 8]+--+-- >>> run $ maximum (use mat)+-- Vector (Z :. 3) [8,8,9]+--+maximum+    :: (Shape sh, Ord e)+    => Acc (Array (sh:.Int) e)+    -> Acc (Array sh e)+maximum = fold1 max+++-- Composite scans+-- ---------------++-- | Left-to-right pre-scan (aka exclusive scan). As for 'scan', the first+-- argument must be an /associative/ function. Denotationally, we have:+--+-- > prescanl f e = afst . scanl' f e+--+-- >>> let vec = fromList (Z:.10) [1..10] :: Vector Int+-- >>> run $ prescanl (+) 0 (use vec)+-- Vector (Z :. 10) [0,1,3,6,10,15,21,28,36,45]+--+prescanl+    :: (Shape sh, Elt a)+    => (Exp a -> Exp a -> Exp a)+    -> Exp a+    -> Acc (Array (sh:.Int) a)+    -> Acc (Array (sh:.Int) a)+prescanl f e = afst . scanl' f e++-- | Left-to-right post-scan, a variant of 'scanl1' with an initial value. As+-- with 'scanl1', the array must not be empty. Denotationally, we have:+--+-- > postscanl f e = map (e `f`) . scanl1 f+--+-- >>> let vec = fromList (Z:.10) [1..10] :: Vector Int+-- >>> run $ postscanl (+) 42 (use vec)+-- Vector (Z :. 10) [43,45,48,52,57,63,70,78,87,97]+--+postscanl+    :: (Shape sh, Elt a)+    => (Exp a -> Exp a -> Exp a)+    -> Exp a+    -> Acc (Array (sh:.Int) a)+    -> Acc (Array (sh:.Int) a)+postscanl f e = map (e `f`) . scanl1 f++-- | Right-to-left pre-scan (aka exclusive scan). As for 'scan', the first+-- argument must be an /associative/ function. Denotationally, we have:+--+-- > prescanr f e = afst . scanr' f e+--+prescanr+    :: (Shape sh, Elt a)+    => (Exp a -> Exp a -> Exp a)+    -> Exp a+    -> Acc (Array (sh:.Int) a)+    -> Acc (Array (sh:.Int) a)+prescanr f e = afst . scanr' f e++-- | Right-to-left postscan, a variant of 'scanr1' with an initial value.+-- Denotationally, we have:+--+-- > postscanr f e = map (e `f`) . scanr1 f+--+postscanr+    :: (Shape sh, Elt a)+    => (Exp a -> Exp a -> Exp a)+    -> Exp a+    -> Acc (Array (sh:.Int) a)+    -> Acc (Array (sh:.Int) a)+postscanr f e = map (`f` e) . scanr1 f+++-- Segmented scans+-- ---------------++-- | Segmented version of 'scanl' along the innermost dimension of an array. The+-- innermost dimension must have at least as many elements as the sum of the+-- segment descriptor.+--+-- >>> let seg = fromList (Z:.4) [1,4,0,3] :: Segments Int+-- >>> seg+-- Vector (Z :. 4) [1,4,0,3]+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ scanlSeg (+) 0 (use mat) (use seg)+-- Matrix (Z :. 5 :. 12)+--   [ 0,  0, 0,  1,  3,   6,  10, 0, 0,  5, 11,  18,+--     0, 10, 0, 11, 23,  36,  50, 0, 0, 15, 31,  48,+--     0, 20, 0, 21, 43,  66,  90, 0, 0, 25, 51,  78,+--     0, 30, 0, 31, 63,  96, 130, 0, 0, 35, 71, 108,+--     0, 40, 0, 41, 83, 126, 170, 0, 0, 45, 91, 138]+--+scanlSeg+    :: forall sh e i. (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Exp e+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e)+scanlSeg f z arr seg =+  if null arr || null flags+    then fill (lift (sh:.sz + length seg)) z+    else scanl1Seg f arr' seg'+  where+    sh :. sz    = unlift (shape arr) :: Exp sh :. Exp Int++    -- Segmented exclusive scan is implemented by first injecting the seed+    -- element at the head of each segment, and then performing a segmented+    -- inclusive scan.+    --+    -- This is done by creating a creating a vector entirely of the seed+    -- element, and overlaying the input data in all places other than at the+    -- start of a segment.+    --+    seg'        = map (+1) seg+    arr'        = permute const+                          (fill (lift (sh :. sz + length seg)) z)+                          (\ix -> let sx :. i = unlift ix :: Exp sh :. Exp Int+                                  in  lift (sx :. i + fromIntegral (inc ! index1 i)))+                          (take (length flags) arr)++    -- Each element in the segments must be shifted to the right one additional+    -- place for each successive segment, to make room for the seed element.+    -- Here, we make use of the fact that the vector returned by 'mkHeadFlags'+    -- contains non-unit entries, which indicate zero length segments.+    --+    flags       = mkHeadFlags seg+    inc         = scanl1 (+) flags+++-- | Segmented version of 'scanl'' along the innermost dimension of an array. The+-- innermost dimension must have at least as many elements as the sum of the+-- segment descriptor.+--+-- The first element of the resulting tuple is a vector of scanned values. The+-- second element is a vector of segment scan totals and has the same size as+-- the segment vector.+--+-- >>> let seg = fromList (Z:.4) [1,4,0,3] :: Segments Int+-- >>> seg+-- Vector (Z :. 4) [1,4,0,3]+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> let (res,sums) = run $ scanl'Seg (+) 0 (use mat) (use seg)+-- >>> res+-- Matrix (Z :. 5 :. 8)+--   [ 0, 0,  1,  3,   6, 0,  5, 11,+--     0, 0, 11, 23,  36, 0, 15, 31,+--     0, 0, 21, 43,  66, 0, 25, 51,+--     0, 0, 31, 63,  96, 0, 35, 71,+--     0, 0, 41, 83, 126, 0, 45, 91]+-- >>> sums+-- Matrix (Z :. 5 :. 4)+--   [  0,  10, 0,  18,+--     10,  50, 0,  48,+--     20,  90, 0,  78,+--     30, 130, 0, 108,+--     40, 170, 0, 138]+--+scanl'Seg+    :: forall sh e i. (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Exp e+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e, Array (sh:.Int) e)+scanl'Seg f z arr seg =+  if null arr+    then lift (arr,  fill (lift (indexTail (shape arr) :. length seg)) z)+    else lift (body, sums)+  where+    -- Segmented scan' is implemented by deconstructing a segmented exclusive+    -- scan, to separate the final value and scan body.+    --+    -- TLM: Segmented scans, and this version in particular, expend a lot of+    --      effort scanning flag arrays. On inspection it appears that several+    --      of these operations are duplicated, but this will not be picked up+    --      by sharing _observation_. Perhaps a global CSE-style pass would be+    --      beneficial.+    --+    arr'        = scanlSeg f z arr seg++    -- Extract the final reduction value for each segment, which is at the last+    -- index of each segment.+    --+    seg'        = map (+1) seg+    tails       = zipWith (+) seg $ prescanl (+) 0 seg'+    sums        = backpermute+                    (lift (indexTail (shape arr') :. length seg))+                    (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int+                            in  lift (sz :. fromIntegral (tails ! index1 i)))+                    arr'++    -- Slice out the body of each segment.+    --+    -- Build a head-flags representation based on the original segment+    -- descriptor. This contains the target length of each of the body segments,+    -- which is one fewer element than the actual bodies stored in arr'. Thus,+    -- the flags align with the last element of each body section, and when+    -- scanned, this element will be incremented over.+    --+    offset      = scanl1 (+) seg+    inc         = scanl1 (+)+                $ permute (+) (fill (index1 $ size arr + 1) 0)+                              (\ix -> index1' $ offset ! ix)+                              (fill (shape seg) (1 :: Exp i))++    len         = offset ! index1 (length offset - 1)+    body        = backpermute+                    (lift (indexTail (shape arr) :. fromIntegral len))+                    (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int+                            in  lift (sz :. i + fromIntegral (inc ! index1 i)))+                    arr'+++-- | Segmented version of 'scanl1' along the innermost dimension.+--+-- As with 'scanl1', the total number of elements considered, in this case given+-- by the 'sum' of segment descriptor, must not be zero. The input vector must+-- contain at least this many elements.+--+-- Zero length segments are allowed, and the behaviour is as if those entries+-- were not present in the segment descriptor; that is:+--+-- > scanl1Seg f xs [n,0,0] == scanl1Seg f xs [n]   where n /= 0+--+-- >>> let seg = fromList (Z:.4) [1,4,0,3] :: Segments Int+-- >>> seg+-- Vector (Z :. 4) [1,4,0,3]+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ scanl1Seg (+) (use mat) (use seg)+-- Matrix (Z :. 5 :. 8)+--   [  0,  1,  3,   6,  10,  5, 11,  18,+--     10, 11, 23,  36,  50, 15, 31,  48,+--     20, 21, 43,  66,  90, 25, 51,  78,+--     30, 31, 63,  96, 130, 35, 71, 108,+--     40, 41, 83, 126, 170, 45, 91, 138]+--+scanl1Seg+    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e)+scanl1Seg f arr seg+  = map snd+  . scanl1 (segmented f)+  $ zip (replicate (lift (indexTail (shape arr) :. All)) (mkHeadFlags seg)) arr++-- |Segmented version of 'prescanl'.+--+prescanlSeg+    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Exp e+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e)+prescanlSeg f e vec seg+  = afst+  $ scanl'Seg f e vec seg++-- |Segmented version of 'postscanl'.+--+postscanlSeg+    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Exp e+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e)+postscanlSeg f e vec seg+  = map (f e)+  $ scanl1Seg f vec seg++-- | Segmented version of 'scanr' along the innermost dimension of an array. The+-- innermost dimension must have at least as many elements as the sum of the+-- segment descriptor.+--+-- >>> let seg = fromList (Z:.4) [1,4,0,3] :: Segments Int+-- >>> seg+-- Vector (Z :. 4) [1,4,0,3]+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ scanrSeg (+) 0 (use mat) (use seg)+-- Matrix (Z :. 5 :. 12)+--   [  2, 0,  18,  15, 11,  6, 0, 0,  24, 17,  9, 0,+--     12, 0,  58,  45, 31, 16, 0, 0,  54, 37, 19, 0,+--     22, 0,  98,  75, 51, 26, 0, 0,  84, 57, 29, 0,+--     32, 0, 138, 105, 71, 36, 0, 0, 114, 77, 39, 0,+--     42, 0, 178, 135, 91, 46, 0, 0, 144, 97, 49, 0]+--+scanrSeg+    :: forall sh e i. (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Exp e+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e)+scanrSeg f z arr seg =+  if null arr || null flags+    then fill (lift (sh :. sz + length seg)) z+    else scanr1Seg f arr' seg'+  where+    sh :. sz    = unlift (shape arr) :: Exp sh :. Exp Int++    -- Using technique described for 'scanlSeg', where we intersperse the array+    -- with the seed element at the start of each segment, and then perform an+    -- inclusive segmented scan.+    --+    flags       = mkHeadFlags seg+    inc         = scanl1 (+) flags++    seg'        = map (+1) seg+    arr'        = permute const+                          (fill (lift (sh :. sz + length seg)) z)+                          (\ix -> let sx :. i = unlift ix :: Exp sh :. Exp Int+                                  in  lift (sx :. i + fromIntegral (inc ! index1 i) - 1))+                          (drop (sz - length flags) arr)+++-- | Segmented version of 'scanr''.+--+-- >>> let seg = fromList (Z:.4) [1,4,0,3] :: Segments Int+-- >>> seg+-- Vector (Z :. 4) [1,4,0,3]+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> let (res,sums) = run $ scanr'Seg (+) 0 (use mat) (use seg)+-- >>> res+-- Matrix (Z :. 5 :. 8)+--   [ 0,  15, 11,  6, 0, 17,  9, 0,+--     0,  45, 31, 16, 0, 37, 19, 0,+--     0,  75, 51, 26, 0, 57, 29, 0,+--     0, 105, 71, 36, 0, 77, 39, 0,+--     0, 135, 91, 46, 0, 97, 49, 0]+-- >>> sums+-- Matrix (Z :. 5 :. 4)+--   [  2,  18, 0,  24,+--     12,  58, 0,  54,+--     22,  98, 0,  84,+--     32, 138, 0, 114,+--     42, 178, 0, 144]+--+scanr'Seg+    :: forall sh e i. (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Exp e+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e, Array (sh:.Int) e)+scanr'Seg f z arr seg =+  if null arr+    then lift (arr,  fill (lift (indexTail (shape arr) :. length seg)) z)+    else lift (body, sums)+  where+    -- Using technique described for scanl'Seg+    --+    arr'        = scanrSeg f z arr seg++    -- reduction values+    seg'        = map (+1) seg+    heads       = prescanl (+) 0 seg'+    sums        = backpermute+                    (lift (indexTail (shape arr') :. length seg))+                    (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int+                            in  lift (sz :. fromIntegral (heads ! index1 i)))+                    arr'++    -- body segments+    flags       = mkHeadFlags seg+    inc         = scanl1 (+) flags+    body        = backpermute+                    (lift (indexTail (shape arr) :. indexHead (shape flags)))+                    (\ix -> let sz:.i = unlift ix :: Exp sh :. Exp Int+                            in  lift (sz :. i + fromIntegral (inc ! index1 i)))+                    arr'+++-- | Segmented version of 'scanr1'.+--+-- >>> let seg = fromList (Z:.4) [1,4,0,3] :: Segments Int+-- >>> seg+-- Vector (Z :. 4) [1,4,0,3]+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ scanr1Seg (+) (use mat) (use seg)+-- Matrix (Z :. 5 :. 8)+--   [  0,  10,   9,  7,  4,  18, 13,  7,+--     10,  50,  39, 27, 14,  48, 33, 17,+--     20,  90,  69, 47, 24,  78, 53, 27,+--     30, 130,  99, 67, 34, 108, 73, 37,+--     40, 170, 129, 87, 44, 138, 93, 47]+--+scanr1Seg+    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e)+scanr1Seg f arr seg+  = map snd+  . scanr1 (flip (segmented f))+  $ zip (replicate (lift (indexTail (shape arr) :. All)) (mkTailFlags seg)) arr+++-- |Segmented version of 'prescanr'.+--+prescanrSeg+    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Exp e+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e)+prescanrSeg f e vec seg+  = afst+  $ scanr'Seg f e vec seg++-- |Segmented version of 'postscanr'.+--+postscanrSeg+    :: (Shape sh, Slice sh, Elt e, Integral i, Bits i, FromIntegral i Int)+    => (Exp e -> Exp e -> Exp e)+    -> Exp e+    -> Acc (Array (sh:.Int) e)+    -> Acc (Segments i)+    -> Acc (Array (sh:.Int) e)+postscanrSeg f e vec seg+  = map (f e)+  $ scanr1Seg f vec seg+++-- Segmented scan helpers+-- ----------------------++-- |Compute head flags vector from segment vector for left-scans.+--+-- The vector will be full of zeros in the body of a segment, and non-zero+-- otherwise. The "flag" value, if greater than one, indicates that several+-- empty segments are represented by this single flag entry. This is additional+-- data is used by exclusive segmented scan.+--+mkHeadFlags+    :: (Integral i, FromIntegral i Int)+    => Acc (Segments i)+    -> Acc (Segments i)+mkHeadFlags seg+  = init+  $ permute (+) zeros (\ix -> index1' (offset ! ix)) ones+  where+    (offset, len)       = unlift (scanl' (+) 0 seg)+    zeros               = fill (index1' $ the len + 1) 0+    ones                = fill (index1  $ size offset) 1++-- |Compute tail flags vector from segment vector for right-scans. That is, the+-- flag is placed at the last place in each segment.+--+mkTailFlags+    :: (Integral i, FromIntegral i Int)+    => Acc (Segments i)+    -> Acc (Segments i)+mkTailFlags seg+  = init+  $ permute (+) zeros (\ix -> index1' (the len - 1 - offset ! ix)) ones+  where+    (offset, len)       = unlift (scanr' (+) 0 seg)+    zeros               = fill (index1' $ the len + 1) 0+    ones                = fill (index1  $ size offset) 1++-- |Construct a segmented version of a function from a non-segmented version.+-- The segmented apply operates on a head-flag value tuple, and follows the+-- procedure of Sengupta et. al.+--+segmented+    :: (Elt e, Num i, Bits i)+    => (Exp e -> Exp e -> Exp e)+    -> Exp (i, e)+    -> Exp (i, e)+    -> Exp (i, e)+segmented f a b =+  let (aF, aV) = unlift a+      (bF, bV) = unlift b+  in+  lift (aF .|. bF, bF /= 0 ? (bV, f aV bV))++-- |Index construction and destruction generalised to integral types.+--+-- We generalise the segment descriptor to integral types because some+-- architectures, such as GPUs, have poor performance for 64-bit types. So,+-- there is a tension between performance and requiring 64-bit indices for some+-- applications, and we would not like to restrict ourselves to either one.+--+-- As we don't yet support non-Int dimensions in shapes, we will need to convert+-- back to concrete Int. However, don't put these generalised forms into the+-- base library, because it results in too many ambiguity errors.+--+index1' ::  (Integral i, FromIntegral i Int) => Exp i -> Exp DIM1+index1' i = lift (Z :. fromIntegral i)+++-- Reshaping of arrays+-- -------------------++-- | Flatten the given array of arbitrary dimension into a one-dimensional+-- vector. As with 'reshape', this operation performs no work.+--+flatten :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Acc (Vector e)+flatten a+  | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM1)+  = a+flatten a+  = reshape (index1 (size a)) a+++-- Enumeration and filling+-- -----------------------++-- | Create an array where all elements are the same value.+--+-- >>> run $ fill (constant (Z:.10)) 0 :: Vector Float+-- Vector (Z :. 10) [0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0]+--+fill :: (Shape sh, Elt e) => Exp sh -> Exp e -> Acc (Array sh e)+fill sh c = generate sh (const c)++-- | Create an array of the given shape containing the values @x@, @x+1@, etc.+-- (in row-major order).+--+-- >>> run $ enumFromN (constant (Z:.5:.10)) 0 :: Matrix Int+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+enumFromN+    :: (Shape sh, Num e, FromIntegral Int e)+    => Exp sh+    -> Exp e+    -> Acc (Array sh e)+enumFromN sh x = enumFromStepN sh x 1++-- | Create an array of the given shape containing the values @x@, @x+y@,+-- @x+y+y@ etc. (in row-major order).+--+-- >>> run $ enumFromStepN (constant (Z:.5:.10)) 0 0.5 :: Matrix Float+-- Matrix (Z :. 5 :. 10)+--   [  0.0,  0.5,  1.0,  1.5,  2.0,  2.5,  3.0,  3.5,  4.0,  4.5,+--      5.0,  5.5,  6.0,  6.5,  7.0,  7.5,  8.0,  8.5,  9.0,  9.5,+--     10.0, 10.5, 11.0, 11.5, 12.0, 12.5, 13.0, 13.5, 14.0, 14.5,+--     15.0, 15.5, 16.0, 16.5, 17.0, 17.5, 18.0, 18.5, 19.0, 19.5,+--     20.0, 20.5, 21.0, 21.5, 22.0, 22.5, 23.0, 23.5, 24.0, 24.5]+--+enumFromStepN+    :: (Shape sh, Num e, FromIntegral Int e)+    => Exp sh+    -> Exp e              -- ^ x: start+    -> Exp e              -- ^ y: step+    -> Acc (Array sh e)+enumFromStepN sh x y+  = reshape sh+  $ generate (index1 $ shapeSize sh)+             (\ix -> (fromIntegral (unindex1 ix :: Exp Int) * y) + x)++-- Concatenation+-- -------------++-- | Concatenate innermost component of two arrays. The extent of the lower+--   dimensional component is the intersection of the two arrays.+--+-- >>> let m1 = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> m1+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> let m2 = fromList (Z:.10:.3) [0..] :: Matrix Int+-- >>> m2+-- Matrix (Z :. 10 :. 3)+--   [  0,  1,  2,+--      3,  4,  5,+--      6,  7,  8,+--      9, 10, 11,+--     12, 13, 14,+--     15, 16, 17,+--     18, 19, 20,+--     21, 22, 23,+--     24, 25, 26,+--     27, 28, 29]+--+-- >>> run $ use m1 ++ use m2+-- Matrix (Z :. 5 :. 13)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,  0,  1,  2,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,  3,  4,  5,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,  6,  7,  8,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,  9, 10, 11,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 12, 13, 14]+--+infixr 5 +++(++) :: forall sh e. (Slice sh, Shape sh, Elt e)+     => Acc (Array (sh :. Int) e)+     -> Acc (Array (sh :. Int) e)+     -> Acc (Array (sh :. Int) e)+(++) = concatOn _1+++-- | Generalised version of '(++)' where the argument 'Lens'' specifies which+-- dimension to concatenate along.+--+-- Appropriate lenses are available from <https://hackage.haskell.org/package/lens-accelerate lens-accelerate>.+--+-- >>> let m1 = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> m1+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> let m2 = fromList (Z:.10:.5) [0..] :: Matrix Int+-- >>> m2+-- Matrix (Z :. 10 :. 5)+--   [  0,  1,  2,  3,  4,+--      5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14,+--     15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24,+--     25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34,+--     35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44,+--     45, 46, 47, 48, 49]+--+-- >>> run $ concatOn _1 (use m1) (use m2)+-- Matrix (Z :. 5 :. 15)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,  0,  1,  2,  3,  4,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,  5,  6,  7,  8,  9,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 10, 11, 12, 13, 14,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 15, 16, 17, 18, 19,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 20, 21, 22, 23, 24]+--+-- >>> run $ concatOn _2 (use m1) (use m2)+-- Matrix (Z :. 15 :. 5)+--   [  0,  1,  2,  3,  4,+--     10, 11, 12, 13, 14,+--     20, 21, 22, 23, 24,+--     30, 31, 32, 33, 34,+--     40, 41, 42, 43, 44,+--      0,  1,  2,  3,  4,+--      5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14,+--     15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24,+--     25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34,+--     35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44,+--     45, 46, 47, 48, 49]+--+concatOn+    :: (Shape sh, Elt e)+    => Lens' (Exp sh) (Exp Int)+    -> Acc (Array sh e)+    -> Acc (Array sh e)+    -> Acc (Array sh e)+concatOn dim xs ys =+  let+      shx   = shape xs+      shy   = shape ys+      m     = shx ^. dim+      n     = shy ^. dim+      shx'  = shx & dim .~ m+n+      shy'  = shy & dim .~ m+n+  in+  generate (shx' `intersect` shy')+           (\ix -> let i = ix ^. dim in+                   if  i < m then xs ! ix+                             else ys ! (ix & dim -~ m))++-- TLM: If we have something like (concat . split) then the source array will+--      have two use sites, but is actually safe (and better) to inline.+++-- Filtering+-- ---------++-- | Drop elements that do not satisfy the predicate. Returns the elements which+-- pass the predicate, together with a segment descriptor indicating how many+-- elements along each outer dimension were valid.+--+-- >>> let vec = fromList (Z :. 10) [1..10] :: Vector Int+-- >>> vec+-- Vector (Z :. 10) [1,2,3,4,5,6,7,8,9,10]+--+-- >>> run $ filter even (use vec)+-- (Vector (Z :. 5) [2,4,6,8,10],Scalar Z [5])+--+-- >>> let mat = fromList (Z :. 4 :. 10) [1,2,3,4,5,6,7,8,9,10,1,1,1,1,1,2,2,2,2,2,2,4,6,8,10,12,14,16,18,20,1,3,5,7,9,11,13,15,17,19] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 4 :. 10)+--   [ 1, 2, 3, 4,  5,  6,  7,  8,  9, 10,+--     1, 1, 1, 1,  1,  2,  2,  2,  2,  2,+--     2, 4, 6, 8, 10, 12, 14, 16, 18, 20,+--     1, 3, 5, 7,  9, 11, 13, 15, 17, 19]+--+-- >>> run $ filter odd (use mat)+-- (Vector (Z :. 20) [1,3,5,7,9,1,1,1,1,1,1,3,5,7,9,11,13,15,17,19],Vector (Z :. 4) [5,5,0,10])+--+filter :: forall sh e. (Shape sh, Slice sh, Elt e)+       => (Exp e -> Exp Bool)+       -> Acc (Array (sh:.Int) e)+       -> Acc (Vector e, Array sh Int)+filter p arr+  -- Optimise 1-dimensional arrays, where we can avoid additional computations+  -- for the offset indices.+  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)+  = let+        keep            = map p arr+        (target, len)   = unlift $ scanl' (+) 0 (map boolToInt keep)+        prj ix          = keep!ix ? ( index1 (target!ix), ignore )+        dummy           = fill (index1 (the len)) undef+        result          = permute const dummy prj arr+    in+    if null arr+      then lift (emptyArray, fill (constant Z) 0)+      else lift (result, len)++filter p arr+  = let+        sz              = indexTail (shape arr)+        keep            = map p arr+        (target, len)   = unlift $ scanl' (+) 0 (map boolToInt keep)+        (offset, valid) = unlift $ scanl' (+) 0 (flatten len)+        prj ix          = if keep!ix+                            then index1 $ offset!index1 (toIndex sz (indexTail ix)) + target!ix+                            else ignore+        dummy           = fill (index1 (the valid)) undef+        result          = permute const dummy prj arr+    in+    if null arr+      then lift (emptyArray, fill sz 0)+      else lift (result, len)++{-# NOINLINE filter #-}+{-# RULES+  "ACC filter/filter" forall f g arr.+    filter f (afst (filter g arr)) = filter (\x -> g x && f x) arr+ #-}+++-- Gather operations+-- -----------------++-- | Gather elements from a source array by reading values at the given indices.+--+-- >>> let input = fromList (Z:.9) [1,9,6,4,4,2,0,1,2] :: Vector Int+-- >>> let from  = fromList (Z:.6) [1,3,7,2,5,3] :: Vector Int+-- >>> run $ gather (use from) (use input)+-- Vector (Z :. 6) [9,4,1,6,2,4]+--+gather+    :: (Shape sh, Elt e)+    => Acc (Array sh Int)         -- ^ index of source at each index to gather+    -> Acc (Vector e)             -- ^ source values+    -> Acc (Array sh e)+gather indices input = map (input !!) indices+  -- TLM NOTES:+  --  * (!!) has potential for later optimisation+  --  * We needn't fix the source array to Vector, but this matches the+  --    intuition that 'Int' ~ 'DIM1'.+++-- | Conditionally copy elements from source array to destination array+-- according to an index mapping.+--+-- In addition, the 'mask' vector and associated predication function specifies+-- whether the element is copied or a default value is used instead.+--+-- >>> let defaults = fromList (Z :. 6) [6,6,6,6,6,6] :: Vector Float+-- >>> let from     = fromList (Z :. 6) [1,3,7,2,5,3] :: Vector Int+-- >>> let mask     = fromList (Z :. 6) [3,4,9,2,7,5] :: Vector Int+-- >>> let input    = fromList (Z :. 9) [1,9,6,4,4,2,0,1,2] :: Vector Float+-- >>> run $ gatherIf (use from) (use mask) (> 4) (use defaults) (use input)+-- Vector (Z :. 6) [6.0,6.0,1.0,6.0,2.0,4.0]+--+gatherIf+    :: (Elt a, Elt b)+    => Acc (Vector Int)           -- ^ source indices to gather from+    -> Acc (Vector a)             -- ^ mask vector+    -> (Exp a -> Exp Bool)        -- ^ predicate function+    -> Acc (Vector b)             -- ^ default values+    -> Acc (Vector b)             -- ^ source values+    -> Acc (Vector b)+gatherIf from maskV pred defaults input = zipWith zf pf gatheredV+  where+    zf p g      = p ? (unlift g)+    gatheredV   = zip (gather from input) defaults+    pf          = map pred maskV+++-- Scatter operations+-- ------------------++-- | Overwrite elements of the destination by scattering the values of the+-- source array according to the given index mapping.+--+-- Note that if the destination index appears more than once in the mapping the+-- result is undefined.+--+-- >>> let to    = fromList (Z :. 6) [1,3,7,2,5,8] :: Vector Int+-- >>> let input = fromList (Z :. 7) [1,9,6,4,4,2,5] :: Vector Int+-- >>> run $ scatter (use to) (fill (constant (Z:.10)) 0) (use input)+-- Vector (Z :. 10) [0,1,4,9,0,4,0,6,2,0]+--+scatter+    :: Elt e+    => Acc (Vector Int)           -- ^ destination indices to scatter into+    -> Acc (Vector e)             -- ^ default values+    -> Acc (Vector e)             -- ^ source values+    -> Acc (Vector e)+scatter to defaults input = permute const defaults pf input'+  where+    pf ix       = index1 (to ! ix)+    input'      = backpermute (shape to `intersect` shape input) id input+++-- | Conditionally overwrite elements of the destination by scattering values of+-- the source array according to a given index mapping, whenever the masking+-- function resolves to 'True'.+--+-- Note that if the destination index appears more than once in the mapping the+-- result is undefined.+--+-- >>> let to    = fromList (Z :. 6) [1,3,7,2,5,8] :: Vector Int+-- >>> let mask  = fromList (Z :. 6) [3,4,9,2,7,5] :: Vector Int+-- >>> let input = fromList (Z :. 7) [1,9,6,4,4,2,5] :: Vector Int+-- >>> run $ scatterIf (use to) (use mask) (> 4) (fill (constant (Z:.10)) 0) (use input)+-- Vector (Z :. 10) [0,0,0,0,0,4,0,6,2,0]+--+scatterIf+    :: (Elt a, Elt b)+    => Acc (Vector Int)           -- ^ destination indices to scatter into+    -> Acc (Vector a)             -- ^ mask vector+    -> (Exp a -> Exp Bool)        -- ^ predicate function+    -> Acc (Vector b)             -- ^ default values+    -> Acc (Vector b)             -- ^ source values+    -> Acc (Vector b)+scatterIf to maskV pred defaults input = permute const defaults pf input'+  where+    pf ix       = pred (maskV ! ix) ? ( index1 (to ! ix), ignore )+    input'      = backpermute (shape to `intersect` shape input) id input+++-- Permutations+-- ------------++-- | Reverse the elements of a vector.+--+reverse :: Elt e => Acc (Vector e) -> Acc (Vector e)+reverse = reverseOn _1++-- | Transpose the rows and columns of a matrix.+--+transpose :: Elt e => Acc (Array DIM2 e) -> Acc (Array DIM2 e)+transpose = transposeOn _1 _2+++-- | Generalised version of 'reverse' where the argument 'Lens'' specifies which+-- dimension to reverse.+--+-- Appropriate lenses are available from <https://hackage.haskell.org/package/lens-accelerate lens-accelerate>.+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ reverseOn _1 (use mat)+-- Matrix (Z :. 5 :. 10)+--   [  9,  8,  7,  6,  5,  4,  3,  2,  1,  0,+--     19, 18, 17, 16, 15, 14, 13, 12, 11, 10,+--     29, 28, 27, 26, 25, 24, 23, 22, 21, 20,+--     39, 38, 37, 36, 35, 34, 33, 32, 31, 30,+--     49, 48, 47, 46, 45, 44, 43, 42, 41, 40]+--+-- >>> run $ reverseOn _2 (use mat)+-- Matrix (Z :. 5 :. 10)+--   [ 40, 41, 42, 43, 44, 45, 46, 47, 48, 49,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--      0,  1,  2,  3,  4,  5,  6,  7,  8,  9]+--+-- @since 1.2.0.0+--+reverseOn+    :: (Shape sh, Elt e)+    => Lens' (Exp sh) (Exp Int)+    -> Acc (Array sh e)+    -> Acc (Array sh e)+reverseOn dim xs =+  let+      sh = shape xs+      n  = sh ^. dim+  in+  backpermute sh (over dim $ \i -> n - i - 1) xs++-- | Generalised version of 'transpose' where the argument 'Lens''s specify+-- which two dimensions to transpose.+--+-- Appropriate lenses are available from <https://hackage.haskell.org/package/lens-accelerate lens-accelerate>.+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ transposeOn _1 _2 (use mat)+-- Matrix (Z :. 10 :. 5)+--   [ 0, 10, 20, 30, 40,+--     1, 11, 21, 31, 41,+--     2, 12, 22, 32, 42,+--     3, 13, 23, 33, 43,+--     4, 14, 24, 34, 44,+--     5, 15, 25, 35, 45,+--     6, 16, 26, 36, 46,+--     7, 17, 27, 37, 47,+--     8, 18, 28, 38, 48,+--     9, 19, 29, 39, 49]+--+-- >>> let box = fromList (Z:.2:.3:.5) [0..] :: Array DIM3 Int+-- >>> box+-- Array (Z :. 2 :. 3 :. 5) [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29]+--+-- >>> run $ transposeOn _1 _2 (use box)+-- Array (Z :. 2 :. 5 :. 3) [0,5,10,1,6,11,2,7,12,3,8,13,4,9,14,15,20,25,16,21,26,17,22,27,18,23,28,19,24,29]+--+-- >>> run $ transposeOn _2 _3 (use box)+-- Array (Z :. 3 :. 2 :. 5) [0,1,2,3,4,15,16,17,18,19,5,6,7,8,9,20,21,22,23,24,10,11,12,13,14,25,26,27,28,29]+--+-- >>> run $ transposeOn _1 _3 (use box)+-- Array (Z :. 5 :. 3 :. 2) [0,15,5,20,10,25,1,16,6,21,11,26,2,17,7,22,12,27,3,18,8,23,13,28,4,19,9,24,14,29]+--+-- @since 1.2.0.0+--+transposeOn+    :: (Shape sh, Elt e)+    => Lens' (Exp sh) (Exp Int)+    -> Lens' (Exp sh) (Exp Int)+    -> Acc (Array sh e)+    -> Acc (Array sh e)+transposeOn dim1 dim2 xs =+  let+      swap ix = ix & dim2 .~ ix ^. dim1+                   & dim1 .~ ix ^. dim2+  in+  backpermute (swap (shape xs)) swap xs+++-- Extracting sub-vectors+-- ----------------------++-- | Yield the first @n@ elements in the innermost dimension of the array (plus+-- all lower dimensional elements).+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ take 5 (use mat)+-- Matrix (Z :. 5 :. 5)+--   [  0,  1,  2,  3,  4,+--     10, 11, 12, 13, 14,+--     20, 21, 22, 23, 24,+--     30, 31, 32, 33, 34,+--     40, 41, 42, 43, 44]+--+take :: forall sh e. (Slice sh, Shape sh, Elt e)+     => Exp Int+     -> Acc (Array (sh :. Int) e)+     -> Acc (Array (sh :. Int) e)+take = takeOn _1+++-- | Yield all but the first @n@ elements along the innermost dimension of the+-- array (plus all lower dimensional elements).+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ drop 7 (use mat)+-- Matrix (Z :. 5 :. 3)+--   [  7,  8,  9,+--     17, 18, 19,+--     27, 28, 29,+--     37, 38, 39,+--     47, 48, 49]+--+drop :: forall sh e. (Slice sh, Shape sh, Elt e)+     => Exp Int+     -> Acc (Array (sh :. Int) e)+     -> Acc (Array (sh :. Int) e)+drop = dropOn _1+++-- | Yield all but the elements in the last index of the innermost dimension.+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ init (use mat)+-- Matrix (Z :. 5 :. 9)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,+--     10, 11, 12, 13, 14, 15, 16, 17, 18,+--     20, 21, 22, 23, 24, 25, 26, 27, 28,+--     30, 31, 32, 33, 34, 35, 36, 37, 38,+--     40, 41, 42, 43, 44, 45, 46, 47, 48]+--+init :: forall sh e. (Slice sh, Shape sh, Elt e)+     => Acc (Array (sh :. Int) e)+     -> Acc (Array (sh :. Int) e)+init = initOn _1+++-- | Yield all but the first element along the innermost dimension of an array.+-- The innermost dimension must not be empty.+--+-- >>> let mat = fromList (Z:.5:.10) [0..] :: Matrix Int+-- >>> mat+-- Matrix (Z :. 5 :. 10)+--   [  0,  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     10, 11, 12, 13, 14, 15, 16, 17, 18, 19,+--     20, 21, 22, 23, 24, 25, 26, 27, 28, 29,+--     30, 31, 32, 33, 34, 35, 36, 37, 38, 39,+--     40, 41, 42, 43, 44, 45, 46, 47, 48, 49]+--+-- >>> run $ tail (use mat)+-- Matrix (Z :. 5 :. 9)+--   [  1,  2,  3,  4,  5,  6,  7,  8,  9,+--     11, 12, 13, 14, 15, 16, 17, 18, 19,+--     21, 22, 23, 24, 25, 26, 27, 28, 29,+--     31, 32, 33, 34, 35, 36, 37, 38, 39,+--     41, 42, 43, 44, 45, 46, 47, 48, 49]+--+tail :: forall sh e. (Slice sh, Shape sh, Elt e)+     => Acc (Array (sh :. Int) e)+     -> Acc (Array (sh :. Int) e)+tail = tailOn _1+++-- | Yield a slit (slice) of the innermost indices of an array. Denotationally,+-- we have:+--+-- > slit i n = take n . drop i+--+slit :: forall sh e. (Slice sh, Shape sh, Elt e)+     => Exp Int                     -- ^ starting index+     -> Exp Int                     -- ^ length+     -> Acc (Array (sh :. Int) e)+     -> Acc (Array (sh :. Int) e)+slit = slitOn _1+++-- | Generalised version of 'init' where the argument 'Lens'' specifies which+-- dimension to operate over.+--+-- Appropriate lenses are available from <https://hackage.haskell.org/package/lens-accelerate lens-accelerate>.+--+-- @since 1.2.0.0+--+initOn+    :: (Shape sh, Elt e)+    => Lens' (Exp sh) (Exp Int)+    -> Acc (Array sh e)+    -> Acc (Array sh e)+initOn dim xs =+  let+      sh  = shape xs+      sh' = over dim (\i -> 0 `max` (i-1)) sh+  in+  backpermute sh' id xs+++-- | Generalised version of 'tail' where the argument 'Lens'' specifies which+-- dimension to operate over.+--+-- Appropriate lenses are available from <https://hackage.haskell.org/package/lens-accelerate lens-accelerate>.+--+-- @since 1.2.0.0+--+tailOn+    :: (Shape sh, Elt e)+    => Lens' (Exp sh) (Exp Int)+    -> Acc (Array sh e)+    -> Acc (Array sh e)+tailOn dim xs =+  let+      sh  = shape xs+      sh' = over dim (\i -> 0 `max` (i-1)) sh+  in+  backpermute sh' (& dim +~ 1) xs+++-- | Generalised version of 'take' where the argument 'Lens'' specifies which+-- dimension to operate over.+--+-- Appropriate lenses are available from <https://hackage.haskell.org/package/lens-accelerate lens-accelerate>.+--+-- @since 1.2.0.0+--+takeOn+    :: (Shape sh, Elt e)+    => Lens' (Exp sh) (Exp Int)+    -> Exp Int+    -> Acc (Array sh e)+    -> Acc (Array sh e)+takeOn dim n xs =+  let+      sh = shape xs+      m  = sh ^. dim+  in+  backpermute (sh & dim .~ min m n) id xs+++-- | Generalised version of 'drop' where the argument 'Lens'' specifies which+-- dimension to operate over.+--+-- Appropriate lenses are available from <https://hackage.haskell.org/package/lens-accelerate lens-accelerate>.+--+-- @since 1.2.0.0+--+dropOn+    :: (Shape sh, Elt e)+    => Lens' (Exp sh) (Exp Int)+    -> Exp Int+    -> Acc (Array sh e)+    -> Acc (Array sh e)+dropOn dim n xs =+  let+      sh = shape xs+      m  = sh ^. dim+  in+  backpermute (sh & dim .~ max 0 (m-n)) (& dim +~ n) xs++-- Note: [embedding constants in take & drop]+--+-- Previously the 'take' and 'drop functions prevented the value of the+-- take/drop amount from being embedded directly in the generated code. This was+-- done by writing the value into a scalar array and reading that value out,+-- rather than using it directly. Although that is better from a code+-- cache/reuse standpoint, I've now removed this as it prevents the user from+-- specialising their code, and in a real program this extra indirection is+-- probably not necessary anyway.+--++-- | Generalised version of 'drop' where the argument 'Lens'' specifies which+-- dimension to operate over.+--+-- Appropriate lenses are available from <https://hackage.haskell.org/package/lens-accelerate lens-accelerate>.+--+-- @since 1.2.0.0+--+slitOn+    :: (Shape sh, Elt e)+    => Lens' (Exp sh) (Exp Int)+    -> Exp Int                      -- ^ starting index+    -> Exp Int                      -- ^ length+    -> Acc (Array sh e)+    -> Acc (Array sh e)+slitOn dim i n = takeOn dim n . dropOn dim i+++-- Controlling execution+-- ---------------------++-- | Force an array expression to be evaluated, preventing it from fusing with+-- other operations. Forcing operations to be computed to memory, rather than+-- being fused into their consuming function, can sometimes improve performance.+-- For example, computing a matrix 'transpose' could provide better memory+-- locality for the subsequent operation. Preventing fusion to split large+-- operations into several simpler steps could also help by reducing register+-- pressure.+--+-- Preventing fusion also means that the individual operations are available to+-- be executed concurrently with other kernels. In particular, consider using+-- this if you have a series of operations that are compute bound rather than+-- memory bound.+--+-- Here is the synthetic example:+--+-- > loop :: Exp Int -> Exp Int+-- > loop ticks =+-- >   let clockRate = 900000   -- kHz+-- >   in  while (\i -> i < clockRate * ticks) (+1) 0+-- >+-- > test :: Acc (Vector Int)+-- > test =+-- >   zip3+-- >     (compute $ map loop (use $ fromList (Z:.1) [10]))+-- >     (compute $ map loop (use $ fromList (Z:.1) [10]))+-- >     (compute $ map loop (use $ fromList (Z:.1) [10]))+-- >+--+-- Without the use of 'compute', the operations are fused together and the three+-- long-running loops are executed sequentially in a single kernel. Instead, the+-- individual operations can now be executed concurrently, potentially reducing+-- overall runtime.+--+compute :: Arrays a => Acc a -> Acc a+compute = id >-> id+++-- Flow control+-- ------------++-- | Infix version of 'acond'. If the predicate evaluates to 'True', the first+-- component of the tuple is returned, else the second.+--+-- Enabling the @RebindableSyntax@ extension will allow you to use the standard+-- if-then-else syntax instead.+--+infix 0 ?|+(?|) :: Arrays a => Exp Bool -> (Acc a, Acc a) -> Acc a+c ?| (t, e) = acond c t e++-- | An infix version of 'cond'. If the predicate evaluates to 'True', the first+-- component of the tuple is returned, else the second.+--+-- Enabling the @RebindableSyntax@ extension will allow you to use the standard+-- if-then-else syntax instead.+--+infix 0 ?+(?) :: Elt t => Exp Bool -> (Exp t, Exp t) -> Exp t+c ? (t, e) = cond c t e++-- | A case-like control structure+--+caseof :: (Elt a, Elt b)+       => Exp a                         -- ^ case subject+       -> [(Exp a -> Exp Bool, Exp b)]  -- ^ list of cases to attempt+       -> Exp b                         -- ^ default value+       -> Exp b+caseof _ []        e = e+caseof x ((p,b):l) e = cond (p x) b (caseof x l e)+++-- | For use with @-XRebindableSyntax@, this class provides 'ifThenElse' lifted+-- to both scalar and array types.+--+class IfThenElse t where+  type EltT t a :: Constraint+  ifThenElse :: EltT t a => Exp Bool -> t a -> t a -> t a++instance IfThenElse Exp where+  type EltT Exp t = Elt t+  ifThenElse = cond++instance IfThenElse Acc where+  type EltT Acc a = Arrays a+  ifThenElse = acond+++-- Scalar iteration+-- ----------------++-- | Repeatedly apply a function a fixed number of times+--+iterate+    :: forall a. Elt a+    => Exp Int+    -> (Exp a -> Exp a)+    -> Exp a+    -> Exp a+iterate n f z+  = let step :: (Exp Int, Exp a) -> (Exp Int, Exp a)+        step (i, acc)   = ( i+1, f acc )+    in+    snd $ while (\v -> fst v < n) (lift1 step) (lift (0, z))+++-- Scalar bulk operations+-- ----------------------++-- | Reduce along an innermost slice of an array /sequentially/, by applying a+-- binary operator to a starting value and the array from left to right.+--+sfoldl :: forall sh a b. (Shape sh, Slice sh, Elt a, Elt b)+       => (Exp a -> Exp b -> Exp a)+       -> Exp a+       -> Exp sh+       -> Acc (Array (sh :. Int) b)+       -> Exp a+sfoldl f z ix xs+  = let step :: (Exp Int, Exp a) -> (Exp Int, Exp a)+        step (i, acc)   = ( i+1, acc `f` (xs ! lift (ix :. i)) )+        (_ :. n)        = unlift (shape xs)     :: Exp sh :. Exp Int+    in+    snd $ while (\v -> fst v < n) (lift1 step) (lift (0, z))+++-- Tuples+-- ------++-- |Extract the first component of a scalar pair.+--+fst :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp a+fst e = let (x, _::Exp b) = unlift e in x++-- |Extract the first component of an array pair.+{-# NOINLINE[1] afst #-}+afst :: forall a b. (Arrays a, Arrays b) => Acc (a, b) -> Acc a+afst a = let (x, _::Acc b) = unlift a in x++-- |Extract the second component of a scalar pair.+--+snd :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp b+snd e = let (_:: Exp a, y) = unlift e in y++-- | Extract the second component of an array pair+asnd :: forall a b. (Arrays a, Arrays b) => Acc (a, b) -> Acc b+asnd a = let (_::Acc a, y) = unlift a in y++-- |Converts an uncurried function to a curried function.+--+curry :: Lift f (f a, f b) => (f (Plain (f a), Plain (f b)) -> f c) -> f a -> f b -> f c+curry f x y = f (lift (x, y))++-- |Converts a curried function to a function on pairs.+--+uncurry :: Unlift f (f a, f b) => (f a -> f b -> f c) -> f (Plain (f a), Plain (f b)) -> f c+uncurry f t = let (x, y) = unlift t in f x y+++-- Shapes and indices+-- ------------------++-- | The one index for a rank-0 array.+--+index0 :: Exp Z+index0 = lift Z++-- | Turn an 'Int' expression into a rank-1 indexing expression.+--+index1 :: Elt i => Exp i -> Exp (Z :. i)+index1 i = lift (Z :. i)++-- | Turn a rank-1 indexing expression into an 'Int' expression.+--+unindex1 :: Elt i => Exp (Z :. i) -> Exp i+unindex1 ix = let Z :. i = unlift ix in i++-- | Creates a rank-2 index from two Exp Int`s+--+index2+    :: (Elt i, Slice (Z :. i))+    => Exp i+    -> Exp i+    -> Exp (Z :. i :. i)+index2 i j = lift (Z :. i :. j)++-- | Destructs a rank-2 index to an Exp tuple of two Int`s.+--+unindex2+    :: forall i. (Elt i, Slice (Z :. i))+    => Exp (Z :. i :. i)+    -> Exp (i, i)+unindex2 ix+  = let Z :. i :. j = unlift ix :: Z :. Exp i :. Exp i+    in  lift (i, j)++-- | Create a rank-3 index from three Exp Int`s+--+index3+    :: (Elt i, Slice (Z :. i), Slice (Z :. i :. i))+    => Exp i+    -> Exp i+    -> Exp i+    -> Exp (Z :. i :. i :. i)+index3 k j i = lift (Z :. k :. j :. i)++-- | Destruct a rank-3 index into an Exp tuple of Int`s+unindex3+    :: forall i. (Elt i, Slice (Z :. i), Slice (Z :. i :. i))+    => Exp (Z :. i :. i :. i)+    -> Exp (i, i, i)+unindex3 ix = let Z :. k :. j :. i = unlift ix  :: Z :. Exp i :. Exp i :. Exp i+              in  lift (k, j, i)+++-- Array operations with a scalar result+-- -------------------------------------++-- | Extract the element of a singleton array.+--+-- > the xs  ==  xs ! Z+--+the :: Elt e => Acc (Scalar e) -> Exp e+the = (!index0)++-- | Test whether an array is empty.+--+null :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp Bool+null arr = size arr == 0++-- | Get the length of a vector.+--+length :: Elt e => Acc (Vector e) -> Exp Int+length = unindex1 . shape+++{--+-- Sequence operations+-- --------------------------------------++-- | Reduce a sequence by appending all the shapes and all the elements in two+-- separate vectors.+--+fromSeq :: (Shape sh, Elt a) => Seq [Array sh a] -> Seq (Vector sh, Vector a)+fromSeq = foldSeqFlatten f (lift (emptyArray, emptyArray))+  where+    f x sh1 a1 =+      let (sh0, a0) = unlift x+      in lift (sh0 ++ sh1, a0 ++ a1)+++fromSeqElems :: (Shape sh, Elt a) => Seq [Array sh a] -> Seq (Vector a)+fromSeqElems = foldSeqFlatten f emptyArray+  where+    f a0 _ a1 = a0 ++ a1++fromSeqShapes :: (Shape sh, Elt a) => Seq [Array sh a] -> Seq (Vector sh)+fromSeqShapes = foldSeqFlatten f emptyArray+  where+    f sh0 sh1 _ = sh0 ++ sh1++-- | Sequence an array on the innermost dimension.+--+toSeqInner :: (Shape sh, Elt a) => Acc (Array (sh :. Int) a) -> Seq [Array sh a]+toSeqInner a = toSeq (Any :. Split) a++-- | Sequence a 2-dimensional array on the outermost dimension.+--+toSeqOuter2 :: Elt a => Acc (Array DIM2 a) -> Seq [Array DIM1 a]+toSeqOuter2 a = toSeq (Z :. Split :. All) a++-- | Sequence a 3-dimensional array on the outermost dimension.+toSeqOuter3 :: Elt a => Acc (Array DIM3 a) -> Seq [Array DIM2 a]+toSeqOuter3 a = toSeq (Z :. Split :. All :. All) a++-- | Generate a scalar sequence of a fixed given length, by applying+-- the given scalar function at each index.+generateSeq :: Elt a => Exp Int -> (Exp Int -> Exp a) -> Seq [Scalar a]+generateSeq n f = toSeq (Z :. Split) (generate (index1 n) (f . unindex1))+--}++-- Utilities+-- ---------++emptyArray :: (Shape sh, Elt e) => Acc (Array sh e)+emptyArray = fill (constant empty) undef+++matchShapeType :: forall s t. (Shape s, Shape t) => s -> t -> Maybe (s :~: t)+matchShapeType _ _+  | Just Refl <- matchTupleType (eltType (undefined::s)) (eltType (undefined::t))+  = gcast Refl++matchShapeType _ _+  = Nothing+++-- Lenses+-- ------+--+-- Imported from `lens-accelerate` (which provides more general Field instances)+--+_1 :: forall sh. (Shape sh, Slice sh) => Lens' (Exp (sh:.Int)) (Exp Int)+_1 = lens (\ix   -> let _  :. x = unlift ix :: Exp sh :. Exp Int in x)+          (\ix x -> let sh :. _ = unlift ix :: Exp sh :. Exp Int in lift (sh :. x))++_2 :: forall sh. (Shape sh, Slice sh) => Lens' (Exp (sh:.Int:.Int)) (Exp Int)+_2 = lens (\ix   -> let _  :. y :. _ = unlift ix :: Exp sh :. Exp Int :. Exp Int in y)+          (\ix y -> let sh :. _ :. x = unlift ix :: Exp sh :. Exp Int :. Exp Int in lift (sh :. y :. x))++_3 :: forall sh. (Shape sh, Slice sh) => Lens' (Exp (sh:.Int:.Int:.Int)) (Exp Int)+_3 = lens (\ix   -> let _  :. z :. _ :. _ = unlift ix :: Exp sh :. Exp Int :. Exp Int :. Exp Int in z)+          (\ix z -> let sh :. _ :. y :. x = unlift ix :: Exp sh :. Exp Int :. Exp Int :. Exp Int in lift (sh :. z :. y :. x))+
+ src/Data/Array/Accelerate/Pretty.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Pretty+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] 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.Pretty (++  -- * Pretty printing functions+  module Data.Array.Accelerate.Pretty.Print,+  module Data.Array.Accelerate.Pretty.Graphviz,++  -- * Instances of Show++) where++-- libraries+import System.IO+import System.IO.Unsafe+import Text.PrettyPrint.ANSI.Leijen+import qualified System.Console.ANSI                                as Term+import qualified System.Console.Terminal.Size                       as Term++-- friends+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Trafo.Base+import Data.Array.Accelerate.Pretty.Print+import Data.Array.Accelerate.Pretty.Graphviz+++-- Show+-- ----++-- Explicitly enumerate Show instances for the Accelerate array AST types. If we+-- instead use a generic instance of the form:+--+--   instance Kit acc => Show (acc aenv a) where+--+-- This matches any type of kind (* -> * -> *), which can cause problems+-- interacting with other packages. See Issue #108.+--+instance PrettyEnv aenv => Show (OpenAcc aenv a) where+  showsPrec _ = renderForTerminal . pretty++instance PrettyEnv aenv => Show (DelayedOpenAcc aenv a) where+  showsPrec _ = renderForTerminal . pretty++-- These parameterised instances are fine because there is a concrete kind+--+-- TLM: Ugh, his new 'PrettyEnv' constraint really just enforces something+--      that we already know, which is that our environments are nested+--      tuples, but our type parameter 'env' doesn't capture that.+--+instance (Kit acc, PrettyEnv aenv) => Show (PreOpenAfun acc aenv f) where+  showsPrec _ = renderForTerminal . pretty++instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Show (PreOpenFun acc env aenv f) where+  showsPrec _ = renderForTerminal . pretty++instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Show (PreOpenExp acc env aenv t) where+  showsPrec _ = renderForTerminal . pretty++-- instance Kit acc => Show (PreOpenSeq acc aenv senv t) where+--   show s = renderForTerminal wide $ sep $ punctuate (text ";") $ prettySeq prettyAcc 0 0 noParens s++renderForTerminal :: Doc -> ShowS+renderForTerminal doc next =+  unsafePerformIO $ do+    term <- Term.size+    ansi <- Term.hSupportsANSI stdout+    let+        w             = maybe 120 Term.width term+        d | ansi      = doc+          | otherwise = plain doc+        f | w <= 100  = 0.7+          | w <= 120  = 0.6+          | otherwise = 0.5+    --+    return $ displayS (renderSmart f w d) next++-- Pretty+-- ------++instance PrettyEnv aenv => Pretty (OpenAcc aenv a) where+  pretty c = prettyAcc noParens prettyEnv c++instance PrettyEnv aenv => Pretty (DelayedOpenAcc aenv a) where+  pretty c = prettyAcc noParens prettyEnv c++instance (Kit acc, PrettyEnv aenv) => Pretty (PreOpenAfun acc aenv f) where+  pretty f = prettyPreOpenAfun prettyAcc prettyEnv f++instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Pretty (PreOpenFun acc env aenv f) where+  pretty f = prettyPreOpenFun prettyAcc prettyEnv prettyEnv f++instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Pretty (PreOpenExp acc env aenv t) where+  pretty e = prettyPreOpenExp prettyAcc noParens prettyEnv prettyEnv e+
+ src/Data/Array/Accelerate/Pretty/Graphviz.hs view
@@ -0,0 +1,559 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE PatternGuards        #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns         #-}+-- |+-- Module      : Data.Array.Accelerate.Pretty.Graphviz+-- Copyright   : [2015..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.Pretty.Graphviz (++  Graph,+  PrettyGraph(..), Detail(..),++  graphDelayedAcc, graphDelayedAfun,++) where++-- standard libraries+import Control.Applicative                              hiding ( Const, empty )+import Control.Arrow                                    ( (&&&) )+import Control.Monad.State                              ( modify, gets, state )+import Data.HashSet                                     ( HashSet )+import Data.List+import Data.Maybe+import System.IO.Unsafe                                 ( unsafePerformIO )+import Text.PrettyPrint.ANSI.Leijen                     hiding ( (<$>), parens )+import Prelude                                          hiding ( exp )+import qualified Data.Sequence                          as Seq+import qualified Data.HashSet                           as Set+import qualified Text.PrettyPrint.ANSI.Leijen           as PP++-- friends+import Data.Array.Accelerate.AST                        ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), PreBoundary(..), Idx(..) )+import Data.Array.Accelerate.Array.Sugar                ( Array, Shape, Elt, Tuple(..), Atuple(..), arrays, toElt, strForeign )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Trafo.Base+import Data.Array.Accelerate.Pretty.Print+import Data.Array.Accelerate.Pretty.Graphviz.Monad+import Data.Array.Accelerate.Pretty.Graphviz.Type+++-- Configuration options+-- ---------------------++cfgIncludeShape, cfgUnique :: Bool+cfgIncludeShape = False             -- draw edges for uses of shape information+cfgUnique       = False             -- draw a single edge per data dependency+++-- Environments+-- ------------++-- This is the standard environment typed by de Bruijn indices, where at each+-- index we need to record both the pretty printed label as well its 'NodeId',+-- which we use to track data dependencies.+--+data Aval env where+  Aempty ::                                Aval ()+  Apush  :: Aval env -> NodeId -> Label -> Aval (env, t)++-- Convert to the 'Val' used by the base pretty printing module by stripping out+-- the 'NodeId' part.+--+avalToVal :: Aval aenv -> Val aenv+avalToVal Aempty           = Empty+avalToVal (Apush aenv _ v) = Push (avalToVal aenv) (text v)++aprj :: Idx aenv t -> Aval aenv -> (NodeId, Label)        -- TLM: (Vertex, Label) ??+aprj ZeroIdx      (Apush _    n v) = (n,v)+aprj (SuccIdx ix) (Apush aenv _ _) = aprj ix aenv+#if __GLASGOW_HASKELL__ < 800+aprj _            _                = $internalError "aprj" "inconsistent valuation"+#endif+++-- Graph construction+-- ------------------++mkNode :: PNode -> Maybe Label -> Dot NodeId+mkNode (PNode ident tree deps) label =+  let node  = Node label ident tree+      edges = Seq.fromList+            $ map (\(from, to) -> Edge from (Vertex ident to))+            $ if cfgUnique then nub deps else deps+  in+  state $ \s ->+    ( ident+    , s { dotNodes = node  Seq.<| dotNodes s+        , dotEdges = edges Seq.>< dotEdges s+        }+    )+++-- Add [T|F] ports underneath the given tree.+--+mkTF :: Tree (Maybe Port, Doc) -> Tree (Maybe Port, Doc)+mkTF this =+  Forest [ this+         , Forest [ Leaf (Just "T", "T")+                  , Leaf (Just "F", "F")+                  ]+         ]+++-- Pretty Printing+-- ===============+--+-- The use of unsafePerformIO in the below is safe in the sense that we only+-- require IO to recover the stable names of terms. At worst, if we do not+-- recover the correct stable name for some reason, we will be left with+-- dandling edges in the graph.+--++class PrettyGraph g where+  ppGraph :: Detail -> g -> Graph++instance PrettyGraph (DelayedAcc a) where+  ppGraph = graphDelayedAcc++instance PrettyGraph (DelayedAfun a) where+  ppGraph = graphDelayedAfun++data Detail = Simple | Full++simple :: Detail -> Bool+simple Simple = True+simple _      = False++-- | Generate a dependency graph for the given computation+--+{-# NOINLINE graphDelayedAcc #-}+graphDelayedAcc :: Detail -> DelayedAcc a -> Graph+graphDelayedAcc detail acc =+  unsafePerformIO $! evalDot (graphDelayedOpenAcc detail Aempty acc)++-- | Generate a dependency graph for an array function+--+{-# NOINLINE graphDelayedAfun #-}+graphDelayedAfun :: Detail -> DelayedAfun f -> Graph+graphDelayedAfun detail afun = unsafePerformIO . evalDot $! do+  l <- prettyDelayedAfun detail Aempty afun+  state $ \s ->+    case Seq.viewl (dotGraph s) of+      g@(Graph l' _) Seq.:< gs | l == l' -> (g, s { dotGraph = gs })+      _                                  -> $internalError "graphDelaydAfun" "unexpected error"+++-- Pretty-printing data-dependency graphs+-- --------------------------------------++-- Partially constructed graph nodes, consists of some body text and a list of+-- vertices which we will draw edges from (and later, the port we connect into).+--+data PDoc  = PDoc Doc [Vertex]+data PNode = PNode NodeId (Tree (Maybe Port, Doc)) [(Vertex, Maybe Port)]++graphDelayedOpenAcc+    :: Detail+    -> Aval aenv+    -> DelayedOpenAcc aenv a+    -> Dot Graph+graphDelayedOpenAcc detail aenv acc = do+  r <- prettyDelayedOpenAcc detail noParens aenv acc+  i <- mkNodeId r+  v <- mkNode r Nothing+  _ <- mkNode (PNode i (Leaf (Nothing,"result")) [(Vertex v Nothing, Nothing)]) Nothing+  mkGraph++-- Generate a graph for the given term.+--+prettyDelayedOpenAcc+    :: forall aenv arrs.+       Detail                               -- simplified output: only print operator name+    -> (Doc -> Doc)+    -> Aval aenv+    -> DelayedOpenAcc aenv arrs+    -> Dot PNode+prettyDelayedOpenAcc _      _    _    Delayed{}            = $internalError "prettyDelayedOpenAcc" "expected manifest array"+prettyDelayedOpenAcc detail wrap aenv atop@(Manifest pacc) =+  case pacc of+    Avar ix                 -> pnode (avar ix)+    Alet bnd body           -> do+      bnd'  <- prettyDelayedOpenAcc detail noParens aenv                 bnd+      a     <- mkLabel+      ident <- mkNode bnd' (Just a)+      body' <- prettyDelayedOpenAcc detail noParens (Apush aenv ident a) body+      return body'++    Acond p t e             -> do+      ident <- mkNodeId atop+      vt    <- lift t+      ve    <- lift e+      PDoc p' vs <- ppE p+      let port = Just "P"+          doc  = mkTF $ Leaf (port, if simple detail then "?|" else p')+          deps = (vt, Just "T") : (ve, Just "F") : map (,port) vs+      return $ PNode ident doc deps++    Apply afun acc          -> apply <$> prettyDelayedAfun    detail        aenv afun+                                     <*> prettyDelayedOpenAcc detail parens aenv acc++    Awhile p f x            -> do+      ident <- mkNodeId atop+      x'    <- replant =<< prettyDelayedOpenAcc detail parens aenv x+      p'    <- prettyDelayedAfun detail aenv p+      f'    <- prettyDelayedAfun detail aenv f+      --+      let PNode _ (Leaf (Nothing,xb)) fvs = x'+          loop                            = wrap $ hang 2 (sep ["awhile", text p', text f', xb ])+      return $ PNode ident (Leaf (Nothing,loop)) fvs++    Atuple atup             -> prettyDelayedAtuple detail wrap aenv atup+    Aprj ix atup            -> do+      ident                     <- mkNodeId atop+      PNode _ (Leaf (p,d)) deps <- replant =<< prettyDelayedOpenAcc detail parens aenv atup+      return $ PNode ident (Leaf (p, wrap (prettyTupleIdx ix <+> nest 2 d))) deps++    Use arrs                -> "use"         .$ [ return $ PDoc (prettyArrays (arrays (undefined::arrs)) arrs) [] ]+    Unit e                  -> "unit"        .$ [ ppE e ]+    Generate sh f           -> "generate"    .$ [ ppSh sh, ppF f ]+    Transform sh ix f xs    -> "transform"   .$ [ ppSh sh, ppF ix, ppF f, ppA xs ]+    Reshape sh xs           -> "reshape"     .$ [ ppSh sh, ppA xs ]+    Replicate _ty ix xs     -> "replicate"   .$ [ ppSh ix, ppA xs ]+    Slice _ty xs ix         -> "slice"       .$ [ ppA xs, ppSh ix ]+    Map f xs                -> "map"         .$ [ ppF f, ppA xs ]+    ZipWith f xs ys         -> "zipWith"     .$ [ ppF f, ppA xs, ppA ys ]+    Fold f e xs             -> "fold"        .$ [ ppF f, ppE e, ppA xs ]+    Fold1 f xs              -> "fold1"       .$ [ ppF f, ppA xs ]+    FoldSeg f e xs ys       -> "foldSeg"     .$ [ ppF f, ppE e, ppA xs, ppA ys ]+    Fold1Seg f xs ys        -> "fold1Seg"    .$ [ ppF f, ppA xs, ppA ys ]+    Scanl f e xs            -> "scanl"       .$ [ ppF f, ppE e, ppA xs ]+    Scanl' f e xs           -> "scanl'"      .$ [ ppF f, ppE e, ppA xs ]+    Scanl1 f xs             -> "scanl1"      .$ [ ppF f, ppA xs ]+    Scanr f e xs            -> "scanr"       .$ [ ppF f, ppE e, ppA xs ]+    Scanr' f e xs           -> "scanr'"      .$ [ ppF f, ppE e, ppA xs ]+    Scanr1 f xs             -> "scanr1"      .$ [ ppF f, ppA xs ]+    Permute f dfts p xs     -> "permute"     .$ [ ppF f, ppA dfts, ppF p, ppA xs ]+    Backpermute sh p xs     -> "backpermute" .$ [ ppSh sh, ppF p, ppA xs ]+    Stencil sten bndy xs    -> "stencil"     .$ [ ppF sten, ppB bndy, ppA xs ]+    Stencil2 sten bndy1 acc1 bndy2 acc2+                            -> "stencil2"    .$ [ ppF sten, ppB bndy1, ppA acc1, ppB bndy2, ppA acc2 ]+    Aforeign ff _afun xs    -> "aforeign"    .$ [ return (PDoc (text (strForeign ff)) []), {- ppAf afun, -} ppA xs ]+    -- Collect{}               -> error "Collect"++  where+    (.$) :: String -> [Dot PDoc] -> Dot PNode+    name .$ docs = pnode =<< fmt name docs++    fmt :: String -> [Dot PDoc] -> Dot PDoc+    fmt name docs = do+      docs' <- sequence docs+      let args = [ x | PDoc x _ <- docs' ]+          fvs  = [ x | PDoc _ x <- docs' ]+      return $ PDoc (wrap $ hang 2 (sep [text name, if simple detail then empty else sep args]))+                    (concat fvs)++    pnode :: PDoc -> Dot PNode+    pnode (PDoc doc vs) = do+      let port = Nothing+      ident <- mkNodeId atop+      return $ PNode ident (Leaf (port, doc)) (map (,port) vs)++    -- Free variables+    --+    fvA :: FVAcc DelayedOpenAcc+    fvA env (Manifest (Avar ix)) = [ Vertex (fst $ aprj ix env) Nothing ]+    fvA _   _                    = $internalError "graphviz" "expected array variable"++    fvF :: DelayedFun aenv t -> [Vertex]+    fvF = fvPreOpenFun fvA Empty aenv++    fvE :: DelayedExp aenv t -> [Vertex]+    fvE = fvPreOpenExp fvA Empty aenv++    -- Pretty-printing+    --+    avar :: Idx aenv t -> PDoc+    avar ix = let (ident, v) = aprj ix aenv+              in  PDoc (text v) [Vertex ident Nothing]++    aenv' :: Val aenv+    aenv' = avalToVal aenv++    ppA :: DelayedOpenAcc aenv a -> Dot PDoc+    ppA (Manifest (Avar ix)) = return (avar ix)+    ppA acc@Manifest{}       = do+      -- Lift out and draw as a separate node. This can occur with the manifest+      -- array arguments to permute (defaults array) and stencil[2].+      acc'  <- prettyDelayedOpenAcc detail noParens aenv acc+      v     <- mkLabel+      ident <- mkNode acc' (Just v)+      return $ PDoc (text v) [Vertex ident Nothing]+    ppA (Delayed sh f _)+      | Shape a    <- sh                                             -- identical shape+      , Just Refl  <- match f (Lam (Body (Index a (Var ZeroIdx))))   -- identity function+      = ppA a+    ppA (Delayed sh f _) = do+      PDoc d v <- "Delayed" `fmt` [ ppSh sh, ppF f ]+      return    $ PDoc (parens d) v++    ppB :: forall sh e. (Shape sh, Elt e)+        => PreBoundary DelayedOpenAcc aenv (Array sh e)+        -> Dot PDoc+    ppB Clamp        = return (PDoc "clamp"  [])+    ppB Mirror       = return (PDoc "mirror" [])+    ppB Wrap         = return (PDoc "wrap"   [])+    ppB (Constant e) = return (PDoc (parens $ "constant" <+> text (show (toElt e :: e))) [])+    ppB (Function f) = ppF f++    ppF :: DelayedFun aenv t -> Dot PDoc+    ppF = return . uncurry PDoc . (parens . prettyDelayedFun aenv' &&& fvF)++    ppE :: DelayedExp aenv t -> Dot PDoc+    ppE = return . uncurry PDoc . (prettyDelayedExp parens aenv' &&& fvE)++    ppSh :: DelayedExp aenv sh -> Dot PDoc+    ppSh = return . uncurry PDoc . (parens . prettyDelayedExp noParens aenv' &&& fvE)++    lift :: DelayedOpenAcc aenv a -> Dot Vertex+    lift Delayed{}            = $internalError "prettyDelayedOpenAcc" "expected manifest array"+    lift (Manifest (Avar ix)) = return $ Vertex (fst (aprj ix aenv)) Nothing+    lift acc                  = do+      acc'  <- prettyDelayedOpenAcc detail noParens aenv acc+      ident <- mkNode acc' Nothing+      return $ Vertex ident Nothing++    apply :: Label -> PNode -> PNode+    apply f (PNode ident x vs) =+      let x' = case x of+                 Leaf (p,d) -> Leaf (p, wrap (text f <+> d))+                 Forest ts  -> Forest (Leaf (Nothing,text f) : ts)+      in+      PNode ident x' vs++    parens :: Doc -> Doc+    parens = PP.parens . align+++-- Pretty print array functions as separate sub-graphs, and return the name of+-- the sub-graph as if it can be called like a function. We will add additional+-- nodes at the top of the graph to represent the bound variables.+--+-- Note: [Edge placement]+--+-- If a node belongs to a particular graph, so too must all its edges (and+-- vertices). This means that if the subgraph references anything from the+-- enclosing environment, we must lift those edges out of this subgraph,+-- otherwise the referenced node will be drawn inside of the subgraph.+--+prettyDelayedAfun+    :: Detail+    -> Aval aenv+    -> DelayedOpenAfun aenv afun+    -> Dot Label+prettyDelayedAfun detail aenv afun = do+  Graph _ ss  <- mkSubgraph (go aenv afun)+  n           <- Seq.length <$> gets dotGraph+  let label         = "afun" ++ show (n+1)+      outer         = collect aenv+      (lifted,ss')  =+        flip partition ss $ \s ->+        case s of+          E (Edge (Vertex ident _) _) -> Set.member ident outer+          _                           -> False+  --+  modify $ \s -> s { dotGraph = dotGraph s                         Seq.|> Graph label ss'+                   , dotEdges = Seq.fromList [ e | E e <- lifted ] Seq.>< dotEdges s+                   }+  return label+  where+    go :: Aval aenv' -> DelayedOpenAfun aenv' a' -> Dot Graph+    go aenv' (Abody b) = graphDelayedOpenAcc detail aenv' b+    go aenv' (Alam  f) = do+      a     <- mkLabel+      ident <- mkNodeId f+      _     <- mkNode (PNode ident (Leaf (Nothing, text a)) []) Nothing+      go (Apush aenv' ident a) f++    collect :: Aval aenv' -> HashSet NodeId+    collect Aempty        = Set.empty+    collect (Apush a i _) = Set.insert i (collect a)+++-- Display array tuples. This is a little tricky...+--+prettyDelayedAtuple+    :: forall aenv atup.+       Detail+    -> (Doc -> Doc)+    -> Aval aenv+    -> Atuple (DelayedOpenAcc aenv) atup+    -> Dot PNode+prettyDelayedAtuple detail wrap aenv atup = do+  ident         <- mkNodeId atup+  (ids, ts, vs) <- unzip3 . map (\(PNode i t v) -> (i,t,v)) <$> collect [] atup+  modify $ \s -> s { dotEdges = fmap (redirect ident ids) (dotEdges s) }+  return $ PNode ident (forest ts) (concat vs)+  where+    collect :: [PNode] -> Atuple (DelayedOpenAcc aenv) t -> Dot [PNode]+    collect acc NilAtup          = return acc+    collect acc (SnocAtup tup a) = do+      a'   <- replant =<< prettyDelayedOpenAcc detail wrap aenv a+      tup' <- collect (a':acc) tup+      return tup'++    -- Redirect any edges that pointed into one of the nodes now part of this+    -- tuple, to instead point to the container node.+    --+    redirect :: NodeId -> [NodeId] -> Edge -> Edge+    redirect new subs edge@(Edge from (Vertex to port))+      | to `elem` subs = Edge from (Vertex new port)+      | otherwise      = edge++    -- Since we have lifted out any non-leaves into separate nodes, we can+    -- simply tuple-up all of the elements.+    --+    forest :: [Tree (Maybe Port, Doc)] -> Tree (Maybe Port, Doc)+    forest leaves = Leaf (Nothing, tupled [ align d | Leaf (Nothing,d) <- leaves ])+++-- Lift out anything that isn't a Leaf node and output it to the graph+-- immediately as a new labelled node.+--+replant :: PNode -> Dot PNode+replant pnode@(PNode ident tree _) =+  case tree of+    Leaf (Nothing, _) -> return pnode+    _                 -> do+      vacuous <- mkNodeId pnode+      a       <- mkLabel+      _       <- mkNode pnode (Just a)+      return   $ PNode vacuous (Leaf (Nothing, text a)) [(Vertex ident Nothing, Nothing)]+++-- Pretty printing scalar functions and expressions+-- ------------------------------------------------+--+-- This is done with the usual machinery. Note that we rely on knowing that all+-- array operations will be lifted out of scalar expressions. This means that we+-- don't really need to recurse into the scalar terms to uncover new graph+-- nodes.+--++prettyDelayedFun :: Val aenv -> DelayedFun aenv f -> Doc+prettyDelayedFun = prettyDelayedOpenFun Empty++prettyDelayedExp :: (Doc -> Doc) -> Val aenv -> DelayedExp aenv t -> Doc+prettyDelayedExp wrap = prettyDelayedOpenExp wrap Empty+++prettyDelayedOpenFun+    :: forall env aenv f.+       Val env+    -> Val aenv+    -> DelayedOpenFun env aenv f+    -> Doc+prettyDelayedOpenFun env aenv fun = "\\\\" <> next env fun+  where+    -- graphviz will silently not print a label containing the string "->",+    -- so instead we use the special token "&rarr" for a short right arrow.+    --+    next :: Val env' -> PreOpenFun DelayedOpenAcc env' aenv f' -> Doc+    next env' (Body body) = "&rarr;" <+> prettyDelayedOpenExp noParens env' aenv body+    next env' (Lam fun')  =+      let x = char 'x' <> int (sizeEnv env')+      in  x <+> next (env' `Push` x) fun'++prettyDelayedOpenExp+    :: (Doc -> Doc)+    -> Val env+    -> Val aenv+    -> DelayedOpenExp env aenv t+    -> Doc+prettyDelayedOpenExp = prettyPreOpenExp pp+  where+    pp :: PrettyAcc DelayedOpenAcc+    pp _ aenv (Manifest (Avar ix)) = prj ix aenv+    pp _ _    _                    = $internalError "prettyDelayedOpenExp" "expected array variable"+++-- Data dependencies+-- -----------------+--+-- Return the data-dependencies of the given term. This is just a tree traversal+-- to extract all of the free variables. We will draw an edge from each of those+-- nodes (vertices) into the current term.+--++type FVAcc acc = forall aenv a. Aval aenv -> acc aenv a -> [Vertex]++fvPreOpenFun+    :: forall acc env aenv fun.+       FVAcc acc+    -> Val env+    -> Aval aenv+    -> PreOpenFun acc env aenv fun+    -> [Vertex]+fvPreOpenFun fvA env aenv (Body b) = fvPreOpenExp fvA env                                          aenv b+fvPreOpenFun fvA env aenv (Lam f)  = fvPreOpenFun fvA (env `Push` (char 'x' <> int (sizeEnv env))) aenv f++fvPreOpenExp+    :: forall acc env aenv exp.+       FVAcc acc+    -> Val env+    -> Aval aenv+    -> PreOpenExp acc env aenv exp+    -> [Vertex]+fvPreOpenExp fvA env aenv = fv+  where+    fvT :: Tuple (PreOpenExp acc env aenv) t -> [Vertex]+    fvT NilTup          = []+    fvT (SnocTup tup e) = concat [ fv e, fvT tup ]++    fvF :: PreOpenFun acc env aenv f -> [Vertex]+    fvF = fvPreOpenFun fvA env aenv++    fv :: PreOpenExp acc env aenv e -> [Vertex]+    fv (Shape acc)              = if cfgIncludeShape then fvA aenv acc else []+    fv (Index acc i)            = concat [ fvA aenv acc, fv i ]+    fv (LinearIndex acc i)      = concat [ fvA aenv acc, fv i ]+    --+    fv (Let e1 e2)              = concat [ fv e1, fvPreOpenExp fvA (env `Push` (char 'x' <> int (sizeEnv env))) aenv e2 ]+    fv Var{}                    = []+    fv Undef                    = []+    fv Const{}                  = []+    fv PrimConst{}              = []+    fv (PrimApp _ x)            = fv x+    fv (Tuple tup)              = fvT tup+    fv (Prj _ e)                = fv e+    fv IndexNil                 = []+    fv IndexAny                 = []+    fv (IndexHead sh)           = fv sh+    fv (IndexTail sh)           = fv sh+    fv (IndexCons t h)          = concat [ fv t, fv h ]+    fv (IndexSlice _ slix sh)   = concat [ fv slix, fv sh ]+    fv (IndexFull _ slix sh)    = concat [ fv slix, fv sh ]+    fv (ToIndex sh ix)          = concat [ fv sh, fv ix ]+    fv (FromIndex sh ix)        = concat [ fv sh, fv ix ]+    fv (Union sh1 sh2)          = concat [ fv sh1, fv sh2 ]+    fv (Intersect sh1 sh2)      = concat [ fv sh1, fv sh2 ]+    fv (ShapeSize sh)           = fv sh+    fv Foreign{}                = []+    fv (Cond p t e)             = concat [ fv p, fv t, fv e ]+    fv (While p f x)            = concat [ fvF p, fvF f, fv x ]+    fv (Coerce e)               = fv e+
+ src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      : Data.Array.Accelerate.Pretty.Graphviz.Monad+-- Copyright   : [2015..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.Pretty.Graphviz.Monad+  where++import Control.Applicative+import Control.Monad.State+import Data.Foldable                                    ( toList )+import Data.Sequence                                    ( Seq )+import System.Mem.StableName+import Prelude+import qualified Data.Sequence                          as Seq++import Data.Array.Accelerate.Pretty.Graphviz.Type+++-- Graph construction state ----------------------------------------------------++type Dot a    = StateT DotState IO a+data DotState = DotState+  { fresh       :: !Int+  , dotGraph    :: Seq Graph+  , dotEdges    :: Seq Edge+  , dotNodes    :: Seq Node+  }++emptyState :: DotState+emptyState =  DotState 0 Seq.empty Seq.empty Seq.empty++runDot :: Dot a -> IO (a, DotState)+runDot dot = runStateT dot emptyState++evalDot :: Dot a -> IO a+evalDot dot = fst <$> runDot dot++execDot :: Dot a -> IO DotState+execDot dot = snd <$> runDot dot+++-- Utilities -------------------------------------------------------------------++mkLabel :: Dot Label+mkLabel = state $ \s ->+  let n = fresh s+  in  ( 'a' : show n, s { fresh = n + 1 } )++mkNodeId :: a -> Dot NodeId+mkNodeId node = do+  sn    <- liftIO $ makeStableName node+  return $ NodeId (hashStableName sn)++mkGraph :: Dot Graph+mkGraph =+  state $ \DotState{..} ->+    ( Graph [] (toList $ fmap N dotNodes Seq.>< fmap E dotEdges Seq.>< fmap G dotGraph)+    , emptyState { fresh = fresh }+    )++mkSubgraph :: Dot Graph -> Dot Graph+mkSubgraph g = do+  n       <- gets fresh+  (r, s') <- lift . runDot $ do+    modify $ \s -> s { fresh = n }+    g+  state $ \s -> (r, s { fresh = fresh s' })+
+ src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ViewPatterns       #-}+-- |+-- Module      : Data.Array.Accelerate.Pretty.Graphviz.Type+-- Copyright   : [2015..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)+--+-- Simple data types for representing (simple, directed) graphs and+-- pretty-printing to Graphviz dot format.+--+module Data.Array.Accelerate.Pretty.Graphviz.Type+  where++import Data.Maybe+import Data.Hashable+import Text.Printf+import Text.PrettyPrint.ANSI.Leijen+++-- Rose tree, with all information at the leaves.+--+data Tree a = Leaf a+            | Forest [Tree a]++instance Functor Tree where+  fmap f (Leaf x)    = Leaf (f x)+  fmap f (Forest xs) = Forest (map (fmap f) xs)+++-- Representation for simple Graphviz graphs+--+data Graph      = Graph Label [Statement]+data Statement  = N Node | E Edge | G Graph++data Node       = Node (Maybe Label) NodeId (Tree (Maybe Port, Doc))+data NodeId     = NodeId !Int++-- XXX: Changed from 'Doc' to 'String' because the version of 'pretty' included+--      with ghc-7.8 does not have an Eq Doc instance, which was added in+--      pretty-1.1.1.2. However, we don't want to simply depend on a newer+--      version of the library, because this will indirectly lead to+--      a dependency on multiple versions (through, e.g., template-haskell).+--+type Label      = String+type Port       = String++data Vertex     = Vertex NodeId (Maybe Port)+data Edge       = Edge {- from -} Vertex+                       {-  to  -} Vertex++deriving instance Eq NodeId+deriving instance Eq Vertex++instance Hashable NodeId where+  hashWithSalt salt (NodeId ident) = hashWithSalt salt ident++instance Show Graph where+  show = show . ppGraph+++-- Pretty print a (directed) graph to dot format+--+ppGraph :: Graph -> Doc+ppGraph (Graph l ss) =+  vcat [ text "digraph" <+> text l <+> lbrace+       , nest 4 $ vcat+                $ punctuate semi+                $ text "graph [compound=true]"+                : text "node  [shape=record,fontsize=10]"+                : map ppStatement ss+       , rbrace+       ]++ppSubgraph :: Graph -> Doc+ppSubgraph (Graph l ss) =+  vcat [ text "subgraph cluster_" <> text l <+> lbrace+       , nest 4 $ vcat+                $ punctuate semi+                $ text "label" <> equals <> text l+                : map ppStatement ss+       , rbrace+       ]++ppStatement :: Statement -> Doc+ppStatement (N n) = ppNode n+ppStatement (E e) = ppEdge e+ppStatement (G g) = ppSubgraph g++ppEdge :: Edge -> Doc+ppEdge (Edge from to) = ppVertex from <+> text "->" <+> ppVertex to++ppVertex :: Vertex -> Doc+ppVertex (Vertex n p) = ppNodeId n <> maybe empty (colon<>) (fmap text p)++ppNode :: Node -> Doc+ppNode (Node label nid body) =+  hcat [ ppNodeId nid+       , brackets+       $ hcat+       $ punctuate comma+       $ catMaybes [ fmap ((\x -> text "xlabel" <> equals <> x) . dquotes . text) label+                   , Just (       text "label"  <> equals <>      dquotes (ppNodeTree body))+                   ]+       ]++ppNodeTree :: Tree (Maybe Port, Doc) -> Doc+ppNodeTree (Forest trees)      = braces $ hcat (punctuate (char '|') (map ppNodeTree trees))+ppNodeTree (Leaf (port, body)) = maybe empty (\p -> char '<' <> p <> char '>') (fmap text port) <> pp body+  where+    -- In order for the text to be properly rendered by graphviz, we need to+    -- escape some special characters. If the text takes up more than one line,+    -- then newlines '\n' need be be replaced with '\l', to ensure that the text+    -- is left justified rather than centred. The last line also needs a final+    -- '\l'. Single lines of text remain centred, which provides better+    -- formatting for short statements and port labels.+    --+    pp :: Doc -> Doc+    pp = encode . renderSmart 0.7 120++    encode :: SimpleDoc -> Doc+    encode doc =+      let+          go SFail         = error "unexpected failure rendering SimpleDoc"+          go SEmpty        = (empty, False)+          go (SChar c x)   = let (x',m) = go x in (text (escape c) <> x', m)+          go (SText _ t x) = let (x',m) = go x in (text (concatMap escape t) <> x', m)+          go (SLine i x)   = let (x',_) = go x in (text "\\l" <> spaces i <> x', True)  -- [1] left justify+          go (SSGR _ x)    = go x++          (doc',multiline) = go doc+      in+      doc' <> if multiline+                then text "\\l"+                else empty++    spaces :: Int -> Doc+    spaces i | i <= 0    = empty+             | otherwise = text (concat (replicate i "\\ "))++    escape :: Char -> String+    escape ' '  = "\\ "         -- don't collapse multiple spaces+    escape '>'  = "\\>"+    escape '<'  = "\\<"+    escape '|'  = "\\|"+    -- escape '\n' = "\\l"      -- handled at [1] instead+    escape c    = [c]++ppNodeId :: NodeId -> Doc+ppNodeId (NodeId nid) = text (printf "Node_%#0x" nid)+
+ src/Data/Array/Accelerate/Pretty/Print.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Pretty.Print+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] 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.Pretty.Print (++  -- * Pretty printing+  -- ** 'OpenAcc'+  --+  prettyOpenAcc,+  prettyOpenAfun,+  prettyOpenExp,+  prettyOpenFun,++  -- ** 'PreOpenAcc'+  PrettyAcc,+  prettyPreOpenAcc,+  prettyPreOpenAfun,+  -- prettyPreOpenSeq,+  prettyPreExp, prettyPreOpenExp,+  prettyPreFun, prettyPreOpenFun,+  prettyPrim,+  prettyArrays,+  prettyTupleIdx,++  -- ** Utilities+  Val(..), PrettyEnv(..), prj, sizeEnv,+  noParens,++) where++-- standard libraries+import Prelude                                          hiding ( (<$>), exp, seq )+import Data.List                                        ( isPrefixOf )+import Data.Typeable                                    ( typeOf, showsTypeRep )+import Text.PrettyPrint.ANSI.Leijen                     hiding ( parens, tupled )+import qualified Text.PrettyPrint.ANSI.Leijen           as PP++-- friends+import Data.Array.Accelerate.AST                        hiding ( Val(..), prj )+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Type+++-- Pretty printing+-- ===============++-- Pretty printing for the knot-tied 'OpenAcc'+-- -------------------------------------------++-- Pretty print an array expression+--+prettyOpenAcc :: PrettyAcc OpenAcc+prettyOpenAcc wrap aenv (OpenAcc acc) = prettyPreOpenAcc prettyOpenAcc wrap aenv acc++prettyOpenAfun :: Val aenv -> OpenAfun aenv t -> Doc+prettyOpenAfun = prettyPreOpenAfun prettyOpenAcc+++-- Pretty print scalar expressions+--+prettyOpenFun :: Val env -> Val aenv -> OpenFun env aenv fun -> Doc+prettyOpenFun = prettyPreOpenFun prettyOpenAcc++prettyOpenExp :: (Doc -> Doc) -> Val env -> Val aenv -> OpenExp env aenv t -> Doc+prettyOpenExp = prettyPreOpenExp prettyOpenAcc+++-- Pretty printing for open 'PreOpenAcc'+-- -------------------------------------++-- The type of pretty printing functions for array computations.+--+type PrettyAcc acc = forall aenv t.+       (Doc -> Doc)+    -> Val aenv+    -> acc aenv t+    -> Doc++prettyPreOpenAcc+    :: forall acc aenv arrs.+       PrettyAcc acc+    -> (Doc -> Doc)                             -- apply to compound expressions+    -> Val aenv                                 -- environment of array variables+    -> PreOpenAcc acc aenv arrs+    -> Doc+prettyPreOpenAcc prettyAcc wrap aenv = pp+  where+    ppE :: PreExp acc aenv e -> Doc+    ppE = prettyPreExp prettyAcc parens aenv++    ppSh :: PreExp acc aenv sh -> Doc+    ppSh x = encase (prettyPreExp prettyAcc noParens aenv x)+      where+        encase = case x of+                   Var{}    -> id+                   IndexNil -> id+                   IndexAny -> id+                   Const{}  -> id+                   _        -> parens++    ppF :: PreFun acc aenv f -> Doc+    ppF = parens . prettyPreFun prettyAcc aenv++    ppA :: acc aenv a -> Doc+    ppA = prettyAcc parens aenv++    ppAF :: PreOpenAfun acc aenv f -> Doc+    ppAF = parens . prettyPreOpenAfun prettyAcc aenv++    ppB :: forall sh e. (Shape sh, Elt e)+        => PreBoundary acc aenv (Array sh e)+        -> Doc+    ppB Clamp        = text "clamp"+    ppB Mirror       = text "mirror"+    ppB Wrap         = text "wrap"+    ppB (Constant e) = parens $ text "constant" <+> text (show (toElt e :: e))+    ppB (Function f) = ppF f++    -- pretty print a named array operation with its arguments+    infixr 0 .$+    name .$ docs = wrap $ hang 2 (sep (manifest (text name) : docs))++    -- The main pretty-printer+    -- -----------------------+    --+    pp :: PreOpenAcc acc aenv arrs -> Doc+    pp (Alet acc1 acc2)+      | isAlet acc2'+      = if isAlet acc1'+          then wrap $ vsep [ let_ <+> a <+> equals <$> indent 2 acc1'    <+> in_, acc2' ]+          else wrap $ vsep [ hang 2 (sep [let_ <+> a <+> equals, acc1']) <+> in_, acc2' ]++      | otherwise+      = wrap $ vsep [ hang 2 (sep [let_ <+> a <+> equals, acc1']), in_ </> acc2' ]+      where+        -- TLM: derp, can't unwrap into a PreOpenAcc to pattern match on Alet+        render doc  = displayS (renderCompact (plain doc)) ""+        isAlet doc  = "let" `isPrefixOf` render doc+        acc1'       = prettyAcc noParens aenv            acc1+        acc2'       = prettyAcc noParens (aenv `Push` a) acc2+        a           = char 'a' <> int (sizeEnv aenv)++    pp (Awhile p afun acc)      = "awhile" .$ [ppAF p, ppAF afun, ppA acc]+    pp (Atuple tup)             = prettyAtuple prettyAcc aenv tup+    pp (Avar idx)               = prj idx aenv+    pp (Aprj ix arrs)           = wrap $ prettyTupleIdx ix <+> ppA arrs+    pp (Apply afun acc)         = wrap $ sep [ ppAF afun, ppA acc ]+    pp (Acond e acc1 acc2)      = wrap $ hang 3 (vsep [if_ <+> ppE e, then_ <+> ppA acc1, else_ <+> ppA acc2])+    pp (Slice _ty acc ix)       = "slice"       .$ [ ppA acc, ppE ix ]+    pp (Use arrs)               = "use"         .$ [ prettyArrays (arrays (undefined :: arrs)) arrs ]+    pp (Unit e)                 = "unit"        .$ [ ppE e ]+    pp (Generate sh f)          = "generate"    .$ [ ppSh sh, ppF f ]+    pp (Transform sh ix f acc)  = "transform"   .$ [ ppSh sh, ppF ix, ppF f, ppA acc ]+    pp (Reshape sh acc)         = "reshape"     .$ [ ppSh sh, ppA acc ]+    pp (Replicate _ty ix acc)   = "replicate"   .$ [ ppSh ix, ppA acc ]+    pp (Map f acc)              = "map"         .$ [ ppF f, ppA acc ]+    pp (ZipWith f acc1 acc2)    = "zipWith"     .$ [ ppF f, ppA acc1, ppA acc2 ]+    pp (Fold f e acc)           = "fold"        .$ [ ppF f, ppE e, ppA acc ]+    pp (Fold1 f acc)            = "fold1"       .$ [ ppF f, ppA acc ]+    pp (FoldSeg f e acc1 acc2)  = "foldSeg"     .$ [ ppF f, ppE e, ppA acc1, ppA acc2 ]+    pp (Fold1Seg f acc1 acc2)   = "fold1Seg"    .$ [ ppF f, ppA acc1, ppA acc2 ]+    pp (Scanl f e acc)          = "scanl"       .$ [ ppF f, ppE e, ppA acc ]+    pp (Scanl' f e acc)         = "scanl'"      .$ [ ppF f, ppE e, ppA acc ]+    pp (Scanl1 f acc)           = "scanl1"      .$ [ ppF f, ppA acc ]+    pp (Scanr f e acc)          = "scanr"       .$ [ ppF f, ppE e, ppA acc ]+    pp (Scanr' f e acc)         = "scanr'"      .$ [ ppF f, ppE e, ppA acc ]+    pp (Scanr1 f acc)           = "scanr1"      .$ [ ppF f, ppA acc ]+    pp (Permute f dfts p acc)   = "permute"     .$ [ ppF f, ppA dfts, ppF p, ppA acc ]+    pp (Backpermute sh p acc)   = "backpermute" .$ [ ppSh sh, ppF p, ppA acc ]+    pp (Aforeign ff _afun acc)  = "aforeign"    .$ [ text (strForeign ff), {- ppAf afun, -} ppA acc ]+    pp (Stencil sten bndy acc)  = "stencil"     .$ [ ppF sten, ppB bndy, ppA acc ]+    pp (Stencil2 sten bndy1 acc1 bndy2 acc2)+                                = "stencil2"    .$ [ ppF sten, ppB bndy1, ppA acc1, ppB bndy2, ppA acc2 ]++    -- pp (Collect s)              = wrap $ hang (text "collect") 2+    --                                    $ encloseSep lbrace rbrace semi+    --                                    $ prettyPreOpenSeq prettyAcc wrap aenv Empty s+++{--+-- Pretty print a computation over sequences+--+prettyPreOpenSeq+    :: forall acc aenv senv arrs.+       PrettyAcc acc+    -> (Doc -> Doc)                             -- apply to compound expressions+    -> Val aenv                                 -- environment of array variables+    -> Val senv                                 -- environment of sequence variables+    -> PreOpenSeq acc aenv senv arrs+    -> [Doc]+prettyPreOpenSeq prettyAcc wrap aenv senv seq =+  case seq of+    Producer p s' -> prettyP p : prettyPreOpenSeq prettyAcc wrap aenv (senv `Push` var (sizeEnv senv)) s'+    Consumer c    -> [prettyC c]+    Reify ix      -> [var (idxToInt ix)]+  where+    var n         = char 's' <> int n+    name .$  docs = wrap $ hang (var (sizeEnv senv) <+> text ":=" <+> text name) 2 (sep docs)+    name ..$ docs = wrap $ hang (text name) 2 (sep docs)++    ppE :: PreExp acc aenv e -> Doc+    ppE = prettyPreExp prettyAcc parens aenv++    ppF :: PreFun acc aenv f -> Doc+    ppF = parens . prettyPreFun prettyAcc aenv++    ppA :: acc aenv a -> Doc+    ppA = prettyAcc parens aenv++    ppAF :: PreOpenAfun acc aenv f -> Doc+    ppAF = parens . prettyPreOpenAfun prettyAcc aenv++    ppX :: Idx aenv' a -> Doc+    ppX x = var (idxToInt x)++    ppSlix :: SliceIndex slix sl co sh -> Doc+    ppSlix SliceNil       = text "Z"+    ppSlix (SliceAll s)   = sep [ ppSlix s, text ":.", text "All"   ]+    ppSlix (SliceFixed s) = sep [ ppSlix s, text ":.", text "Split" ]++    prettyP :: forall a. Producer acc aenv senv a -> Doc+    prettyP p =+      case p of+        StreamIn _        -> "streamIn"      .$ [ text "..." ]+        ToSeq slix _ a    -> "toSeq"         .$ [ ppSlix slix, ppA a ]+        MapSeq f x        -> "mapSeq"        .$ [ ppAF f , ppX x ]+        ChunkedMapSeq f x -> "chunkedMapSeq" .$ [ ppAF f , ppX x ]+        ZipWithSeq f x y  -> "zipWithSeq"    .$ [ ppAF f , ppX x , ppX y ]+        ScanSeq f e x     -> "foldSeq"       .$ [ ppF f , ppE e , ppX x ]++    prettyC :: forall a. Consumer acc aenv senv a -> Doc+    prettyC c =+      case c of+        FoldSeq f e x        -> "foldSeq"        ..$ [ ppF f , ppE e , ppX x ]+        FoldSeqFlatten f a x -> "foldSeqFlatten" ..$ [ ppAF f , ppA a , ppX x ]+        Stuple t             -> tupled (prettyT t)++    prettyT :: forall t. Atuple (Consumer acc aenv senv) t -> [Doc]+    prettyT NilAtup        = []+    prettyT (SnocAtup t c) = prettyT t ++ [prettyC c]+--}+++-- Pretty print a function over array computations.+--+prettyPreOpenAfun+    :: forall acc aenv f.+       PrettyAcc acc+    -> Val aenv+    -> PreOpenAfun acc aenv f+    -> Doc+prettyPreOpenAfun pp aenv afun = char '\\' <> next aenv afun+  where+    next :: Val aenv' -> PreOpenAfun acc aenv' f' -> Doc+    next aenv' (Abody body) = text "->" <+> align (pp noParens aenv' body)+    next aenv' (Alam afun') =+      let a = char 'a' <> int (sizeEnv aenv')+      in  a <+> next (aenv' `Push` a) afun'+++-- Pretty print a scalar function.+--+prettyPreFun :: PrettyAcc acc -> Val aenv -> PreFun acc aenv fun -> Doc+prettyPreFun pp = prettyPreOpenFun pp Empty++prettyPreOpenFun+    :: forall acc env aenv f.+       PrettyAcc acc+    -> Val env                                  -- environment of scalar variables+    -> Val aenv                                 -- environment of array variables+    -> PreOpenFun acc env aenv f+    -> Doc+prettyPreOpenFun pp env aenv fun = char '\\' <> next env fun+  where+    next :: Val env' -> PreOpenFun acc env' aenv f' -> Doc+    next env' (Body body) = text "->" <+> align (prettyPreOpenExp pp noParens env' aenv body)+    next env' (Lam fun')  =+      let x = char 'x' <> int (sizeEnv env')+      in  x <+> next (env' `Push` x) fun'+++-- Pretty print a scalar expression.+--+prettyPreExp :: PrettyAcc acc -> (Doc -> Doc) -> Val aenv -> PreExp acc aenv t -> Doc+prettyPreExp pp wrap = prettyPreOpenExp pp wrap Empty++prettyPreOpenExp+    :: forall acc t env aenv.+       PrettyAcc acc+    -> (Doc -> Doc)                             -- apply to compound expressions+    -> Val env                                  -- environment of scalar variables+    -> Val aenv                                 -- environment of array variables+    -> PreOpenExp acc env aenv t+    -> Doc+prettyPreOpenExp prettyAcc wrap env aenv = pp+  where+    ppE, ppE' :: PreOpenExp acc env aenv e -> Doc+    ppE  = prettyPreOpenExp prettyAcc parens env aenv+    ppE' = prettyPreOpenExp prettyAcc noParens env aenv++    ppSh :: PreOpenExp acc env aenv sh -> Doc+    ppSh x = encase (ppE' x)+      where+        encase = case x of+                   Var{}    -> id+                   IndexNil -> id+                   IndexAny -> id+                   Const{}  -> id+                   _        -> parens++    ppF :: PreOpenFun acc env aenv f -> Doc+    ppF = parens . prettyPreOpenFun prettyAcc env aenv++    ppA :: acc aenv a -> Doc+    ppA = prettyAcc parens aenv++    -- pretty print a named array operation with its arguments+    infixr 0 .$+    name .$ docs = wrap $ hang 2 (sep (text name : docs))++    -- The main pretty-printer+    -- -----------------------+    --+    pp :: PreOpenExp acc env aenv t -> Doc+    pp (Let e1 e2)+      | isLet e2+      = if isLet e1+          then wrap $ vsep [ let_ <+> x <+> equals <$> indent 2 e1'    <+> in_, e2' ]+          else wrap $ vsep [ hang 2 (sep [let_ <+> x <+> equals, e1']) <+> in_, e2' ]+      | otherwise+      = wrap $ vsep [ hang 2 (sep [let_ <+> x <+> equals, e1']), in_ </> e2' ]+      where+        isLet (Let _ _)     = True+        isLet _             = False+        e1'                 = align $ prettyPreOpenExp prettyAcc noParens env            aenv e1+        e2'                 = align $ prettyPreOpenExp prettyAcc noParens (env `Push` x) aenv e2+        x                   = char 'x' <> int (sizeEnv env)++    pp (PrimApp p a)+      | Tuple (NilTup `SnocTup` x `SnocTup` y) <- a+      = if infixOp+          then wrap $ sep [ppE x, f, ppE y]+          else hang 2 (sep [f, ppSh x, ppSh y])+      | otherwise+      = wrap $ hang 2 (sep [f', ppE a])+      where+        -- sometimes the infix function arguments are obstructed. If so, add+        -- parentheses and print prefix.+        --+        (infixOp, f) = prettyPrim p+        f'           = if infixOp then parens f else f++    pp (PrimConst a)            = prettyConst a+    pp (Tuple tup)              = prettyTuple (eltType (undefined::t)) prettyAcc env aenv tup+    pp (Var idx)                = prj idx env+    pp (Const v)                = text $ show (toElt v :: t)+    pp (Prj idx e)              = wrap $ prettyTupleIdx idx <+> ppE e+    pp (Cond c t e)             = wrap $ hang 3 (vsep [ if_ <+> ppE' c, then_ <+> ppE' t, else_ <+> ppE' e ])+    pp Undef                    = text "undef"+    pp IndexNil                 = char 'Z'+    pp IndexAny                 = text "indexAny"+    pp (IndexCons t h)          = sep [ ppE' t, text ":.", ppE' h ]+    pp (IndexHead ix)           = "indexHead"  .$ [ ppE ix ]+    pp (IndexTail ix)           = "indexTail"  .$ [ ppE ix ]+    pp (IndexSlice _ slix sh)   = "indexSlice" .$ [ ppSh slix, ppSh sh ]+    pp (IndexFull _ slix sl)    = "indexFull"  .$ [ ppSh slix, ppSh sl ]+    pp (ToIndex sh ix)          = "toIndex"    .$ [ ppSh sh, ppSh ix ]+    pp (FromIndex sh ix)        = "fromIndex"  .$ [ ppSh sh, ppSh ix ]+    pp (While p f x)            = "while"      .$ [ ppF p, ppF f, ppE x ]+    pp (Foreign ff _f e)        = "foreign"    .$ [ text (strForeign ff), {- ppF f, -} ppE e ]+    pp (Shape idx)              = "shape"      .$ [ ppA idx ]+    pp (ShapeSize idx)          = "shapeSize"  .$ [ ppSh idx ]+    pp (Intersect sh1 sh2)      = "intersect"  .$ [ ppSh sh1, ppSh sh2 ]+    pp (Union sh1 sh2)          = "union"      .$ [ ppSh sh1, ppSh sh2 ]+    pp (Index idx i)            = wrap $ cat [ ppA idx, char '!',  ppSh i ]+    pp (LinearIndex idx i)      = wrap $ cat [ ppA idx, text "!!", ppSh i ]+    pp (Coerce x)               = "coerce<" ++ showsTypeRep (typeOf (undefined::t)) ">" .$ [ ppE x ]+++-- Pretty print nested pairs as a proper tuple.+--+prettyAtuple+    :: forall acc aenv t.+       PrettyAcc acc+    -> Val aenv+    -> Atuple (acc aenv) t+    -> Doc+prettyAtuple pp aenv = tupled False . collect+  where+    collect :: Atuple (acc aenv) t' -> [Doc]+    collect NilAtup          = []+    collect (SnocAtup tup a) = collect tup ++ [pp noParens aenv a]++prettyTuple+    :: forall acc env aenv t p.+       TupleType t+    -> PrettyAcc acc+    -> Val env+    -> Val aenv+    -> Tuple (PreOpenExp acc env aenv) p+    -> Doc+prettyTuple tt pp env aenv = tupled simd . collect+  where+    collect :: Tuple (PreOpenExp acc env aenv) t' -> [Doc]+    collect NilTup          = []+    collect (SnocTup tup e) = collect tup ++ [prettyPreOpenExp pp noParens env aenv e]++    simd :: Bool+    simd | TypeRscalar VectorScalarType{} <- tt = True+         | otherwise                            = False+++-- Pretty print an index for a tuple projection+--+prettyTupleIdx :: TupleIdx t e -> Doc+prettyTupleIdx ix = char '#' <> int (toInt ix)+  where+    toInt :: TupleIdx t e -> Int+    toInt ZeroTupIdx       = 0+    toInt (SuccTupIdx tup) = toInt tup + 1++-- Pretty print a primitive constant+--+prettyConst :: PrimConst a -> Doc+prettyConst (PrimMinBound _) = text "minBound"+prettyConst (PrimMaxBound _) = text "maxBound"+prettyConst (PrimPi       _) = text "pi"++-- Pretty print a primitive operation. The first parameter indicates whether the+-- operator should be printed infix.+--+prettyPrim :: PrimFun a -> (Bool, Doc)+prettyPrim PrimAdd{}                = (True,  char '+')+prettyPrim PrimSub{}                = (True,  char '-')+prettyPrim PrimMul{}                = (True,  char '*')+prettyPrim PrimNeg{}                = (False, text "negate")+prettyPrim PrimAbs{}                = (False, text "abs")+prettyPrim PrimSig{}                = (False, text "signum")+prettyPrim PrimQuot{}               = (False, text "quot")+prettyPrim PrimRem{}                = (False, text "rem")+prettyPrim PrimQuotRem{}            = (False, text "quotRem")+prettyPrim PrimIDiv{}               = (False, text "div")+prettyPrim PrimMod{}                = (False, text "mod")+prettyPrim PrimDivMod{}             = (False, text "divMod")+prettyPrim PrimBAnd{}               = (True,  text ".&.")+prettyPrim PrimBOr{}                = (True,  text ".|.")+prettyPrim PrimBXor{}               = (False, text "xor")+prettyPrim PrimBNot{}               = (False, text "complement")+prettyPrim PrimBShiftL{}            = (False, text "shiftL")+prettyPrim PrimBShiftR{}            = (False, text "shiftR")+prettyPrim PrimBRotateL{}           = (False, text "rotateL")+prettyPrim PrimBRotateR{}           = (False, text "rotateR")+prettyPrim PrimPopCount{}           = (False, text "popCount")+prettyPrim PrimCountLeadingZeros{}  = (False, text "countLeadingZeros")+prettyPrim PrimCountTrailingZeros{} = (False, text "countTrailingZeros")+prettyPrim PrimFDiv{}               = (True,  char '/')+prettyPrim PrimRecip{}              = (False, text "recip")+prettyPrim PrimSin{}                = (False, text "sin")+prettyPrim PrimCos{}                = (False, text "cos")+prettyPrim PrimTan{}                = (False, text "tan")+prettyPrim PrimAsin{}               = (False, text "asin")+prettyPrim PrimAcos{}               = (False, text "acos")+prettyPrim PrimAtan{}               = (False, text "atan")+prettyPrim PrimSinh{}               = (False, text "sinh")+prettyPrim PrimCosh{}               = (False, text "cosh")+prettyPrim PrimTanh{}               = (False, text "tanh")+prettyPrim PrimAsinh{}              = (False, text "asinh")+prettyPrim PrimAcosh{}              = (False, text "acosh")+prettyPrim PrimAtanh{}              = (False, text "atanh")+prettyPrim PrimExpFloating{}        = (False, text "exp")+prettyPrim PrimSqrt{}               = (False, text "sqrt")+prettyPrim PrimLog{}                = (False, text "log")+prettyPrim PrimFPow{}               = (True,  text "**")+prettyPrim PrimLogBase{}            = (False, text "logBase")+prettyPrim PrimTruncate{}           = (False, text "truncate")+prettyPrim PrimRound{}              = (False, text "round")+prettyPrim PrimFloor{}              = (False, text "floor")+prettyPrim PrimCeiling{}            = (False, text "ceiling")+prettyPrim PrimAtan2{}              = (False, text "atan2")+prettyPrim PrimIsNaN{}              = (False, text "isNaN")+prettyPrim PrimIsInfinite{}         = (False, text "isInfinite")+prettyPrim PrimLt{}                 = (True,  text "<")+prettyPrim PrimGt{}                 = (True,  text ">")+prettyPrim PrimLtEq{}               = (True,  text "<=")+prettyPrim PrimGtEq{}               = (True,  text ">=")+prettyPrim PrimEq{}                 = (True,  text "==")+prettyPrim PrimNEq{}                = (True,  text "/=")+prettyPrim PrimMax{}                = (False, text "max")+prettyPrim PrimMin{}                = (False, text "min")+prettyPrim PrimLAnd                 = (True,  text "&&")+prettyPrim PrimLOr                  = (True,  text "||")+prettyPrim PrimLNot                 = (False, text "not")+prettyPrim PrimOrd                  = (False, text "ord")+prettyPrim PrimChr                  = (False, text "chr")+prettyPrim PrimBoolToInt            = (False, text "boolToInt")+prettyPrim PrimFromIntegral{}       = (False, text "fromIntegral")+prettyPrim PrimToFloating{}         = (False, text "toFloating")++{-+-- Pretty print type+--+prettyAnyType :: ScalarType a -> Doc+prettyAnyType ty = text $ show ty+-}++-- TLM: seems to flatten the nesting structure+--+prettyArrays :: ArraysR arrs -> arrs -> Doc+prettyArrays arrs = tupled False . collect arrs+  where+    collect :: ArraysR arrs -> arrs -> [Doc]+    collect ArraysRunit         _        = []+    collect ArraysRarray        arr      = [prettyArray arr]+    collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2++prettyArray :: forall dim e. Array dim e -> Doc+prettyArray arr@(Array sh _)+  = hang 2 $ sep [ text "Array"+                 , parens . text $ showShape (toElt sh :: dim)+                 , dataDoc ]+  where+    showDoc :: forall a. Show a => a -> Doc+    showDoc = text . show+    l       = toList arr+    dataDoc | length l <= 1000 = showDoc l+            | otherwise        = showDoc (take 1000 l) <+>+                                 text "{truncated at 1000 elements}"+++-- Auxiliary pretty printing combinators+--++parens :: Doc -> Doc+parens = PP.parens . align++noParens :: Doc -> Doc+noParens = id++tupled :: Bool -> [Doc] -> Doc+tupled True  = encloseSep langle rangle comma . map align+tupled False = encloseSep lparen rparen comma . map align+++-- ANSI colourisation+--++control :: Doc -> Doc+control = dullyellow++manifest :: Doc -> Doc+manifest = blue++-- delayed :: Doc -> Doc+-- delayed = green++let_, in_ :: Doc+let_ = control (text "let")+in_  = control (text "in")++if_, then_, else_ :: Doc+if_   = control (text "if")+then_ = control (text "then")+else_ = control (text "else")+++-- Environments+-- ------------++data Val env where+  Empty ::                   Val ()+  Push  :: Val env -> Doc -> Val (env, t)++class PrettyEnv env where+  prettyEnv :: Val env++instance PrettyEnv () where+  prettyEnv = Empty++instance PrettyEnv env => PrettyEnv (env, t) where+  prettyEnv =+    let env = prettyEnv :: Val env+        x   = char 'a' <> int (sizeEnv env)+    in+    env `Push` x++sizeEnv :: Val env -> Int+sizeEnv Empty        = 0+sizeEnv (Push env _) = 1 + sizeEnv env++prj :: Idx env t -> Val env -> Doc+prj ZeroIdx      (Push _ v)   = v+prj (SuccIdx ix) (Push env _) = prj ix env+#if __GLASGOW_HASKELL__ < 800+prj _            _            = error "inconsistent valuation"+#endif+++-- Auxiliary operations+-- --------------------++-- Auxiliary dictionary operations+--++{-+-- Show scalar values+--+runScalarShow :: ScalarType a -> (a -> String)+runScalarShow (NumScalarType (IntegralNumType ty))+  | IntegralDict <- integralDict ty = show+runScalarShow (NumScalarType (FloatingNumType ty))+  | FloatingDict <- floatingDict ty = show+runScalarShow (NonNumScalarType ty)+  | NonNumDict   <- nonNumDict ty   = show+-}+
+ src/Data/Array/Accelerate/Product.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Product+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+--               [2013..2017] Robert Clifton-Everest+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- Our representation of products are heterogenous snoc lists, which are typed by+-- type lists, where '()' and '(,)' are type-level nil and snoc, respectively.+-- The components may only be drawn from types that can be used as array+-- elements.+--++module Data.Array.Accelerate.Product (++  -- * Tuple representation+  TupleIdx(..), IsProduct(..), ProdR(..)++) where++import Data.Array.Accelerate.Type+++-- |Type-safe projection indices for tuples.+--+-- NB: We index tuples by starting to count from the *right*!+--+data TupleIdx t e where+  ZeroTupIdx ::                 TupleIdx (t, s) s+  SuccTupIdx :: TupleIdx t e -> TupleIdx (t, s) e++-- |Product reification+--+data ProdR cst t where+  ProdRunit   :: ProdR cst ()+  ProdRsnoc   :: cst e => ProdR cst t -> ProdR cst (t,e)++-- |Conversion between surface product types and our product representation.+--+-- We parameterise our products by a constraint on their elements (the 'cst' argument). Every element+-- in the product must obey this constraint, but the products themselves do necessarily not have to.+--+class IsProduct cst tup where+  type ProdRepr tup+  fromProd :: proxy cst -> tup -> ProdRepr tup+  toProd   :: proxy cst -> ProdRepr tup -> tup+  prod     :: proxy cst -> {- dummy -} tup -> ProdR cst (ProdRepr tup)++instance IsProduct cst () where+  type ProdRepr ()   = ()+  fromProd _         = id+  toProd _           = id+  prod _ _           = ProdRunit++instance (cst a, cst b) => IsProduct cst (a, b) where+  type ProdRepr (a, b)   = (((), a), b)+  fromProd _ (a, b)      = (((), a), b)+  toProd _ (((), a), b)  = (a, b)+  prod _ _               = ProdRsnoc $ ProdRsnoc ProdRunit++instance (cst a, cst b, cst c) => IsProduct cst (a, b, c) where+  type ProdRepr (a, b, c)    = (ProdRepr (a, b), c)+  fromProd _ (a, b, c)       = ((((), a), b), c)+  toProd _ ((((), a), b), c) = (a, b, c)+  prod p _                   = ProdRsnoc (prod p (undefined :: (a,b)))++instance (cst a, cst b, cst c, cst d) => IsProduct cst (a, b, c, d) where+  type ProdRepr (a, b, c, d)      = (ProdRepr (a, b, c), d)+  fromProd _ (a, b, c, d)         = (((((), a), b), c), d)+  toProd _ (((((), a), b), c), d) = (a, b, c, d)+  prod p _                        = ProdRsnoc (prod p (undefined :: (a,b,c)))++instance (cst a, cst b, cst c, cst d, cst e) => IsProduct cst (a, b, c, d, e) where+  type ProdRepr (a, b, c, d, e)        = (ProdRepr (a, b, c, d), e)+  fromProd _ (a, b, c, d, e)           = ((((((), a), b), c), d), e)+  toProd _ ((((((), a), b), c), d), e) = (a, b, c, d, e)+  prod p _                             = ProdRsnoc (prod p (undefined :: (a,b,c,d)))++instance (cst a, cst b, cst c, cst d, cst e, cst f) => IsProduct cst (a, b, c, d, e, f) where+  type ProdRepr (a, b, c, d, e, f)          = (ProdRepr (a, b, c, d, e), f)+  fromProd _ (a, b, c, d, e, f)             = (((((((), a), b), c), d), e), f)+  toProd _ (((((((), a), b), c), d), e), f) = (a, b, c, d, e, f)+  prod p _                                  = ProdRsnoc (prod p (undefined :: (a,b,c,d,e)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g)+  => IsProduct cst (a, b, c, d, e, f, g) where+  type ProdRepr (a, b, c, d, e, f, g)            = (ProdRepr (a, b, c, d, e, f), g)+  fromProd _ (a, b, c, d, e, f, g)               = ((((((((), a), b), c), d), e), f), g)+  toProd _ ((((((((), a), b), c), d), e), f), g) = (a, b, c, d, e, f, g)+  prod p _                                       = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h)+  => IsProduct cst (a, b, c, d, e, f, g, h) where+  type ProdRepr (a, b, c, d, e, f, g, h)              = (ProdRepr (a, b, c, d, e, f, g), h)+  fromProd _ (a, b, c, d, e, f, g, h)                 = (((((((((), a), b), c), d), e), f), g), h)+  toProd _ (((((((((), a), b), c), d), e), f), g), h) = (a, b, c, d, e, f, g, h)+  prod p _                                            = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i)+  => IsProduct cst (a, b, c, d, e, f, g, h, i) where+  type ProdRepr (a, b, c, d, e, f, g, h, i) = (ProdRepr (a, b, c, d, e, f, g, h), i)+  fromProd _ (a, b, c, d, e, f, g, h, i)+    = ((((((((((), a), b), c), d), e), f), g), h), i)+  toProd _ ((((((((((), a), b), c), d), e), f), g), h), i)+    = (a, b, c, d, e, f, g, h, i)+  prod p _+    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j)+  => IsProduct cst (a, b, c, d, e, f, g, h, i, j) where+  type ProdRepr (a, b, c, d, e, f, g, h, i, j) = (ProdRepr (a, b, c, d, e, f, g, h, i), j)+  fromProd _ (a, b, c, d, e, f, g, h, i, j)+    = (((((((((((), a), b), c), d), e), f), g), h), i), j)+  toProd _ (((((((((((), a), b), c), d), e), f), g), h), i), j)+    = (a, b, c, d, e, f, g, h, i, j)+  prod p _+    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k)+  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k) where+  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k) = (ProdRepr (a, b, c, d, e, f, g, h, i, j), k)+  fromProd _ (a, b, c, d, e, f, g, h, i, j, k)+    = ((((((((((((), a), b), c), d), e), f), g), h), i), j), k)+  toProd _ ((((((((((((), a), b), c), d), e), f), g), h), i), j), k)+    = (a, b, c, d, e, f, g, h, i, j, k)+  prod p _+    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k, cst l)+  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k, l) where+  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l) = (ProdRepr (a, b, c, d, e, f, g, h, i, j, k), l)+  fromProd _ (a, b, c, d, e, f, g, h, i, j, k, l)+    = (((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l)+  toProd _ (((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l)+    = (a, b, c, d, e, f, g, h, i, j, k, l)+  prod p _+    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j,k)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k, cst l, cst m)+  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m) = (ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l), m)+  fromProd _ (a, b, c, d, e, f, g, h, i, j, k, l, m)+    = ((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m)+  toProd _ ((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m)+    = (a, b, c, d, e, f, g, h, i, j, k, l, m)+  prod p _+    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j,k,l)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k, cst l, cst m, cst n)+  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = (ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m), n)+  fromProd _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+    = (((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n)+  toProd _ (((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n)+    = (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+  prod p _+    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j,k,l,m)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k, cst l, cst m, cst n, cst o)+  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = (ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n), o)+  fromProd _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+    = ((((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n), o)+  toProd _ ((((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n), o)+    = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+  prod p _+    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n)))++instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, cst k, cst l, cst m, cst n, cst o, cst p)+  => IsProduct cst (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where+  type ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = (ProdRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o), p)+  fromProd _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+    = (((((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n), o), p)+  toProd _ (((((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n), o), p)+    = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+  prod p _+    = ProdRsnoc (prod p (undefined :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)))++instance cst a => IsProduct cst (V2 a) where+  type ProdRepr (V2 a)  = ProdRepr (a, a)+  fromProd cst (V2 a b) = fromProd cst (a, b)+  toProd cst p          = let (a, b) = toProd cst p in V2 a b+  prod cst _            = prod cst (undefined :: (a,a))++instance cst a => IsProduct cst (V3 a) where+  type ProdRepr (V3 a)    = ProdRepr (a, a, a)+  fromProd cst (V3 a b c) = fromProd cst (a, b, c)+  toProd cst p            = let (a, b, c) = toProd cst p in V3 a b c+  prod cst _              = prod cst (undefined :: (a,a,a))++instance cst a => IsProduct cst (V4 a) where+  type ProdRepr (V4 a)      = ProdRepr (a, a, a, a)+  fromProd cst (V4 a b c d) = fromProd cst (a, b, c, d)+  toProd cst p              = let (a, b, c, d) = toProd cst p in V4 a b c d+  prod cst _                = prod cst (undefined :: (a,a,a,a))++instance cst a => IsProduct cst (V8 a) where+  type ProdRepr (V8 a) = ProdRepr (a, a, a, a, a, a, a, a)+  fromProd cst (V8 a b c d e f g h)+    = fromProd cst (a, b, c, d, e, f, g, h)+  toProd cst p+    = let (a, b, c, d, e, f, g, h) = toProd cst p+      in  V8 a b c d e f g h+  prod cst _+    = prod cst (undefined :: (a,a,a,a,a,a,a,a))++instance cst a => IsProduct cst (V16 a) where+  type ProdRepr (V16 a) = ProdRepr (a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a)+  fromProd cst (V16 a b c d e f g h i j k l m n o p)+    = fromProd cst (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+  toProd cst x+    = let (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = toProd cst x+      in  V16 a b c d e f g h i j k l m n o p+  prod cst _+    = prod cst (undefined :: (a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a))+
+ src/Data/Array/Accelerate/Smart.hs view
@@ -0,0 +1,2313 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Smart+-- 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)+--+-- This modules defines the AST of the user-visible embedded language using more+-- convenient higher-order abstract syntax (instead of de Bruijn indices).+-- Moreover, it defines smart constructors to construct programs.+--++module Data.Array.Accelerate.Smart (++  -- * HOAS AST+  Acc(..), PreAcc(..), Exp(..), PreExp(..), Boundary(..), PreBoundary(..), Stencil(..), Level,++  -- * Smart constructors for literals+  constant, undef,++  -- * Smart constructors and destructors for tuples+  tup2, tup3, tup4, tup5, tup6, tup7, tup8, tup9, tup10, tup11, tup12, tup13, tup14, tup15, tup16,+  untup2, untup3, untup4, untup5, untup6, untup7, untup8, untup9, untup10, untup11, untup12, untup13, untup14, untup15, untup16,++  atup2, atup3, atup4, atup5, atup6, atup7, atup8, atup9, atup10, atup11, atup12, atup13, atup14, atup15, atup16,+  unatup2, unatup3, unatup4, unatup5, unatup6, unatup7, unatup8, unatup9, unatup10, unatup11, unatup12, unatup13, unatup14, unatup15, unatup16,++  -- * Smart constructors for constants+  mkMinBound, mkMaxBound, mkPi,+  mkSin, mkCos, mkTan,+  mkAsin, mkAcos, mkAtan,+  mkSinh, mkCosh, mkTanh,+  mkAsinh, mkAcosh, mkAtanh,+  mkExpFloating, mkSqrt, mkLog,+  mkFPow, mkLogBase,+  mkTruncate, mkRound, mkFloor, mkCeiling,+  mkAtan2,++  -- * Smart constructors for primitive functions+  mkAdd, mkSub, mkMul, mkNeg, mkAbs, mkSig, mkQuot, mkRem, mkQuotRem, mkIDiv, mkMod, mkDivMod,+  mkBAnd, mkBOr, mkBXor, mkBNot, mkBShiftL, mkBShiftR, mkBRotateL, mkBRotateR, mkPopCount, mkCountLeadingZeros, mkCountTrailingZeros,+  mkFDiv, mkRecip, mkLt, mkGt, mkLtEq, mkGtEq, mkEq, mkNEq, mkMax, mkMin,+  mkLAnd, mkLOr, mkLNot, mkIsNaN, mkIsInfinite,++  -- * Smart constructors for type coercion functions+  mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkUnsafeCoerce,++  -- * Auxiliary functions+  ($$), ($$$), ($$$$), ($$$$$),++  -- Debugging+  showPreAccOp, showPreExpOp,++) where++-- standard library+import Prelude                                  hiding ( exp )+import Data.List+import Data.Typeable++-- friends+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.AST                hiding ( PreOpenAcc(..), OpenAcc(..), Acc+                                                       , PreOpenExp(..), OpenExp, PreExp, Exp+                                                       , Stencil(..), PreBoundary(..), Boundary+                                                       , showPreAccOp, showPreExpOp )+import qualified Data.Array.Accelerate.AST      as AST++-- Array computations+-- ------------------++-- | Accelerate is an /embedded language/ that distinguishes between vanilla+-- arrays (e.g. in Haskell memory on the CPU) and embedded arrays (e.g. in+-- device memory on a GPU), as well as the computations on both of these. Since+-- Accelerate is an embedded language, programs written in Accelerate are not+-- compiled by the Haskell compiler (GHC). Rather, each Accelerate backend is+-- a /runtime compiler/ which generates and executes parallel SIMD code of the+-- target language at application /runtime/.+--+-- The type constructor 'Acc' represents embedded collective array operations.+-- A term of type @Acc a@ is an Accelerate program which, once executed, will+-- produce a value of type 'a' (an 'Array' or a tuple of 'Arrays'). Collective+-- operations of type @Acc a@ comprise many /scalar expressions/, wrapped in+-- type constructor 'Exp', which will be executed in parallel. Although+-- collective operations comprise many scalar operations executed in parallel,+-- scalar operations /cannot/ initiate new collective operations: this+-- stratification between scalar operations in 'Exp' and array operations in+-- 'Acc' helps statically exclude /nested data parallelism/, which is difficult+-- to execute efficiently on constrained hardware such as GPUs.+--+-- [/A simple example/]+--+-- As a simple example, to compute a vector dot product we can write:+--+-- > dotp :: Num a => Vector a -> Vector a -> Acc (Scalar a)+-- > dotp xs ys =+-- >   let+-- >       xs' = use xs+-- >       ys' = use ys+-- >   in+-- >   fold (+) 0 ( zipWith (*) xs' ys' )+--+-- The function @dotp@ consumes two one-dimensional arrays ('Vector's) of+-- values, and produces a single ('Scalar') result as output. As the return type+-- is wrapped in the type 'Acc', we see that it is an embedded Accelerate+-- computation - it will be evaluated in the /object/ language of dynamically+-- generated parallel code, rather than the /meta/ language of vanilla Haskell.+--+-- As the arguments to @dotp@ are plain Haskell arrays, to make these available+-- to Accelerate computations they must be embedded with the+-- 'Data.Array.Accelerate.Language.use' function.+--+-- An Accelerate backend is used to evaluate the embedded computation and return+-- the result back to vanilla Haskell. Calling the 'run' function of a backend+-- will generate code for the target architecture, compile, and execute it. For+-- example, the following backends are available:+--+--  * <http://hackage.haskell.org/package/accelerate-llvm-native accelerate-llvm-native>: for execution on multicore CPUs+--  * <http://hackage.haskell.org/package/accelerate-llvm-ptx accelerate-llvm-ptx>: for execution on NVIDIA CUDA-capable GPUs+--+-- See also 'Exp', which encapsulates embedded /scalar/ computations.+--+-- [/Avoiding nested parallelism/]+--+-- As mentioned above, embedded scalar computations of type 'Exp' can not+-- initiate further collective operations.+--+-- Suppose we wanted to extend our above @dotp@ function to matrix-vector+-- multiplication. First, let's rewrite our @dotp@ function to take 'Acc' arrays+-- as input (which is typically what we want):+--+-- > dotp :: Num a => Acc (Vector a) -> Acc (Vector a) -> Acc (Scalar a)+-- > dotp xs ys = fold (+) 0 ( zipWith (*) xs ys )+--+-- We might then be inclined to lift our dot-product program to the following+-- (incorrect) matrix-vector product, by applying @dotp@ to each row of the+-- input matrix:+--+-- > mvm_ndp :: Num a => Acc (Matrix a) -> Acc (Vector a) -> Acc (Vector a)+-- > mvm_ndp mat vec =+-- >   let Z :. rows :. cols  = unlift (shape mat)  :: Z :. Exp Int :. Exp Int+-- >   in  generate (index1 rows)+-- >                (\row -> the $ dotp vec (slice mat (lift (row :. All))))+--+-- Here, we use 'Data.Array.Accelerate.generate' to create a one-dimensional+-- vector by applying at each index a function to 'Data.Array.Accelerate.slice'+-- out the corresponding @row@ of the matrix to pass to the @dotp@ function.+-- However, since both 'Data.Array.Accelerate.generate' and+-- 'Data.Array.Accelerate.slice' are data-parallel operations, and moreover that+-- 'Data.Array.Accelerate.slice' /depends on/ the argument @row@ given to it by+-- the 'Data.Array.Accelerate.generate' function, this definition requires+-- nested data-parallelism, and is thus not permitted. The clue that this+-- definition is invalid is that in order to create a program which will be+-- accepted by the type checker, we must use the function+-- 'Data.Array.Accelerate.the' to retrieve the result of the @dotp@ operation,+-- effectively concealing that @dotp@ is a collective array computation in order+-- to match the type expected by 'Data.Array.Accelerate.generate', which is that+-- of scalar expressions. Additionally, since we have fooled the type-checker,+-- this problem will only be discovered at program runtime.+--+-- In order to avoid this problem, we can make use of the fact that operations+-- in Accelerate are /rank polymorphic/. The 'Data.Array.Accelerate.fold'+-- operation reduces along the innermost dimension of an array of arbitrary+-- rank, reducing the rank (dimensionality) of the array by one. Thus, we can+-- 'Data.Array.Accelerate.replicate' the input vector to as many @rows@ there+-- are in the input matrix, and perform the dot-product of the vector with every+-- row simultaneously:+--+-- > mvm :: A.Num a => Acc (Matrix a) -> Acc (Vector a) -> Acc (Vector a)+-- > mvm mat vec =+-- >   let Z :. rows :. cols = unlift (shape mat) :: Z :. Exp Int :. Exp Int+-- >       vec'              = A.replicate (lift (Z :. rows :. All)) vec+-- >   in+-- >   A.fold (+) 0 ( A.zipWith (*) mat vec' )+--+-- Note that the intermediate, replicated array @vec'@ is never actually created+-- in memory; it will be fused directly into the operation which consumes it. We+-- discuss fusion next.+--+-- [/Fusion/]+--+-- Array computations of type 'Acc' will be subject to /array fusion/;+-- Accelerate will combine individual 'Acc' computations into a single+-- computation, which reduces the number of traversals over the input data and+-- thus improves performance. As such, it is often useful to have some intuition+-- on when fusion should occur.+--+-- The main idea is to first partition array operations into two categories:+--+--   1. Element-wise operations, such as 'Data.Array.Accelerate.map',+--      'Data.Array.Accelerate.generate', and+--      'Data.Array.Accelerate.backpermute'. Each element of these operations+--      can be computed independently of all others.+--+--   2. Collective operations such as 'Data.Array.Accelerate.fold',+--      'Data.Array.Accelerate.scanl', and 'Data.Array.Accelerate.stencil'. To+--      compute each output element of these operations requires reading+--      multiple elements from the input array(s).+--+-- Element-wise operations fuse together whenever the consumer operation uses+-- a single element of the input array. Element-wise operations can both fuse+-- their inputs into themselves, as well be fused into later operations. Both+-- these examples should fuse into a single loop:+--+-- <<images/fusion_example_1.png>>+--+-- <<images/fusion_example_2.png>>+--+-- If the consumer operation uses more than one element of the input array+-- (typically, via 'Data.Array.Accelerate.generate' indexing an array multiple+-- times), then the input array will be completely evaluated first; no fusion+-- occurs in this case, because fusing the first operation into the second+-- implies duplicating work.+--+-- On the other hand, collective operations can fuse their input arrays into+-- themselves, but on output always evaluate to an array; collective operations+-- will not be fused into a later step. For example:+--+-- <<images/fusion_example_3.png>>+--+-- Here the element-wise sequence ('Data.Array.Accelerate.use'+-- + 'Data.Array.Accelerate.generate' + 'Data.Array.Accelerate.zipWith') will+-- fuse into a single operation, which then fuses into the collective+-- 'Data.Array.Accelerate.fold' operation. At this point in the program the+-- 'Data.Array.Accelerate.fold' must now be evaluated. In the final step the+-- 'Data.Array.Accelerate.map' reads in the array produced by+-- 'Data.Array.Accelerate.fold'. As there is no fusion between the+-- 'Data.Array.Accelerate.fold' and 'Data.Array.Accelerate.map' steps, this+-- program consists of two "loops"; one for the 'Data.Array.Accelerate.use'+-- + 'Data.Array.Accelerate.generate' + 'Data.Array.Accelerate.zipWith'+-- + 'Data.Array.Accelerate.fold' step, and one for the final+-- 'Data.Array.Accelerate.map' step.+--+-- You can see how many operations will be executed in the fused program by+-- 'Show'-ing the 'Acc' program, or by using the debugging option @-ddump-dot@+-- to save the program as a graphviz DOT file.+--+-- As a special note, the operations 'Data.Array.Accelerate.unzip' and+-- 'Data.Array.Accelerate.reshape', when applied to a real array, are executed+-- in constant time, so in this situation these operations will not be fused.+--+-- [/Tips/]+--+--  * Since 'Acc' represents embedded computations that will only be executed+--    when evaluated by a backend, we can programatically generate these+--    computations using the meta language Haskell; for example, unrolling loops+--    or embedding input values into the generated code.+--+--  * It is usually best to keep all intermediate computations in 'Acc', and+--    only 'run' the computation at the very end to produce the final result.+--    This enables optimisations between intermediate results (e.g. array+--    fusion) and, if the target architecture has a separate memory space, as is+--    the case of GPUs, to prevent excessive data transfers.+--+newtype Acc a = Acc (PreAcc Acc Exp a)+deriving instance Typeable Acc+++-- The level of lambda-bound variables. The root has level 0; then it increases with each bound+-- variable — i.e., it is the same as the size of the environment at the defining occurrence.+--+type Level = Int++-- | Array-valued collective computations without a recursive knot+--+data PreAcc acc exp as where+    -- Needed for conversion to de Bruijn form+  Atag          :: Arrays as+                => Level                        -- environment size at defining occurrence+                -> PreAcc acc exp as++  Pipe          :: (Arrays as, Arrays bs, Arrays cs)+                => (Acc as -> acc bs)+                -> (Acc bs -> acc cs)+                -> acc as+                -> PreAcc acc exp cs++  Aforeign      :: (Arrays as, Arrays bs, Foreign asm)+                => asm (as -> bs)+                -> (Acc as -> Acc bs)+                -> acc as+                -> PreAcc acc exp bs++  Acond         :: Arrays as+                => exp Bool+                -> acc as+                -> acc as+                -> PreAcc acc exp as++  Awhile        :: Arrays arrs+                => (Acc arrs -> acc (Scalar Bool))+                -> (Acc arrs -> acc arrs)+                -> acc arrs+                -> PreAcc acc exp arrs++  Atuple        :: (Arrays arrs, IsAtuple arrs)+                => Atuple acc (TupleRepr arrs)+                -> PreAcc acc exp arrs++  Aprj          :: (Arrays arrs, IsAtuple arrs, Arrays a)+                => TupleIdx (TupleRepr arrs) a+                ->        acc     arrs+                -> PreAcc acc exp a++  Use           :: Arrays arrs+                => arrs+                -> PreAcc acc exp arrs++  Unit          :: Elt e+                => exp e+                -> PreAcc acc exp (Scalar e)++  Generate      :: (Shape sh, Elt e)+                => exp sh+                -> (Exp sh -> exp e)+                -> PreAcc acc exp (Array sh e)++  Reshape       :: (Shape sh, Shape sh', Elt e)+                => exp sh+                -> acc (Array sh' e)+                -> PreAcc acc exp (Array sh e)++  Replicate     :: (Slice slix, Elt e)+                => exp slix+                -> acc            (Array (SliceShape slix) e)+                -> PreAcc acc exp (Array (FullShape  slix) e)++  Slice         :: (Slice slix, Elt e)+                => acc            (Array (FullShape  slix) e)+                -> exp slix+                -> PreAcc acc exp (Array (SliceShape slix) e)++  Map           :: (Shape sh, Elt e, Elt e')+                => (Exp e -> exp e')+                -> acc (Array sh e)+                -> PreAcc acc exp (Array sh e')++  ZipWith       :: (Shape sh, Elt e1, Elt e2, Elt e3)+                => (Exp e1 -> Exp e2 -> exp e3)+                -> acc (Array sh e1)+                -> acc (Array sh e2)+                -> PreAcc acc exp (Array sh e3)++  Fold          :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Array (sh:.Int) e)+                -> PreAcc acc exp (Array sh e)++  Fold1         :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> acc (Array (sh:.Int) e)+                -> PreAcc acc exp (Array sh e)++  FoldSeg       :: (Shape sh, Elt e, Elt i, IsIntegral i)+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Array (sh:.Int) e)+                -> acc (Segments i)+                -> PreAcc acc exp (Array (sh:.Int) e)++  Fold1Seg      :: (Shape sh, Elt e, Elt i, IsIntegral i)+                => (Exp e -> Exp e -> exp e)+                -> acc (Array (sh:.Int) e)+                -> acc (Segments i)+                -> PreAcc acc exp (Array (sh:.Int) e)++  Scanl         :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Array (sh :. Int) e)+                -> PreAcc acc exp (Array (sh :. Int) e)++  Scanl'        :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Array (sh :. Int) e)+                -> PreAcc acc exp (Array (sh :. Int) e, Array sh e)++  Scanl1        :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> acc (Array (sh :. Int) e)+                -> PreAcc acc exp (Array (sh :. Int) e)++  Scanr         :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Array (sh :. Int) e)+                -> PreAcc acc exp (Array (sh :. Int) e)++  Scanr'        :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> exp e+                -> acc (Array (sh :. Int) e)+                -> PreAcc acc exp (Array (sh :. Int) e, Array sh e)++  Scanr1        :: (Shape sh, Elt e)+                => (Exp e -> Exp e -> exp e)+                -> acc (Array (sh :. Int) e)+                -> PreAcc acc exp (Array (sh :. Int) e)++  Permute       :: (Shape sh, Shape sh', Elt e)+                => (Exp e -> Exp e -> exp e)+                -> acc (Array sh' e)+                -> (Exp sh -> exp sh')+                -> acc (Array sh e)+                -> PreAcc acc exp (Array sh' e)++  Backpermute   :: (Shape sh, Shape sh', Elt e)+                => exp sh'+                -> (Exp sh' -> exp sh)+                -> acc (Array sh e)+                -> PreAcc acc exp (Array sh' e)++  Stencil       :: (Shape sh, Elt a, Elt b, Stencil sh a stencil)+                => (stencil -> exp b)+                -> PreBoundary acc exp (Array sh a)+                -> acc (Array sh a)+                -> PreAcc acc exp (Array sh b)++  Stencil2      :: (Shape sh, Elt a, Elt b, Elt c, Stencil sh a stencil1, Stencil sh b stencil2)+                => (stencil1 -> stencil2 -> exp c)+                -> PreBoundary acc exp (Array sh a)+                -> acc (Array sh a)+                -> PreBoundary acc exp (Array sh b)+                -> acc (Array sh b)+                -> PreAcc acc exp (Array sh c)++  -- Collect       :: Arrays arrs+  --               => seq arrs+  --               -> PreAcc acc seq exp arrs+++{--+data PreSeq acc seq exp arrs where+  -- Convert the given Haskell-list of arrays to a sequence.+  StreamIn :: Arrays a+           => [a]+           -> PreSeq acc seq exp [a]++  -- Convert the given array to a sequence.+  -- Example:+  -- slix = Z :. All :. Split :. All :. All :. Split+  --              ^       ^       ^      ^      ^+  --              |        \     /      /       |+  --              |         \___/______/_______ Iteration space.+  --              |            /      /+  --           Element________/______/+  --            shape.+  --+  ToSeq :: ( Elt e+           , Slice slix+           , Division slsix+           , DivisionSlice slsix ~ slix+           , Typeable (FullShape slix)+           , Typeable (SliceShape slix)+           )+        => slsix+        -> acc (Array (FullShape slix) e)+        -> PreSeq acc seq exp [Array (SliceShape slix) e]++  -- Apply the given the given function to all elements of the given sequence.+  MapSeq :: (Arrays a, Arrays b)+         => (Acc a -> acc b)+         -> seq [a]+         -> PreSeq acc seq exp [b]++  -- Apply a given binary function pairwise to all elements of the given sequences.+  -- The length of the result is the length of the shorter of the two argument+  -- arrays.+  ZipWithSeq :: (Arrays a, Arrays b, Arrays c)+             => (Acc a -> Acc b -> acc c)+             -> seq [a]+             -> seq [b]+             -> PreSeq acc seq exp [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 a+          => (Exp a -> Exp a -> exp a)+          -> exp a+          -> seq [Scalar a]+          -> PreSeq acc seq exp [Scalar a]++  -- 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+          => (Exp a -> Exp a -> exp a)+          -> exp a+          -> seq [Scalar a]+          -> PreSeq acc seq exp (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 s1 a2 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)+                 => (Acc a -> Acc (Vector sh) -> Acc (Vector e) -> acc a)+                 -> acc a+                 -> seq [Array sh e]+                 -> PreSeq acc seq exp a++  -- Tuple up the results of a sequence computation. Note that the Arrays+  -- constraint requires that the elements of the tuple are Arrays, not+  -- streams ([]).+  Stuple :: (Arrays arrs, IsAtuple arrs)+         => Atuple (seq) (TupleRepr arrs)+         -> PreSeq acc seq exp arrs++-- |Array-valued sequence computations+--+newtype Seq a = Seq (PreSeq Acc Seq Exp a)++deriving instance Typeable Seq+--}+++-- Embedded expressions of the surface language+-- --------------------------------------------++-- HOAS expressions mirror the constructors of 'AST.OpenExp', but with the 'Tag'+-- constructor instead of variables in the form of de Bruijn indices. Moreover,+-- HOAS expression use n-tuples and the type class 'Elt' to constrain element+-- types, whereas 'AST.OpenExp' uses nested pairs and the GADT 'TupleType'.+--++-- | The type 'Exp' represents embedded scalar expressions. The collective+-- operations of Accelerate 'Acc' consist of many scalar expressions executed in+-- data-parallel.+--+-- Note that scalar expressions can not initiate new collective operations:+-- doing so introduces /nested data parallelism/, which is difficult to execute+-- efficiently on constrained hardware such as GPUs, and is thus currently+-- unsupported.+--+newtype Exp t = Exp (PreExp Acc Exp t)++deriving instance Typeable Exp++-- | Scalar expressions to parametrise collective array operations, themselves parameterised over+-- the type of collective array operations.+--+data PreExp acc exp t where+    -- Needed for conversion to de Bruijn form+  Tag           :: Elt t+                => Level                        -- environment size at defining occurrence+                -> PreExp acc exp t++  -- All the same constructors as 'AST.Exp'+  Const         :: Elt t+                => t+                -> PreExp acc exp t++  Tuple         :: (Elt t, IsTuple t)+                => Tuple exp (TupleRepr t)+                -> PreExp acc exp t++  Prj           :: (Elt t, IsTuple t, Elt e)+                => TupleIdx (TupleRepr t) e+                -> exp t+                -> PreExp acc exp e++  IndexNil      :: PreExp acc exp Z++  IndexCons     :: (Slice sl, Elt a)+                => exp sl+                -> exp a+                -> PreExp acc exp (sl:.a)++  IndexHead     :: (Slice sl, Elt a)+                => exp (sl:.a)+                -> PreExp acc exp a++  IndexTail     :: (Slice sl, Elt a)+                => exp (sl:.a)+                -> PreExp acc exp sl++  IndexAny      :: Shape sh+                => PreExp acc exp (Any sh)++  ToIndex       :: Shape sh+                => exp sh+                -> exp sh+                -> PreExp acc exp Int++  FromIndex     :: Shape sh+                => exp sh+                -> exp Int+                -> PreExp acc exp sh++  Cond          :: Elt t+                => exp Bool+                -> exp t+                -> exp t+                -> PreExp acc exp t++  While         :: Elt t+                => (Exp t -> exp Bool)+                -> (Exp t -> exp t)+                -> exp t+                -> PreExp acc exp t++  PrimConst     :: Elt t+                => PrimConst t+                -> PreExp acc exp t++  PrimApp       :: (Elt a, Elt r)+                => PrimFun (a -> r)+                -> exp a+                -> PreExp acc exp r++  Index         :: (Shape sh, Elt t)+                => acc (Array sh t)+                -> exp sh+                -> PreExp acc exp t++  LinearIndex   :: (Shape sh, Elt t)+                => acc (Array sh t)+                -> exp Int+                -> PreExp acc exp t++  Shape         :: (Shape sh, Elt e)+                => acc (Array sh e)+                -> PreExp acc exp sh++  ShapeSize     :: Shape sh+                => exp sh+                -> PreExp acc exp Int++  Intersect     :: Shape sh+                => exp sh+                -> exp sh+                -> PreExp acc exp sh++  Union         :: Shape sh+                => exp sh+                -> exp sh+                -> PreExp acc exp sh++  Foreign       :: (Elt x, Elt y, Foreign asm)+                => asm (x -> y)+                -> (Exp x -> Exp y) -- RCE: Using Exp instead of exp to aid in sharing recovery.+                -> exp x+                -> PreExp acc exp y++  Undef         :: Elt t+                => PreExp acc exp t++  Coerce        :: (Elt a, Elt b)+                => exp a+                -> PreExp acc exp b++++-- Smart constructors and destructors for array tuples+-- ---------------------------------------------------++atup2 :: (Arrays a, Arrays b)+      => (Acc a, Acc b)+      -> Acc (a, b)+atup2 (a, b)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b++atup3 :: (Arrays a, Arrays b, Arrays c)+      => (Acc a, Acc b, Acc c)+      -> Acc (a, b, c)+atup3 (a, b, c)+  = Acc $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c++atup4 :: (Arrays a, Arrays b, Arrays c, Arrays d)+      => (Acc a, Acc b, Acc c, Acc d)+      -> Acc (a, b, c, d)+atup4 (a, b, c, d)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d++atup5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)+      => (Acc a, Acc b, Acc c, Acc d, Acc e)+      -> Acc (a, b, c, d, e)+atup5 (a, b, c, d, e)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e++atup6 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)+      => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f)+      -> Acc (a, b, c, d, e, f)+atup6 (a, b, c, d, e, f)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f++atup7 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)+      => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g)+      -> Acc (a, b, c, d, e, f, g)+atup7 (a, b, c, d, e, f, g)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g++atup8 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)+      => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h)+      -> Acc (a, b, c, d, e, f, g, h)+atup8 (a, b, c, d, e, f, g, h)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g+            `SnocAtup` h++atup9 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)+      => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i)+      -> Acc (a, b, c, d, e, f, g, h, i)+atup9 (a, b, c, d, e, f, g, h, i)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g+            `SnocAtup` h+            `SnocAtup` i++atup10 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j)+       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j)+       -> Acc (a, b, c, d, e, f, g, h, i, j)+atup10 (a, b, c, d, e, f, g, h, i, j)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g+            `SnocAtup` h+            `SnocAtup` i+            `SnocAtup` j++atup11 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k)+       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k)+       -> Acc (a, b, c, d, e, f, g, h, i, j, k)+atup11 (a, b, c, d, e, f, g, h, i, j, k)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g+            `SnocAtup` h+            `SnocAtup` i+            `SnocAtup` j+            `SnocAtup` k++atup12 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l)+       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l)+       -> Acc (a, b, c, d, e, f, g, h, i, j, k, l)+atup12 (a, b, c, d, e, f, g, h, i, j, k, l)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g+            `SnocAtup` h+            `SnocAtup` i+            `SnocAtup` j+            `SnocAtup` k+            `SnocAtup` l++atup13 :: (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)+       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m)+       -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m)+atup13 (a, b, c, d, e, f, g, h, i, j, k, l, m)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g+            `SnocAtup` h+            `SnocAtup` i+            `SnocAtup` j+            `SnocAtup` k+            `SnocAtup` l+            `SnocAtup` m++atup14 :: (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)+       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n)+       -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+atup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g+            `SnocAtup` h+            `SnocAtup` i+            `SnocAtup` j+            `SnocAtup` k+            `SnocAtup` l+            `SnocAtup` m+            `SnocAtup` n++atup15 :: (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)+       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o)+       -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+atup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g+            `SnocAtup` h+            `SnocAtup` i+            `SnocAtup` j+            `SnocAtup` k+            `SnocAtup` l+            `SnocAtup` m+            `SnocAtup` n+            `SnocAtup` o++atup16 :: (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 p)+       => (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o, Acc p)+       -> Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+atup16 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+  = Acc+  $ Atuple+  $ NilAtup `SnocAtup` a+            `SnocAtup` b+            `SnocAtup` c+            `SnocAtup` d+            `SnocAtup` e+            `SnocAtup` f+            `SnocAtup` g+            `SnocAtup` h+            `SnocAtup` i+            `SnocAtup` j+            `SnocAtup` k+            `SnocAtup` l+            `SnocAtup` m+            `SnocAtup` n+            `SnocAtup` o+            `SnocAtup` p++unatup2 :: (Arrays a, Arrays b)+        => Acc (a, b)+        -> (Acc a, Acc b)+unatup2 e =+  ( Acc $ tix1 `Aprj` e+  , Acc $ tix0 `Aprj` e )++unatup3 :: (Arrays a, Arrays b, Arrays c)+        => Acc (a, b, c)+        -> (Acc a, Acc b, Acc c)+unatup3 e =+  ( Acc $ tix2 `Aprj` e+  , Acc $ tix1 `Aprj` e+  , Acc $ tix0 `Aprj` e )++unatup4+    :: (Arrays a, Arrays b, Arrays c, Arrays d)+    => Acc (a, b, c, d)+    -> (Acc a, Acc b, Acc c, Acc d)+unatup4 e =+  ( Acc $ tix3 `Aprj` e+  , Acc $ tix2 `Aprj` e+  , Acc $ tix1 `Aprj` e+  , Acc $ tix0 `Aprj` e )++unatup5+    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)+    => Acc (a, b, c, d, e)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e)+unatup5 e =+  ( Acc $ tix4 `Aprj` e+  , Acc $ tix3 `Aprj` e+  , Acc $ tix2 `Aprj` e+  , Acc $ tix1 `Aprj` e+  , Acc $ tix0 `Aprj` e )++unatup6+    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)+    => Acc (a, b, c, d, e, f)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f)+unatup6 e =+  ( Acc $ tix5 `Aprj` e+  , Acc $ tix4 `Aprj` e+  , Acc $ tix3 `Aprj` e+  , Acc $ tix2 `Aprj` e+  , Acc $ tix1 `Aprj` e+  , Acc $ tix0 `Aprj` e )++unatup7+    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)+    => Acc (a, b, c, d, e, f, g)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g)+unatup7 e =+  ( Acc $ tix6 `Aprj` e+  , Acc $ tix5 `Aprj` e+  , Acc $ tix4 `Aprj` e+  , Acc $ tix3 `Aprj` e+  , Acc $ tix2 `Aprj` e+  , Acc $ tix1 `Aprj` e+  , Acc $ tix0 `Aprj` e )++unatup8+    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)+    => Acc (a, b, c, d, e, f, g, h)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h)+unatup8 e =+  ( Acc $ tix7 `Aprj` e+  , Acc $ tix6 `Aprj` e+  , Acc $ tix5 `Aprj` e+  , Acc $ tix4 `Aprj` e+  , Acc $ tix3 `Aprj` e+  , Acc $ tix2 `Aprj` e+  , Acc $ tix1 `Aprj` e+  , Acc $ tix0 `Aprj` e )++unatup9+    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)+    => Acc (a, b, c, d, e, f, g, h, i)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i)+unatup9 e =+  ( Acc $ tix8 `Aprj` e+  , Acc $ tix7 `Aprj` e+  , Acc $ tix6 `Aprj` e+  , Acc $ tix5 `Aprj` e+  , Acc $ tix4 `Aprj` e+  , Acc $ tix3 `Aprj` e+  , Acc $ tix2 `Aprj` e+  , Acc $ tix1 `Aprj` e+  , Acc $ tix0 `Aprj` e )++unatup10+    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j)+    => Acc (a, b, c, d, e, f, g, h, i, j)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j)+unatup10 e =+  ( Acc $ tix9 `Aprj` e+  , Acc $ tix8 `Aprj` e+  , Acc $ tix7 `Aprj` e+  , Acc $ tix6 `Aprj` e+  , Acc $ tix5 `Aprj` e+  , Acc $ tix4 `Aprj` e+  , Acc $ tix3 `Aprj` e+  , Acc $ tix2 `Aprj` e+  , Acc $ tix1 `Aprj` e+  , Acc $ tix0 `Aprj` e )++unatup11+    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k)+    => Acc (a, b, c, d, e, f, g, h, i, j, k)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k)+unatup11 e =+  ( Acc $ tix10 `Aprj` e+  , Acc $ tix9  `Aprj` e+  , Acc $ tix8  `Aprj` e+  , Acc $ tix7  `Aprj` e+  , Acc $ tix6  `Aprj` e+  , Acc $ tix5  `Aprj` e+  , Acc $ tix4  `Aprj` e+  , Acc $ tix3  `Aprj` e+  , Acc $ tix2  `Aprj` e+  , Acc $ tix1  `Aprj` e+  , Acc $ tix0  `Aprj` e )++unatup12+    :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l)+    => Acc (a, b, c, d, e, f, g, h, i, j, k, l)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l)+unatup12 e =+  ( Acc $ tix11 `Aprj` e+  , Acc $ tix10 `Aprj` e+  , Acc $ tix9  `Aprj` e+  , Acc $ tix8  `Aprj` e+  , Acc $ tix7  `Aprj` e+  , Acc $ tix6  `Aprj` e+  , Acc $ tix5  `Aprj` e+  , Acc $ tix4  `Aprj` e+  , Acc $ tix3  `Aprj` e+  , Acc $ tix2  `Aprj` e+  , Acc $ tix1  `Aprj` e+  , Acc $ tix0  `Aprj` e )++unatup13+    :: (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)+    => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m)+unatup13 e =+  ( Acc $ tix12 `Aprj` e+  , Acc $ tix11 `Aprj` e+  , Acc $ tix10 `Aprj` e+  , Acc $ tix9  `Aprj` e+  , Acc $ tix8  `Aprj` e+  , Acc $ tix7  `Aprj` e+  , Acc $ tix6  `Aprj` e+  , Acc $ tix5  `Aprj` e+  , Acc $ tix4  `Aprj` e+  , Acc $ tix3  `Aprj` e+  , Acc $ tix2  `Aprj` e+  , Acc $ tix1  `Aprj` e+  , Acc $ tix0  `Aprj` e )++unatup14+    :: (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)+    => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n)+unatup14 e =+  ( Acc $ tix13 `Aprj` e+  , Acc $ tix12 `Aprj` e+  , Acc $ tix11 `Aprj` e+  , Acc $ tix10 `Aprj` e+  , Acc $ tix9  `Aprj` e+  , Acc $ tix8  `Aprj` e+  , Acc $ tix7  `Aprj` e+  , Acc $ tix6  `Aprj` e+  , Acc $ tix5  `Aprj` e+  , Acc $ tix4  `Aprj` e+  , Acc $ tix3  `Aprj` e+  , Acc $ tix2  `Aprj` e+  , Acc $ tix1  `Aprj` e+  , Acc $ tix0  `Aprj` e )++unatup15+    :: (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)+    => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o)+unatup15 e =+  ( Acc $ tix14 `Aprj` e+  , Acc $ tix13 `Aprj` e+  , Acc $ tix12 `Aprj` e+  , Acc $ tix11 `Aprj` e+  , Acc $ tix10 `Aprj` e+  , Acc $ tix9  `Aprj` e+  , Acc $ tix8  `Aprj` e+  , Acc $ tix7  `Aprj` e+  , Acc $ tix6  `Aprj` e+  , Acc $ tix5  `Aprj` e+  , Acc $ tix4  `Aprj` e+  , Acc $ tix3  `Aprj` e+  , Acc $ tix2  `Aprj` e+  , Acc $ tix1  `Aprj` e+  , Acc $ tix0  `Aprj` e )++unatup16+    :: (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 p)+    => Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+    -> (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o, Acc p)+unatup16 e =+  ( Acc $ tix15 `Aprj` e+  , Acc $ tix14 `Aprj` e+  , Acc $ tix13 `Aprj` e+  , Acc $ tix12 `Aprj` e+  , Acc $ tix11 `Aprj` e+  , Acc $ tix10 `Aprj` e+  , Acc $ tix9  `Aprj` e+  , Acc $ tix8  `Aprj` e+  , Acc $ tix7  `Aprj` e+  , Acc $ tix6  `Aprj` e+  , Acc $ tix5  `Aprj` e+  , Acc $ tix4  `Aprj` e+  , Acc $ tix3  `Aprj` e+  , Acc $ tix2  `Aprj` e+  , Acc $ tix1  `Aprj` e+  , Acc $ tix0  `Aprj` e )+++-- Smart constructors for stencils+-- -------------------------------++-- | Boundary condition specification for stencil operations+--+newtype Boundary t = Boundary (PreBoundary Acc Exp t)++data PreBoundary acc exp t where+  Clamp     :: PreBoundary acc exp t+  Mirror    :: PreBoundary acc exp t+  Wrap      :: PreBoundary acc exp t++  Constant  :: Elt e+            => e+            -> PreBoundary acc exp (Array sh e)++  Function  :: (Shape sh, Elt e)+            => (Exp sh -> exp e)+            -> PreBoundary acc exp (Array sh e)+++-- Stencil reification+--+-- In the AST representation, we turn the stencil type from nested tuples of Accelerate expressions+-- into an Accelerate expression whose type is a tuple nested in the same manner.  This enables us+-- to represent the stencil function as a unary function (which also only needs one de Bruijn+-- index). The various positions in the stencil are accessed via tuple indices (i.e., projections).+--+class (Elt (StencilRepr sh stencil), AST.Stencil sh a (StencilRepr sh stencil)) => Stencil sh a stencil where+  type StencilRepr sh stencil :: *+  stencilPrj :: {-dummy-} sh+             -> {-dummy-} a+             -> Exp (StencilRepr sh stencil)+             -> stencil++-- DIM1+instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e) where+  type StencilRepr DIM1 (Exp e, Exp e, Exp e)+    = (e, e, e)+  stencilPrj _ _ s = (Exp $ Prj tix2 s,+                      Exp $ Prj tix1 s,+                      Exp $ Prj tix0 s)++instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e) where+  type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e)+    = (e, e, e, e, e)+  stencilPrj _ _ s = (Exp $ Prj tix4 s,+                      Exp $ Prj tix3 s,+                      Exp $ Prj tix2 s,+                      Exp $ Prj tix1 s,+                      Exp $ Prj tix0 s)++instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) where+  type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)+    = (e, e, e, e, e, e, e)+  stencilPrj _ _ s = (Exp $ Prj tix6 s,+                      Exp $ Prj tix5 s,+                      Exp $ Prj tix4 s,+                      Exp $ Prj tix3 s,+                      Exp $ Prj tix2 s,+                      Exp $ Prj tix1 s,+                      Exp $ Prj tix0 s)++instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)+  where+  type StencilRepr DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e)+    = (e, e, e, e, e, e, e, e, e)+  stencilPrj _ _ s = (Exp $ Prj tix8 s,+                      Exp $ Prj tix7 s,+                      Exp $ Prj tix6 s,+                      Exp $ Prj tix5 s,+                      Exp $ Prj tix4 s,+                      Exp $ Prj tix3 s,+                      Exp $ Prj tix2 s,+                      Exp $ Prj tix1 s,+                      Exp $ Prj tix0 s)++-- DIM(n+1)+instance (Stencil (sh:.Int) a row2,+          Stencil (sh:.Int) a row1,+          Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row2, row1, row0) where+  type StencilRepr (sh:.Int:.Int) (row2, row1, row0)+    = (StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row0)+  stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))++instance (Stencil (sh:.Int) a row1,+          Stencil (sh:.Int) a row2,+          Stencil (sh:.Int) a row3,+          Stencil (sh:.Int) a row4,+          Stencil (sh:.Int) a row5) => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5) where+  type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5)+    = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,+       StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5)+  stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))++instance (Stencil (sh:.Int) a row1,+          Stencil (sh:.Int) a row2,+          Stencil (sh:.Int) a row3,+          Stencil (sh:.Int) a row4,+          Stencil (sh:.Int) a row5,+          Stencil (sh:.Int) a row6,+          Stencil (sh:.Int) a row7)+  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7) where+  type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7)+    = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,+       StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6,+       StencilRepr (sh:.Int) row7)+  stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))++instance (Stencil (sh:.Int) a row1,+          Stencil (sh:.Int) a row2,+          Stencil (sh:.Int) a row3,+          Stencil (sh:.Int) a row4,+          Stencil (sh:.Int) a row5,+          Stencil (sh:.Int) a row6,+          Stencil (sh:.Int) a row7,+          Stencil (sh:.Int) a row8,+          Stencil (sh:.Int) a row9)+  => Stencil (sh:.Int:.Int) a (row1, row2, row3, row4, row5, row6, row7, row8, row9) where+  type StencilRepr (sh:.Int:.Int) (row1, row2, row3, row4, row5, row6, row7, row8, row9)+    = (StencilRepr (sh:.Int) row1, StencilRepr (sh:.Int) row2, StencilRepr (sh:.Int) row3,+       StencilRepr (sh:.Int) row4, StencilRepr (sh:.Int) row5, StencilRepr (sh:.Int) row6,+       StencilRepr (sh:.Int) row7, StencilRepr (sh:.Int) row8, StencilRepr (sh:.Int) row9)+  stencilPrj _ a s = (stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix8 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix7 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix6 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix5 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix4 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix3 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix2 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix1 s),+                      stencilPrj (undefined::(sh:.Int)) a (Exp $ Prj tix0 s))++-- Auxiliary tuple index constants+--+tix0 :: TupleIdx (t, s0) s0+tix0 = ZeroTupIdx++tix1 :: TupleIdx ((t, s1), s0) s1+tix1 = SuccTupIdx tix0++tix2 :: TupleIdx (((t, s2), s1), s0) s2+tix2 = SuccTupIdx tix1++tix3 :: TupleIdx ((((t, s3), s2), s1), s0) s3+tix3 = SuccTupIdx tix2++tix4 :: TupleIdx (((((t, s4), s3), s2), s1), s0) s4+tix4 = SuccTupIdx tix3++tix5 :: TupleIdx ((((((t, s5), s4), s3), s2), s1), s0) s5+tix5 = SuccTupIdx tix4++tix6 :: TupleIdx (((((((t, s6), s5), s4), s3), s2), s1), s0) s6+tix6 = SuccTupIdx tix5++tix7 :: TupleIdx ((((((((t, s7), s6), s5), s4), s3), s2), s1), s0) s7+tix7 = SuccTupIdx tix6++tix8 :: TupleIdx (((((((((t, s8), s7), s6), s5), s4), s3), s2), s1), s0) s8+tix8 = SuccTupIdx tix7++tix9 :: TupleIdx ((((((((((t, s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s9+tix9 = SuccTupIdx tix8++tix10 :: TupleIdx (((((((((((t, s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s10+tix10 = SuccTupIdx tix9++tix11 :: TupleIdx ((((((((((((t, s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s11+tix11 = SuccTupIdx tix10++tix12 :: TupleIdx (((((((((((((t, s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s12+tix12 = SuccTupIdx tix11++tix13 :: TupleIdx ((((((((((((((t, s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s13+tix13 = SuccTupIdx tix12++tix14 :: TupleIdx (((((((((((((((t, s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s14+tix14 = SuccTupIdx tix13++tix15 :: TupleIdx ((((((((((((((((t, s15), s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s15+tix15 = SuccTupIdx tix14++{--+-- Smart constructors for array tuples in sequence computations+-- ---------------------------------------------------++stup2 :: (Arrays a, Arrays b) => (Seq a, Seq b) -> Seq (a, b)+stup2 (a, b) = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b)++stup3 :: (Arrays a, Arrays b, Arrays c) => (Seq a, Seq b, Seq c) -> Seq (a, b, c)+stup3 (a, b, c) = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c)++stup4 :: (Arrays a, Arrays b, Arrays c, Arrays d)+      => (Seq a, Seq b, Seq c, Seq d) -> Seq (a, b, c, d)+stup4 (a, b, c, d)+  = Seq $ Stuple (NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d)++stup5 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)+      => (Seq a, Seq b, Seq c, Seq d, Seq e) -> Seq (a, b, c, d, e)+stup5 (a, b, c, d, e)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e++stup6 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)+      => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f) -> Seq (a, b, c, d, e, f)+stup6 (a, b, c, d, e, f)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c+              `SnocAtup` d `SnocAtup` e `SnocAtup` f++stup7 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)+      => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g)+      -> Seq (a, b, c, d, e, f, g)+stup7 (a, b, c, d, e, f, g)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c+              `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g++stup8 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)+      => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h)+      -> Seq (a, b, c, d, e, f, g, h)+stup8 (a, b, c, d, e, f, g, h)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d+              `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h++stup9 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)+      => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i)+      -> Seq (a, b, c, d, e, f, g, h, i)+stup9 (a, b, c, d, e, f, g, h, i)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d+              `SnocAtup` e `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i++stup10 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j)+       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j)+       -> Seq (a, b, c, d, e, f, g, h, i, j)+stup10 (a, b, c, d, e, f, g, h, i, j)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e+              `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j++stup11 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k)+       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k)+       -> Seq (a, b, c, d, e, f, g, h, i, j, k)+stup11 (a, b, c, d, e, f, g, h, i, j, k)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e+              `SnocAtup` f `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k++stup12 :: (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k, Arrays l)+       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l)+       -> Seq (a, b, c, d, e, f, g, h, i, j, k, l)+stup12 (a, b, c, d, e, f, g, h, i, j, k, l)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f+              `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l++stup13 :: (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)+       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m)+       -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m)+stup13 (a, b, c, d, e, f, g, h, i, j, k, l, m)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f+              `SnocAtup` g `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m++stup14 :: (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)+       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m, Seq n)+       -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+stup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g+              `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n++stup15 :: (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)+       => (Seq a, Seq b, Seq c, Seq d, Seq e, Seq f, Seq g, Seq h, Seq i, Seq j, Seq k, Seq l, Seq m, Seq n, Seq o)+       -> Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+stup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+  = Seq $ Stuple $+      NilAtup `SnocAtup` a `SnocAtup` b `SnocAtup` c `SnocAtup` d `SnocAtup` e `SnocAtup` f `SnocAtup` g+              `SnocAtup` h `SnocAtup` i `SnocAtup` j `SnocAtup` k `SnocAtup` l `SnocAtup` m `SnocAtup` n `SnocAtup` o+--}++-- Smart constructor for literals+--++-- | Scalar expression inlet: make a Haskell value available for processing in+-- an Accelerate scalar expression.+--+-- Note that this embeds the value directly into the expression. Depending on+-- the backend used to execute the computation, this might not always be+-- desirable. For example, a backend that does external code generation may+-- embed this constant directly into the generated code, which means new code+-- will need to be generated and compiled every time the value changes. In such+-- cases, consider instead lifting scalar values into (singleton) arrays so that+-- they can be passed as an input to the computation and thus the value can+-- change without the need to generate fresh code.+--+constant :: Elt t => t -> Exp t+constant = Exp . Const++-- | 'undef' can be used anywhere a constant is expected, and indicates that the+-- consumer of the value can receive an unspecified bit pattern.+--+-- This is useful because a store of an undefined value can be assumed to not+-- have any effect; we can assume that the value is overwritten with bits that+-- happen to match what was already there. However, a store /to/ an undefined+-- location could clobber arbitrary memory, therefore, its use in such a context+-- would introduce undefined /behaviour/.+--+-- There are (at least) two cases where you may want to use this:+--+--   1. The 'Data.Array.Accelerate.Language.permute' function requires an array+--      of default values, into which the new values are combined. However, if+--      you are sure the default values are not used, and will (eventually) be+--      completely overwritten, then 'Data.Array.Accelerate.Prelude.fill'ing an+--      array with this value will give you a new uninitialised array.+--+--   2. In the definition of sum data types. See for example+--      "Data.Array.Accelerate.Data.Maybe" and+--      "Data.Array.Accelerate.Data.Either".+--+-- @since 1.2.0.0+--+undef :: Elt t => Exp t+undef = Exp Undef++-- Smart constructor and destructors for scalar tuples+--+tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b)+tup2 (a, b)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b++tup3 :: (Elt a, Elt b, Elt c)+     => (Exp a, Exp b, Exp c)+     -> Exp (a, b, c)+tup3 (a, b, c)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c++tup4 :: (Elt a, Elt b, Elt c, Elt d)+     => (Exp a, Exp b, Exp c, Exp d)+     -> Exp (a, b, c, d)+tup4 (a, b, c, d)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d++tup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e)+     => (Exp a, Exp b, Exp c, Exp d, Exp e)+     -> Exp (a, b, c, d, e)+tup5 (a, b, c, d, e)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e++tup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+     => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)+     -> Exp (a, b, c, d, e, f)+tup6 (a, b, c, d, e, f)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f++tup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+     => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)+     -> Exp (a, b, c, d, e, f, g)+tup7 (a, b, c, d, e, f, g)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g++tup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+     => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)+     -> Exp (a, b, c, d, e, f, g, h)+tup8 (a, b, c, d, e, f, g, h)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g+           `SnocTup` h++tup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+     => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)+     -> Exp (a, b, c, d, e, f, g, h, i)+tup9 (a, b, c, d, e, f, g, h, i)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g+           `SnocTup` h+           `SnocTup` i++tup10 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)+      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j)+      -> Exp (a, b, c, d, e, f, g, h, i, j)+tup10 (a, b, c, d, e, f, g, h, i, j)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g+           `SnocTup` h+           `SnocTup` i+           `SnocTup` j++tup11 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k)+      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k)+      -> Exp (a, b, c, d, e, f, g, h, i, j, k)+tup11 (a, b, c, d, e, f, g, h, i, j, k)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g+           `SnocTup` h+           `SnocTup` i+           `SnocTup` j+           `SnocTup` k++tup12 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l)+      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l)+      -> Exp (a, b, c, d, e, f, g, h, i, j, k, l)+tup12 (a, b, c, d, e, f, g, h, i, j, k, l)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g+           `SnocTup` h+           `SnocTup` i+           `SnocTup` j+           `SnocTup` k+           `SnocTup` l++tup13 :: (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)+      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m)+      -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m)+tup13 (a, b, c, d, e, f, g, h, i, j, k, l, m)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g+           `SnocTup` h+           `SnocTup` i+           `SnocTup` j+           `SnocTup` k+           `SnocTup` l+           `SnocTup` m++tup14 :: (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)+      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n)+      -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+tup14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g+           `SnocTup` h+           `SnocTup` i+           `SnocTup` j+           `SnocTup` k+           `SnocTup` l+           `SnocTup` m+           `SnocTup` n++tup15 :: (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)+      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o)+      -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+tup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g+           `SnocTup` h+           `SnocTup` i+           `SnocTup` j+           `SnocTup` k+           `SnocTup` l+           `SnocTup` m+           `SnocTup` n+           `SnocTup` o++tup16 :: (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 p)+      => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o, Exp p)+      -> Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+tup16 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+  = Exp+  $ Tuple+  $ NilTup `SnocTup` a+           `SnocTup` b+           `SnocTup` c+           `SnocTup` d+           `SnocTup` e+           `SnocTup` f+           `SnocTup` g+           `SnocTup` h+           `SnocTup` i+           `SnocTup` j+           `SnocTup` k+           `SnocTup` l+           `SnocTup` m+           `SnocTup` n+           `SnocTup` o+           `SnocTup` p++untup2 :: (Elt a, Elt b) => Exp (a, b) -> (Exp a, Exp b)+untup2 e =+  ( Exp $ tix1 `Prj` e+  , Exp $ tix0 `Prj` e )++untup3 :: (Elt a, Elt b, Elt c) => Exp (a, b, c) -> (Exp a, Exp b, Exp c)+untup3 e =+  ( Exp $ tix2 `Prj` e+  , Exp $ tix1 `Prj` e+  , Exp $ tix0 `Prj` e )++untup4 :: (Elt a, Elt b, Elt c, Elt d)+       => Exp (a, b, c, d)+       -> (Exp a, Exp b, Exp c, Exp d)+untup4 e =+  ( Exp $ tix3 `Prj` e+  , Exp $ tix2 `Prj` e+  , Exp $ tix1 `Prj` e+  , Exp $ tix0 `Prj` e )++untup5 :: (Elt a, Elt b, Elt c, Elt d, Elt e)+       => Exp (a, b, c, d, e)+       -> (Exp a, Exp b, Exp c, Exp d, Exp e)+untup5 e =+  ( Exp $ tix4 `Prj` e+  , Exp $ tix3 `Prj` e+  , Exp $ tix2 `Prj` e+  , Exp $ tix1 `Prj` e+  , Exp $ tix0 `Prj` e )++untup6 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+       => Exp (a, b, c, d, e, f)+       -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)+untup6 e =+  ( Exp $ tix5 `Prj` e+  , Exp $ tix4 `Prj` e+  , Exp $ tix3 `Prj` e+  , Exp $ tix2 `Prj` e+  , Exp $ tix1 `Prj` e+  , Exp $ tix0 `Prj` e )++untup7 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)+       => Exp (a, b, c, d, e, f, g)+       -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g)+untup7 e =+  ( Exp $ tix6 `Prj` e+  , Exp $ tix5 `Prj` e+  , Exp $ tix4 `Prj` e+  , Exp $ tix3 `Prj` e+  , Exp $ tix2 `Prj` e+  , Exp $ tix1 `Prj` e+  , Exp $ tix0 `Prj` e )++untup8 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)+       => Exp (a, b, c, d, e, f, g, h)+       -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h)+untup8 e =+  ( Exp $ tix7 `Prj` e+  , Exp $ tix6 `Prj` e+  , Exp $ tix5 `Prj` e+  , Exp $ tix4 `Prj` e+  , Exp $ tix3 `Prj` e+  , Exp $ tix2 `Prj` e+  , Exp $ tix1 `Prj` e+  , Exp $ tix0 `Prj` e )++untup9 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)+       => Exp (a, b, c, d, e, f, g, h, i)+       -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i)+untup9 e =+  ( Exp $ tix8 `Prj` e+  , Exp $ tix7 `Prj` e+  , Exp $ tix6 `Prj` e+  , Exp $ tix5 `Prj` e+  , Exp $ tix4 `Prj` e+  , Exp $ tix3 `Prj` e+  , Exp $ tix2 `Prj` e+  , Exp $ tix1 `Prj` e+  , Exp $ tix0 `Prj` e )++untup10 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)+        => Exp (a, b, c, d, e, f, g, h, i, j)+        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j)+untup10 e =+  ( Exp $ tix9 `Prj` e+  , Exp $ tix8 `Prj` e+  , Exp $ tix7 `Prj` e+  , Exp $ tix6 `Prj` e+  , Exp $ tix5 `Prj` e+  , Exp $ tix4 `Prj` e+  , Exp $ tix3 `Prj` e+  , Exp $ tix2 `Prj` e+  , Exp $ tix1 `Prj` e+  , Exp $ tix0 `Prj` e )++untup11 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k)+        => Exp (a, b, c, d, e, f, g, h, i, j, k)+        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k)+untup11 e =+  ( Exp $ tix10 `Prj` e+  , Exp $ tix9  `Prj` e+  , Exp $ tix8  `Prj` e+  , Exp $ tix7  `Prj` e+  , Exp $ tix6  `Prj` e+  , Exp $ tix5  `Prj` e+  , Exp $ tix4  `Prj` e+  , Exp $ tix3  `Prj` e+  , Exp $ tix2  `Prj` e+  , Exp $ tix1  `Prj` e+  , Exp $ tix0  `Prj` e )++untup12 :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, Elt k, Elt l)+        => Exp (a, b, c, d, e, f, g, h, i, j, k, l)+        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l)+untup12 e =+  ( Exp $ tix11 `Prj` e+  , Exp $ tix10 `Prj` e+  , Exp $ tix9  `Prj` e+  , Exp $ tix8  `Prj` e+  , Exp $ tix7  `Prj` e+  , Exp $ tix6  `Prj` e+  , Exp $ tix5  `Prj` e+  , Exp $ tix4  `Prj` e+  , Exp $ tix3  `Prj` e+  , Exp $ tix2  `Prj` e+  , Exp $ tix1  `Prj` e+  , Exp $ tix0  `Prj` e )++untup13 :: (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)+        => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m)+        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m)+untup13 e =+  ( Exp $ tix12 `Prj` e+  , Exp $ tix11 `Prj` e+  , Exp $ tix10 `Prj` e+  , Exp $ tix9  `Prj` e+  , Exp $ tix8  `Prj` e+  , Exp $ tix7  `Prj` e+  , Exp $ tix6  `Prj` e+  , Exp $ tix5  `Prj` e+  , Exp $ tix4  `Prj` e+  , Exp $ tix3  `Prj` e+  , Exp $ tix2  `Prj` e+  , Exp $ tix1  `Prj` e+  , Exp $ tix0  `Prj` e )++untup14 :: (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)+        => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n)+        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n)+untup14 e =+  ( Exp $ tix13 `Prj` e+  , Exp $ tix12 `Prj` e+  , Exp $ tix11 `Prj` e+  , Exp $ tix10 `Prj` e+  , Exp $ tix9  `Prj` e+  , Exp $ tix8  `Prj` e+  , Exp $ tix7  `Prj` e+  , Exp $ tix6  `Prj` e+  , Exp $ tix5  `Prj` e+  , Exp $ tix4  `Prj` e+  , Exp $ tix3  `Prj` e+  , Exp $ tix2  `Prj` e+  , Exp $ tix1  `Prj` e+  , Exp $ tix0  `Prj` e )++untup15 :: (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)+        => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)+        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o)+untup15 e =+  ( Exp $ tix14 `Prj` e+  , Exp $ tix13 `Prj` e+  , Exp $ tix12 `Prj` e+  , Exp $ tix11 `Prj` e+  , Exp $ tix10 `Prj` e+  , Exp $ tix9  `Prj` e+  , Exp $ tix8  `Prj` e+  , Exp $ tix7  `Prj` e+  , Exp $ tix6  `Prj` e+  , Exp $ tix5  `Prj` e+  , Exp $ tix4  `Prj` e+  , Exp $ tix3  `Prj` e+  , Exp $ tix2  `Prj` e+  , Exp $ tix1  `Prj` e+  , Exp $ tix0  `Prj` e )++untup16 :: (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 p)+        => Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+        -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i, Exp j, Exp k, Exp l, Exp m, Exp n, Exp o, Exp p)+untup16 e =+  ( Exp $ tix15 `Prj` e+  , Exp $ tix14 `Prj` e+  , Exp $ tix13 `Prj` e+  , Exp $ tix12 `Prj` e+  , Exp $ tix11 `Prj` e+  , Exp $ tix10 `Prj` e+  , Exp $ tix9  `Prj` e+  , Exp $ tix8  `Prj` e+  , Exp $ tix7  `Prj` e+  , Exp $ tix6  `Prj` e+  , Exp $ tix5  `Prj` e+  , Exp $ tix4  `Prj` e+  , Exp $ tix3  `Prj` e+  , Exp $ tix2  `Prj` e+  , Exp $ tix1  `Prj` e+  , Exp $ tix0  `Prj` e )+++-- Smart constructor for constants+--++mkMinBound :: (Elt t, IsBounded t) => Exp t+mkMinBound = Exp $ PrimConst (PrimMinBound boundedType)++mkMaxBound :: (Elt t, IsBounded t) => Exp t+mkMaxBound = Exp $ PrimConst (PrimMaxBound boundedType)++mkPi :: (Elt r, IsFloating r) => Exp r+mkPi = Exp $ PrimConst (PrimPi floatingType)+++-- Smart constructors for primitive applications+--++-- Operators from Floating++mkSin :: (Elt t, IsFloating t) => Exp t -> Exp t+mkSin x = Exp $ PrimSin floatingType `PrimApp` x++mkCos :: (Elt t, IsFloating t) => Exp t -> Exp t+mkCos x = Exp $ PrimCos floatingType `PrimApp` x++mkTan :: (Elt t, IsFloating t) => Exp t -> Exp t+mkTan x = Exp $ PrimTan floatingType `PrimApp` x++mkAsin :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAsin x = Exp $ PrimAsin floatingType `PrimApp` x++mkAcos :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAcos x = Exp $ PrimAcos floatingType `PrimApp` x++mkAtan :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAtan x = Exp $ PrimAtan floatingType `PrimApp` x++mkSinh :: (Elt t, IsFloating t) => Exp t -> Exp t+mkSinh x = Exp $ PrimSinh floatingType `PrimApp` x++mkCosh :: (Elt t, IsFloating t) => Exp t -> Exp t+mkCosh x = Exp $ PrimCosh floatingType `PrimApp` x++mkTanh :: (Elt t, IsFloating t) => Exp t -> Exp t+mkTanh x = Exp $ PrimTanh floatingType `PrimApp` x++mkAsinh :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAsinh x = Exp $ PrimAsinh floatingType `PrimApp` x++mkAcosh :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAcosh x = Exp $ PrimAcosh floatingType `PrimApp` x++mkAtanh :: (Elt t, IsFloating t) => Exp t -> Exp t+mkAtanh x = Exp $ PrimAtanh floatingType `PrimApp` x++mkExpFloating :: (Elt t, IsFloating t) => Exp t -> Exp t+mkExpFloating x = Exp $ PrimExpFloating floatingType `PrimApp` x++mkSqrt :: (Elt t, IsFloating t) => Exp t -> Exp t+mkSqrt x = Exp $ PrimSqrt floatingType `PrimApp` x++mkLog :: (Elt t, IsFloating t) => Exp t -> Exp t+mkLog x = Exp $ PrimLog floatingType `PrimApp` x++mkFPow :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t+mkFPow x y = Exp $ PrimFPow floatingType `PrimApp` tup2 (x, y)++mkLogBase :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t+mkLogBase x y = Exp $ PrimLogBase floatingType `PrimApp` tup2 (x, y)++-- Operators from Num++mkAdd :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t+mkAdd x y = Exp $ PrimAdd numType `PrimApp` tup2 (x, y)++mkSub :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t+mkSub x y = Exp $ PrimSub numType `PrimApp` tup2 (x, y)++mkMul :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t+mkMul x y = Exp $ PrimMul numType `PrimApp` tup2 (x, y)++mkNeg :: (Elt t, IsNum t) => Exp t -> Exp t+mkNeg x = Exp $ PrimNeg numType `PrimApp` x++mkAbs :: (Elt t, IsNum t) => Exp t -> Exp t+mkAbs x = Exp $ PrimAbs numType `PrimApp` x++mkSig :: (Elt t, IsNum t) => Exp t -> Exp t+mkSig x = Exp $ PrimSig numType `PrimApp` x++-- Operators from Integral++mkQuot :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkQuot x y = Exp $ PrimQuot integralType `PrimApp` tup2 (x, y)++mkRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkRem x y = Exp $ PrimRem integralType `PrimApp` tup2 (x, y)++mkQuotRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t)+mkQuotRem x y = untup2 $ Exp $ PrimQuotRem integralType `PrimApp` tup2 (x ,y)++mkIDiv :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkIDiv x y = Exp $ PrimIDiv integralType `PrimApp` tup2 (x, y)++mkMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkMod x y = Exp $ PrimMod integralType `PrimApp` tup2 (x, y)++mkDivMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t)+mkDivMod x y = untup2 $ Exp $ PrimDivMod integralType `PrimApp` tup2 (x ,y)+++-- Operators from Bits and FiniteBits++mkBAnd :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkBAnd x y = Exp $ PrimBAnd integralType `PrimApp` tup2 (x, y)++mkBOr :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkBOr x y = Exp $ PrimBOr integralType `PrimApp` tup2 (x, y)++mkBXor :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t+mkBXor x y = Exp $ PrimBXor integralType `PrimApp` tup2 (x, y)++mkBNot :: (Elt t, IsIntegral t) => Exp t -> Exp t+mkBNot x = Exp $ PrimBNot integralType `PrimApp` x++mkBShiftL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+mkBShiftL x i = Exp $ PrimBShiftL integralType `PrimApp` tup2 (x, i)++mkBShiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+mkBShiftR x i = Exp $ PrimBShiftR integralType `PrimApp` tup2 (x, i)++mkBRotateL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+mkBRotateL x i = Exp $ PrimBRotateL integralType `PrimApp` tup2 (x, i)++mkBRotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t+mkBRotateR x i = Exp $ PrimBRotateR integralType `PrimApp` tup2 (x, i)++mkPopCount :: (Elt t, IsIntegral t) => Exp t -> Exp Int+mkPopCount x = Exp $ PrimPopCount integralType `PrimApp` x++mkCountLeadingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int+mkCountLeadingZeros x = Exp $ PrimCountLeadingZeros integralType `PrimApp` x++mkCountTrailingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int+mkCountTrailingZeros x = Exp $ PrimCountTrailingZeros integralType `PrimApp` x+++-- Operators from Fractional++mkFDiv :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t+mkFDiv x y = Exp $ PrimFDiv floatingType `PrimApp` tup2 (x, y)++mkRecip :: (Elt t, IsFloating t) => Exp t -> Exp t+mkRecip x = Exp $ PrimRecip floatingType `PrimApp` x++-- Operators from RealFrac++mkTruncate :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+mkTruncate x = Exp $ PrimTruncate floatingType integralType `PrimApp` x++mkRound :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+mkRound x = Exp $ PrimRound floatingType integralType `PrimApp` x++mkFloor :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+mkFloor x = Exp $ PrimFloor floatingType integralType `PrimApp` x++mkCeiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b+mkCeiling x = Exp $ PrimCeiling floatingType integralType `PrimApp` x++-- Operators from RealFloat++mkAtan2 :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t+mkAtan2 x y = Exp $ PrimAtan2 floatingType `PrimApp` tup2 (x, y)++mkIsNaN :: (Elt t, IsFloating t) => Exp t -> Exp Bool+mkIsNaN x = Exp $ PrimIsNaN floatingType `PrimApp` x++mkIsInfinite :: (Elt t, IsFloating t) => Exp t -> Exp Bool+mkIsInfinite x = Exp $ PrimIsInfinite floatingType `PrimApp` x++-- FIXME: add missing operations from Floating, RealFrac & RealFloat++-- Relational and equality operators++mkLt :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool+mkLt x y = Exp $ PrimLt singleType `PrimApp` tup2 (x, y)++mkGt :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool+mkGt x y = Exp $ PrimGt singleType `PrimApp` tup2 (x, y)++mkLtEq :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool+mkLtEq x y = Exp $ PrimLtEq singleType `PrimApp` tup2 (x, y)++mkGtEq :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool+mkGtEq x y = Exp $ PrimGtEq singleType `PrimApp` tup2 (x, y)++mkEq :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool+mkEq x y = Exp $ PrimEq singleType `PrimApp` tup2 (x, y)++mkNEq :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool+mkNEq x y = Exp $ PrimNEq singleType `PrimApp` tup2 (x, y)++mkMax :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp t+mkMax x y = Exp $ PrimMax singleType `PrimApp` tup2 (x, y)++mkMin :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp t+mkMin x y = Exp $ PrimMin singleType `PrimApp` tup2 (x, y)++-- Logical operators++mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool+mkLAnd x y = Exp $ PrimLAnd `PrimApp` tup2 (x, y)++mkLOr :: Exp Bool -> Exp Bool -> Exp Bool+mkLOr x y = Exp $ PrimLOr `PrimApp` tup2 (x, y)++mkLNot :: Exp Bool -> Exp Bool+mkLNot x = Exp $ PrimLNot `PrimApp` x++-- Character conversions++mkOrd :: Exp Char -> Exp Int+mkOrd x = Exp $ PrimOrd `PrimApp` x++mkChr :: Exp Int -> Exp Char+mkChr x = Exp $ PrimChr `PrimApp` x++-- Numeric conversions++mkFromIntegral :: (Elt a, Elt b, IsIntegral a, IsNum b) => Exp a -> Exp b+mkFromIntegral x = Exp $ PrimFromIntegral integralType numType `PrimApp` x++mkToFloating :: (Elt a, Elt b, IsNum a, IsFloating b) => Exp a -> Exp b+mkToFloating x = Exp $ PrimToFloating numType floatingType `PrimApp` x++-- Other conversions++mkBoolToInt :: Exp Bool -> Exp Int+mkBoolToInt b = Exp $ PrimBoolToInt `PrimApp` b++-- NOTE: Restricted to scalar types with a type-level BitSizeEq constraint to+-- make this version "safe"+mkBitcast :: (Elt a, Elt b, IsScalar (EltRepr a), IsScalar (EltRepr b), BitSizeEq (EltRepr a) (EltRepr b)) => Exp a -> Exp b+mkBitcast = mkUnsafeCoerce++mkUnsafeCoerce :: (Elt a, Elt b) => Exp a -> Exp b+mkUnsafeCoerce = Exp . Coerce+++-- Auxiliary functions+-- --------------------++infixr 0 $$+($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a+(f $$ g) x y = f (g x y)++infixr 0 $$$+($$$) :: (b -> a) -> (c -> d -> e -> b) -> c -> d -> e -> a+(f $$$ g) x y z = f (g x y z)++infixr 0 $$$$+($$$$) :: (b -> a) -> (c -> d -> e -> f -> b) -> c -> d -> e -> f -> a+(f $$$$ g) x y z u = f (g x y z u)++infixr 0 $$$$$+($$$$$) :: (b -> a) -> (c -> d -> e -> f -> g -> b) -> c -> d -> e -> f -> g-> a+(f $$$$$ g) x y z u v = f (g x y z u v)+++-- Debugging+-- ---------++showPreAccOp :: forall acc exp arrs. PreAcc acc exp arrs -> String+showPreAccOp (Atag i)           = "Atag " ++ show i+showPreAccOp (Use a)            = "Use "  ++ showArrays a+showPreAccOp Pipe{}             = "Pipe"+showPreAccOp Acond{}            = "Acond"+showPreAccOp Awhile{}           = "Awhile"+showPreAccOp Atuple{}           = "Atuple"+showPreAccOp Aprj{}             = "Aprj"+showPreAccOp Unit{}             = "Unit"+showPreAccOp Generate{}         = "Generate"+showPreAccOp Reshape{}          = "Reshape"+showPreAccOp Replicate{}        = "Replicate"+showPreAccOp Slice{}            = "Slice"+showPreAccOp Map{}              = "Map"+showPreAccOp ZipWith{}          = "ZipWith"+showPreAccOp Fold{}             = "Fold"+showPreAccOp Fold1{}            = "Fold1"+showPreAccOp FoldSeg{}          = "FoldSeg"+showPreAccOp Fold1Seg{}         = "Fold1Seg"+showPreAccOp Scanl{}            = "Scanl"+showPreAccOp Scanl'{}           = "Scanl'"+showPreAccOp Scanl1{}           = "Scanl1"+showPreAccOp Scanr{}            = "Scanr"+showPreAccOp Scanr'{}           = "Scanr'"+showPreAccOp Scanr1{}           = "Scanr1"+showPreAccOp Permute{}          = "Permute"+showPreAccOp Backpermute{}      = "Backpermute"+showPreAccOp Stencil{}          = "Stencil"+showPreAccOp Stencil2{}         = "Stencil2"+showPreAccOp Aforeign{}         = "Aforeign"+-- showPreAccOp Collect{}          = "Collect"++{--+showPreSeqOp :: PreSeq acc seq exp arrs -> String+showPreSeqOp (StreamIn{})       = "StreamIn"+showPreSeqOp (ToSeq{})          = "ToSeq"+showPreSeqOp (MapSeq{})         = "MapSeq"+showPreSeqOp (ZipWithSeq{})     = "ZipWithSeq"+showPreSeqOp (ScanSeq{})        = "ScanSeq"+showPreSeqOp (FoldSeq{})        = "FoldSeq"+showPreSeqOp (FoldSeqFlatten{}) = "FoldSeqFlatten"+showPreSeqOp (Stuple{})         = "Stuple"+--}++showArrays :: forall arrs. Arrays arrs => arrs -> String+showArrays = display . collect (arrays (undefined::arrs)) . fromArr+  where+    collect :: ArraysR a -> a -> [String]+    collect ArraysRunit         _        = []+    collect ArraysRarray        arr      = [showShortendArr arr]+    collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2+    --+    display []  = []+    display [x] = x+    display xs  = "(" ++ intercalate ", " xs ++ ")"+++showShortendArr :: Elt e => Array sh e -> String+showShortendArr arr+  = show (take cutoff l) ++ if length l > cutoff then ".." else ""+  where+    l      = toList arr+    cutoff = 5+++showPreExpOp :: PreExp acc exp t -> String+showPreExpOp (Tag i)            = "Tag" ++ show i+showPreExpOp (Const c)          = "Const " ++ show c+showPreExpOp Undef              = "Undef"+showPreExpOp Tuple{}            = "Tuple"+showPreExpOp Prj{}              = "Prj"+showPreExpOp IndexNil           = "IndexNil"+showPreExpOp IndexCons{}        = "IndexCons"+showPreExpOp IndexHead{}        = "IndexHead"+showPreExpOp IndexTail{}        = "IndexTail"+showPreExpOp IndexAny           = "IndexAny"+showPreExpOp ToIndex{}          = "ToIndex"+showPreExpOp FromIndex{}        = "FromIndex"+showPreExpOp Cond{}             = "Cond"+showPreExpOp While{}            = "While"+showPreExpOp PrimConst{}        = "PrimConst"+showPreExpOp PrimApp{}          = "PrimApp"+showPreExpOp Index{}            = "Index"+showPreExpOp LinearIndex{}      = "LinearIndex"+showPreExpOp Shape{}            = "Shape"+showPreExpOp ShapeSize{}        = "ShapeSize"+showPreExpOp Intersect{}        = "Intersect"+showPreExpOp Union{}            = "Union"+showPreExpOp Foreign{}          = "Foreign"+showPreExpOp Coerce{}           = "Coerce"+
+ src/Data/Array/Accelerate/Test/NoFib.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE CPP        #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib+-- Copyright   : [2009..2017] 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.Test.NoFib (++  nofib,+  nofibIngredient,++#ifndef ACCELERATE_DISABLE_NOFIB+  module Data.Array.Accelerate.Test.NoFib.Sharing,+  module Data.Array.Accelerate.Test.NoFib.Prelude,+  module Data.Array.Accelerate.Test.NoFib.Imaginary,+  module Data.Array.Accelerate.Test.NoFib.Spectral,+  module Data.Array.Accelerate.Test.NoFib.Issues,+#endif++) where++import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+#ifndef ACCELERATE_DISABLE_NOFIB+import Data.Array.Accelerate.Test.NoFib.Sharing+import Data.Array.Accelerate.Test.NoFib.Prelude+import Data.Array.Accelerate.Test.NoFib.Imaginary+import Data.Array.Accelerate.Test.NoFib.Spectral+import Data.Array.Accelerate.Test.NoFib.Issues++import Test.Tasty+import System.Environment+#endif+++nofib :: RunN -> IO ()+#ifdef ACCELERATE_DISABLE_NOFIB+nofib _    = error $ unlines [ "Data.Array.Accelerate: the nofib test-suite has been disabled."+                             , "Reinstall package 'accelerate' with '-fnofib' to enable it."+                             ]+#else+nofib runN = do+  me <- getProgName+  defaultMainWithIngredients (nofibIngredient : defaultIngredients) $+    testGroup me+      [ test_sharing+      , test_prelude runN+      , test_imaginary runN+      , test_spectral runN+      , test_issues runN+      ]+#endif+
+ src/Data/Array/Accelerate/Test/NoFib/Base.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Base+-- Copyright   : [2009..2017] 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.Test.NoFib.Base+  where++import Data.Array.Accelerate.Array.Sugar                            ( Arrays, Array, Shape, Elt, DIM0, DIM1, DIM2, DIM3, Z(..), (:.)(..), fromList, size )+import Data.Array.Accelerate.Smart                                  ( Acc )+import Data.Array.Accelerate.Trafo.Sharing                          ( Afunction, AfunctionR )+import Data.Array.Accelerate.Type++import Control.Monad++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range+++type Run  = forall a. Arrays a => Acc a -> a+type RunN = forall f. Afunction f => f -> AfunctionR f++dim0 :: Gen DIM0+dim0 = return Z++dim1 :: Gen DIM1+dim1 = (Z :.) <$> Gen.int (Range.linear 0 1024)++dim2 :: Gen DIM2+dim2 = do+  x <- Gen.int (Range.linear 0 128)+  y <- Gen.int (Range.linear 0 48)+  return (Z :. y :. x)++dim3 :: Gen DIM3+dim3 = do+  x <- Gen.int (Range.linear 0 64)+  y <- Gen.int (Range.linear 0 32)+  z <- Gen.int (Range.linear 0 16)+  return (Z :. z :. y :. x)++array :: (Shape sh, Elt e) => sh -> Gen e -> Gen (Array sh e)+array sh gen = fromList sh <$> Gen.list (Range.singleton (size sh)) gen++int :: Gen Int+int = Gen.int Range.linearBounded++i8 :: Gen Int8+i8 = Gen.int8 Range.linearBounded++i16 :: Gen Int16+i16 = Gen.int16 Range.linearBounded++i32 :: Gen Int32+i32 = Gen.int32 Range.linearBounded++i64 :: Gen Int64+i64 = Gen.int64 Range.linearBounded++word :: Gen Word+word = Gen.word Range.linearBounded++w8 :: Gen Word8+w8 = Gen.word8 Range.linearBounded++w16 :: Gen Word16+w16 = Gen.word16 Range.linearBounded++w32 :: Gen Word32+w32 = Gen.word32 Range.linearBounded++w64 :: Gen Word64+w64 = Gen.word64 Range.linearBounded++f16 :: Gen Half+f16 = Gen.realFloat (Range.linearFracFrom 0 (-log_flt_max) log_flt_max)++f32 :: Gen Float+f32 = Gen.float (Range.linearFracFrom 0 (-log_flt_max) log_flt_max)++f64 :: Gen Double+f64 = Gen.double (Range.linearFracFrom 0 (-log_flt_max) log_flt_max)++log_flt_max :: RealFloat a => a+log_flt_max = log flt_max++flt_max :: RealFloat a => a+flt_max = x+  where+    n   = floatDigits x+    b   = floatRadix x+    inf = let (u,v) = floatRange x in max u v   -- bug in half <= 0.2.2.3+    x   = encodeFloat (b^n - 1) (inf - n)++flt_min :: RealFloat a => a+flt_min = x+  where+    n   = floatDigits x+    b   = floatRadix x+    sup = let (u,v) = floatRange x in min u v   -- bug in half <= 0.2.2.3+    x   = encodeFloat (b^n - 1) (sup - n - 1)++except :: Gen e -> (e -> Bool) -> Gen e+except gen f  = do+  v <- gen+  when (f v) Gen.discard+  return v++splitEvery :: Int -> [a] -> [[a]]+splitEvery _ [] = cycle [[]]+splitEvery n xs =+  let (h,t) = splitAt n xs+  in  h : splitEvery n t++splitPlaces :: [Int] -> [a] -> [[a]]+splitPlaces []     _  = []+splitPlaces (i:is) vs =+  let (h,t) = splitAt i vs+  in  h : splitPlaces is t+
+ src/Data/Array/Accelerate/Test/NoFib/Config.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeOperators      #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Config+-- Copyright   : [2009..2017] 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.Test.NoFib.Config+  where++import Data.Bits+import Data.Proxy+import Data.Typeable++import Test.Tasty+import Test.Tasty.Ingredients+import Test.Tasty.Options+++nofibIngredient :: Ingredient+nofibIngredient =+  includingOptions+    [ Option (Proxy::Proxy TestHalf)+    , Option (Proxy::Proxy TestFloat)+    , Option (Proxy::Proxy TestDouble)+    , Option (Proxy::Proxy TestInt8)+    , Option (Proxy::Proxy TestInt16)+    , Option (Proxy::Proxy TestInt32)+    , Option (Proxy::Proxy TestInt64)+    , Option (Proxy::Proxy TestWord8)+    , Option (Proxy::Proxy TestWord16)+    , Option (Proxy::Proxy TestWord32)+    , Option (Proxy::Proxy TestWord64)+    , Option (Proxy::Proxy Interpreter)+    ]++newtype TestAll     = TestAll     Bool deriving (Eq, Show, Typeable)+newtype TestHalf    = TestHalf    Bool deriving (Eq, Show, Typeable)+newtype TestFloat   = TestFloat   Bool deriving (Eq, Show, Typeable)+newtype TestDouble  = TestDouble  Bool deriving (Eq, Show, Typeable)+newtype TestInt8    = TestInt8    Bool deriving (Eq, Show, Typeable)+newtype TestInt16   = TestInt16   Bool deriving (Eq, Show, Typeable)+newtype TestInt32   = TestInt32   Bool deriving (Eq, Show, Typeable)+newtype TestInt64   = TestInt64   Bool deriving (Eq, Show, Typeable)+newtype TestWord8   = TestWord8   Bool deriving (Eq, Show, Typeable)+newtype TestWord16  = TestWord16  Bool deriving (Eq, Show, Typeable)+newtype TestWord32  = TestWord32  Bool deriving (Eq, Show, Typeable)+newtype TestWord64  = TestWord64  Bool deriving (Eq, Show, Typeable)+newtype Interpreter = Interpreter Bool deriving (Eq, Show, Typeable)++instance IsOption TestAll where+  defaultValue = TestAll False+  parseValue = fmap TestAll . safeRead+  optionName = return "all-types"+  optionHelp = return "Enable tests on all primitive types"++instance IsOption TestHalf where+  defaultValue = TestHalf False+  parseValue = fmap TestHalf . safeRead+  optionName = return "half"+  optionHelp = return "Enable half-precision tests"++instance IsOption TestFloat where+  defaultValue = TestFloat False+  parseValue = fmap TestFloat . safeRead+  optionName = return "float"+  optionHelp = return "Enable single-precision tests"++instance IsOption TestDouble where+  defaultValue = TestDouble True+  parseValue = fmap TestDouble . safeRead+  optionName = return "double"+  optionHelp = return "Enable double-precision tests"++instance IsOption TestInt8 where+  defaultValue = TestInt8 False+  parseValue = fmap TestInt8 . safeRead+  optionName = return "int8"+  optionHelp = return "Enable 8-bit signed integer tests"++instance IsOption TestInt16 where+  defaultValue = TestInt16 False+  parseValue = fmap TestInt16 . safeRead+  optionName = return "int16"+  optionHelp = return "Enable 16-bit signed integer tests"++instance IsOption TestInt32 where+  defaultValue = TestInt32 $( [e| finiteBitSize (undefined::Int) == 32 |] )+  parseValue = fmap TestInt32 . safeRead+  optionName = return "int32"+  optionHelp = return "Enable 32-bit signed integer tests"++instance IsOption TestInt64 where+  defaultValue = TestInt64 $( [e| finiteBitSize (undefined::Int) == 64 |] )+  parseValue = fmap TestInt64 . safeRead+  optionName = return "int64"+  optionHelp = return "Enable 64-bit signed integer tests"++instance IsOption TestWord8 where+  defaultValue = TestWord8 False+  parseValue = fmap TestWord8 . safeRead+  optionName = return "word8"+  optionHelp = return "Enable 8-bit unsigned integer tests"++instance IsOption TestWord16 where+  defaultValue = TestWord16 False+  parseValue = fmap TestWord16 . safeRead+  optionName = return "word16"+  optionHelp = return "Enable 16-bit unsigned integer tests"++instance IsOption TestWord32 where+  defaultValue = TestWord32 False+  parseValue = fmap TestWord32 . safeRead+  optionName = return "word32"+  optionHelp = return "Enable 32-bit unsigned integer tests"++instance IsOption TestWord64 where+  defaultValue = TestWord64 False+  parseValue = fmap TestWord64 . safeRead+  optionName = return "word64"+  optionHelp = return "Enable 64-bit unsigned integer tests"++instance IsOption Interpreter where+  defaultValue = Interpreter False+  parseValue = fmap Interpreter . safeRead+  optionName = return "interpreter"+  optionHelp = return "I am an interpreter (skip some tests)"+++class IsOption a => TestConfig a where+  at :: Proxy a -> TestTree -> TestTree++instance TestConfig TestHalf where+  at _ t = askOption $ \(TestHalf v)   -> if v then t else testGroup "Half" []++instance TestConfig TestFloat where+  at _ t = askOption $ \(TestFloat v)  -> if v then t else testGroup "Float" []++instance TestConfig TestDouble where+  at _ t = askOption $ \(TestDouble v) -> if v then t else testGroup "Double" []++instance TestConfig TestInt8 where+  at _ t = askOption $ \(TestInt8 v)   -> if v then t else testGroup "Int8" []++instance TestConfig TestInt16 where+  at _ t = askOption $ \(TestInt16 v)  -> if v then t else testGroup "Int16" []++instance TestConfig TestInt32 where+  at _ t = askOption $ \(TestInt32 v)  -> if v then t else testGroup "Int32" []++instance TestConfig TestInt64 where+  at _ t = askOption $ \(TestInt64 v)  -> if v then t else testGroup "Int64" []++instance TestConfig TestWord8 where+  at _ t = askOption $ \(TestWord8 v)  -> if v then t else testGroup "Word8" []++instance TestConfig TestWord16 where+  at _ t = askOption $ \(TestWord16 v) -> if v then t else testGroup "Word16" []++instance TestConfig TestWord32 where+  at _ t = askOption $ \(TestWord32 v) -> if v then t else testGroup "Word32" []++instance TestConfig TestWord64 where+  at _ t = askOption $ \(TestWord64 v) -> if v then t else testGroup "Word64" []+
+ src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Imaginary+-- Copyright   : [2009..2017] 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.Test.NoFib.Imaginary (++  test_imaginary,++  module Data.Array.Accelerate.Test.NoFib.Imaginary.SASUM,+  module Data.Array.Accelerate.Test.NoFib.Imaginary.SAXPY,+  module Data.Array.Accelerate.Test.NoFib.Imaginary.DotP,++) where++import Test.Tasty++import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Imaginary.SASUM+import Data.Array.Accelerate.Test.NoFib.Imaginary.SAXPY+import Data.Array.Accelerate.Test.NoFib.Imaginary.DotP+++test_imaginary :: RunN -> TestTree+test_imaginary runN =+  testGroup "imaginary"+    [ test_sasum runN+    , test_saxpy runN+    , test_dotp runN+    ]+
+ src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Imaginary.DotP+-- Copyright   : [2009..2017] 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.Test.NoFib.Imaginary.DotP (++  test_dotp++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                  as P++import Data.Array.Accelerate                                    as A+import Data.Array.Accelerate.Array.Sugar                        as S+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                   as Gen+import qualified Hedgehog.Range                                 as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_dotp :: RunN -> TestTree+test_dotp runN =+  testGroup "dot product"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestHalf)   $ testElt f16+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testProperty (show (typeOf (undefined :: a))) $ test_dotp' runN e+++test_dotp'+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_dotp' runN e =+  property $ do+    sh <- forAll ((Z:.) <$> Gen.int (Range.linear 0 16384))+    xs <- forAll (array sh e)+    ys <- forAll (array sh e)+    let !go = runN dotp in go xs ys S.! Z ~~~ dotpRef xs ys++dotp :: A.Num e => Acc (Vector e) -> Acc (Vector e) -> Acc (Scalar e)+dotp xs ys+  = A.fold (+) 0+  $ A.zipWith (*) xs ys++dotpRef :: P.Num e => Vector e -> Vector e -> e+dotpRef xs ys+  = P.sum ( P.zipWith (*) (toList xs) (toList ys) )+
+ src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Imaginary.SASUM+-- Copyright   : [2009..2017] 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.Test.NoFib.Imaginary.SASUM (++  test_sasum++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                  as P++import Data.Array.Accelerate                                    as A+import Data.Array.Accelerate.Array.Sugar                        as S+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                   as Gen+import qualified Hedgehog.Range                                 as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_sasum :: RunN -> TestTree+test_sasum runN =+  testGroup "sasum"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestHalf)   $ testElt f16+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testProperty (show (typeOf (undefined :: a))) $ test_sasum' runN e+++test_sasum'+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_sasum' runN e =+  property $ do+    sh <- forAll ((Z:.) <$> Gen.int (Range.linear 0 16384))+    xs <- forAll (array sh e)+    let !go = runN sasum in go xs S.! Z ~~~ sasumRef xs++sasum :: A.Num e => Acc (Vector e) -> Acc (Scalar e)+sasum = A.fold (+) 0 . A.map abs++sasumRef :: P.Num e => Vector e -> e+sasumRef xs = P.sum [ abs x | x <- toList xs ]+
+ src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Imaginary.SAXPY+-- Copyright   : [2009..2017] 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.Test.NoFib.Imaginary.SAXPY (++  test_saxpy++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                  as P++import Data.Array.Accelerate                                    as A+import Data.Array.Accelerate.Array.Sugar                        as S+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                   as Gen+import qualified Hedgehog.Range                                 as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_saxpy :: RunN -> TestTree+test_saxpy runN =+  testGroup "saxpy"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestHalf)   $ testElt f16+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testProperty (show (typeOf (undefined :: a))) $ test_saxpy' runN e+++test_saxpy'+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_saxpy' runN e =+  property $ do+    sh    <- forAll ((Z:.) <$> Gen.int (Range.linear 0 16384))+    alpha <- forAll e+    xs    <- forAll (array sh e)+    ys    <- forAll (array sh e)+    let !go = runN saxpy in go (scalar alpha) xs ys ~~~ saxpyRef alpha xs ys++scalar :: Elt e => e -> Scalar e+scalar x = fromFunction Z (const x)++saxpy :: A.Num e => Acc (Scalar e) -> Acc (Vector e) -> Acc (Vector e) -> Acc (Vector e)+saxpy alpha xs ys = A.zipWith (\x y -> the alpha * x + y) xs ys++saxpyRef :: (P.Num e, Elt e) => e -> Vector e -> Vector e -> Vector e+saxpyRef alpha xs ys =+  fromFunction+    (S.shape xs `S.intersect` S.shape ys)+    (\ix -> alpha * (xs S.! ix) + (ys S.! ix))+
+ src/Data/Array/Accelerate/Test/NoFib/Issues.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues+-- Copyright   : [2009..2017] 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.Test.NoFib.Issues (++  test_issues,++  module Data.Array.Accelerate.Test.NoFib.Issues.Issue93,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue102,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue114,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue119,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue123,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue137,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue168,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue184,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue185,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue187,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue228,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue255,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue264,+  -- module Data.Array.Accelerate.Test.NoFib.Issues.Issue286,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue287,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue288,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue362,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue407,+  module Data.Array.Accelerate.Test.NoFib.Issues.Issue409,++) where++import Test.Tasty++import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Issues.Issue93+import Data.Array.Accelerate.Test.NoFib.Issues.Issue102+import Data.Array.Accelerate.Test.NoFib.Issues.Issue114+import Data.Array.Accelerate.Test.NoFib.Issues.Issue119+import Data.Array.Accelerate.Test.NoFib.Issues.Issue123+import Data.Array.Accelerate.Test.NoFib.Issues.Issue137+import Data.Array.Accelerate.Test.NoFib.Issues.Issue168+import Data.Array.Accelerate.Test.NoFib.Issues.Issue184+import Data.Array.Accelerate.Test.NoFib.Issues.Issue185+import Data.Array.Accelerate.Test.NoFib.Issues.Issue187+import Data.Array.Accelerate.Test.NoFib.Issues.Issue228+import Data.Array.Accelerate.Test.NoFib.Issues.Issue255+import Data.Array.Accelerate.Test.NoFib.Issues.Issue264+-- import Data.Array.Accelerate.Test.NoFib.Issues.Issue286+import Data.Array.Accelerate.Test.NoFib.Issues.Issue287+import Data.Array.Accelerate.Test.NoFib.Issues.Issue288+import Data.Array.Accelerate.Test.NoFib.Issues.Issue362+import Data.Array.Accelerate.Test.NoFib.Issues.Issue407+import Data.Array.Accelerate.Test.NoFib.Issues.Issue409+++test_issues :: RunN -> TestTree+test_issues runN =+  testGroup "issues"+    [ test_issue93  runN+    , test_issue102 runN+    , test_issue114 runN+    , test_issue119 runN+    , test_issue123 runN+    , test_issue137 runN+    , test_issue168 runN+    , test_issue184 runN+    , test_issue185 runN+    , test_issue187 runN+    , test_issue228 runN+    , test_issue255 runN+    , test_issue264 runN+    -- , test_issue286 runN+    , test_issue287 runN+    , test_issue288 runN+    , test_issue362 runN+    , test_issue407 runN+    , test_issue409 runN+    ]+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE RankNTypes    #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue102+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/102+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue102 (++  test_issue102++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue102 :: RunN -> TestTree+test_issue102 runN =+  testCase "102"  $ ref1 @=? runN test1+++ref1 :: Array DIM3 Int+ref1 = fromList (Z :. 1 :. 3 :. 1) [4,4,4]++test1 :: Acc (Array DIM3 Int)+test1 =+  let p         = 3+      lts       = 1+      rts       = 1+      rustride  = 1++      v         = fill (constant (Z:.(p-1))) (constant 2)+      ru'       = fill (constant (Z:.(p-1))) (constant 1)++      -- generate a vector with phi(p)=p-1 elements+      x'        = reshape (constant (Z :. lts :. (p-1) :. rts)) v++      --embed into a vector of length p+      y         = generate (constant (Z :. lts :. p :. rts))+                           (\ix -> let (Z :. l :. i :. r) = unlift ix :: Z :. Exp Int :. Exp Int :. Exp Int+                                   in  i A.== 0 ? (0, x' ! (lift $ Z :. l :. i-1 :. r)))++      -- do a DFT_p+      y'        = reshape (constant (Z :. lts :. p :. rts)) (flatten y)+      dftrus    = generate (constant (Z :. p :. p))+                           (\ix -> let (Z :. i :. j) = unlift ix :: Z :. Exp Int :. Exp Int+                                   in ru' ! (lift (Z :. (i*j*rustride `mod` (constant p)))))++      tensorDFTCoeffs   = A.replicate (lift (Z:.lts:.All:.rts:.All)) dftrus+      tensorInputCoeffs = generate (shape tensorDFTCoeffs)+                                   (\ix -> let (Z:.l:._:.r:.col) = unlift ix :: Z :. Exp Int :. Exp Int :. Exp Int :. Exp Int+                                           in  y' ! (lift $ Z:.l:.col:.r))++      dftans    = flatten $ fold (+) (constant 0) $ A.zipWith (*) tensorDFTCoeffs tensorInputCoeffs++      --continue the alternate transform, but this line breaks+      dfty      = reshape (shape y) $ dftans+  in+  dfty+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue114+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/114+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue114 (++  test_issue114++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.Similar+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit++import Control.Monad+import Prelude                                                      as P+++test_issue114 :: RunN -> TestTree+test_issue114 runN =+  testGroup "114"+    [ testCase "A"  $ ref1 @~? runN test1+    , testCase "B"  $ ref2 @~? runN test2+    ]+++(@~?) :: (Similar a, Show a) => a -> a -> Assertion+expected @~? actual =+  unless (expected ~= actual) $+    assertFailure $ "expected: " P.++ show expected P.++ "\n but got: " P.++ show actual+++type EFloat = (Float, Float) -- Represents a real number with a value and error++fromFloat :: Float -> EFloat+fromFloat x = (x, 0)++-- toFloat :: EFloat -> Float+-- toFloat (val, err) = val + err++add :: Exp EFloat -> Exp EFloat -> Exp EFloat+add = lift2 f+    where+        f :: (Exp Float, Exp Float) -> (Exp Float, Exp Float) -> (Exp Float, Exp Float)+        f (aval, aerr) (bval, berr) = (val, err)+            where+                val = aval + bval+                err = aval - (val - det) + (bval - det) + aerr + berr+                det = val - aval++esum :: Acc (Vector EFloat) -> Acc (Scalar EFloat)+esum  x = A.fold1  add x++epsum :: Acc (Vector EFloat) -> Acc (Vector EFloat)+epsum x = A.scanl1 add x++xs :: Acc (Vector EFloat)+xs = use $ fromFunction (Z :. 100) (\_ -> fromFloat 1.01)+++ref1 :: Scalar EFloat+ref1 = fromList Z [(101,0)]++test1 :: Acc (Scalar EFloat)+test1 = esum xs+++ref2 :: Vector EFloat+ref2 = fromList (Z :. 100) [ (1.01 * i, 0) | i <- [1..]]++test2 :: Acc (Vector EFloat)+test2 = epsum xs+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue119+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/119+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue119 (++  test_issue119++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue119 :: RunN -> TestTree+test_issue119 runN =+  testGroup "119"+    [ testCase "A"  $ ref1  @=? runN test1+    , testCase "B"  $ ref2  @=? runN test2+    , testCase "C"  $ ref3  @=? runN test3+    , testCase "D"  $ ref4  @=? runN test4+    , testCase "E"  $ ref5  @=? runN test5+    , testCase "F"  $ ref6  @=? runN test6+    , testCase "G"  $ ref7  @=? runN test7+    , testCase "H"  $ ref8  @=? runN test8+    , testCase "I"  $ ref9  @=? runN test9+    , testCase "J"  $ ref10 @=? runN test10+    , testCase "K"  $ ref11 @=? runN test11+    ]+++-- Fold tests+-- ----------++ref1 :: Scalar Int32+ref1 = fromList Z [734889155]++test1 :: Acc (Scalar Int32)+test1 = A.foldAll (+) 0 xs+  where+    xs :: Acc (Array DIM2 Int32)+    xs = use $ fromList (Z :. 5 :. 28) [14769239,-43969807,34096869,26467320,-21446403,-19566997,-20757196,-66879020,19321522,16802755,51423005,-30832656,12956743,-12318583,-48025228,61945796,-2250529,18157252,-44635606,-57062680,54654752,-45950438,-45550976,-62875929,66292458,64296866,34105235,20487639,30133337,-34016948,46574440,-21782247,7668293,8257005,-52134520,65769526,-53807259,56265864,44995988,2419563,50453876,57043978,32058611,41795482,1356242,28417251,5365744,-50462079,-4690548,-63375747,-46568125,17130936,-9136428,53870799,65779607,65381795,-32284364,1085336,41766147,-48032615,-8611290,-31457130,52882781,-11785315,31039408,14338797,11749455,4037928,-28111863,50044760,-63234128,17276128,8579326,57409776,64794871,-43959064,17740348,33371212,-18433618,303726,8599511,14055754,38794127,-49407153,-20949080,-66174156,-43639360,13828228,-36941738,-2879784,-32949921,5454298,46134687,58015243,-2497378,-35813131,-66438706,-28087800,-22569678,21234344,51086800,-17488916,62884654,55526000,31676635,7777220,38149962,66027320,-23764609,41016045,18232856,6488342,20118159,28851925,-6610856,23434278,-57333215,57974240,-66022236,55082111,61254643,-52552004,-62140522,-13018201,17313534,6955448,52914957,8368369,-25845462,50594480,-32920224,-26202745,-25861093,55035780,-60835478,6582276,55668636,26991003,228691,62551594]+++ref2 :: Scalar Int32+ref2 = fromList Z [638248245]++test2 :: Acc (Scalar Int32)+test2 = A.foldAll (+) z xs+  where+    z  = constant 0+    xs :: Acc (Array DIM2 Int32)+    xs = use $ fromList (Z :. 28 :. 5) [30332431,6796098,-15522385,-32163376,-22219878,10020835,22638601,20673036,-30769405,-23271551,16790184,-17975968,29134928,29540030,15695897,-9531463,12041364,15327083,-7856190,28479946,24497912,-13994046,5037581,-25167431,11992516,-25544745,26910784,-29607037,21237332,30371276,1858744,20239265,1576853,5549626,1732708,21169707,-8592014,-17303153,-4691351,29659929,-17704246,-13035309,-21373638,14713362,21130870,-6403753,13321799,22126635,30318513,-25651322,-10668441,-24247707,24353923,-5541473,15335372,-7118652,-28357515,30896735,19938864,21360170,16766774,29976096,10055680,9181294,10294712,-23189559,28234139,19443020,20018378,18990662,12790940,-31136432,7945796,-11687674,4320146,-1353679,21896288,2731169,24625097,12506224,27189679,-10270450,3097174,-11012112,29232397,3162933,-11403300,30059570,-9243914,13047945,16513682,-8138375,-17921376,30769432,23685828,21912950,9206743,25339626,11122590,-13094182,-20380905,-8019817,3199026,21598845,4761221,9104850,-30744683,29597011,-26264428,-17658633,831337,-8352528,-27450307,-29451038,9006711,-21943478,25866183,21329008,-7148827,14493559,-14888430,-26543546,25318288,-14096306,-9132505,2388950,9740892,-12973005,10141734,28363840,-1974095,12753649,26765381,23979765,15399126,20204488,19148086,14457571,-18842735,31509219]+++ref3 :: Scalar Int64+ref3 = fromList Z [-2304750112110]++test3 :: Acc (Scalar Int64)+test3 = A.foldAll (+) 0 xs+  where+    xs :: Acc (Array DIM2 Int64)+    xs = use $ fromList (Z :. 4 :. 34) [-119582066848,211418632971,-273814068829,-441336869225,49277660114,545904743034,-107108516086,272730345990,-227553979182,-205217278623,-334933374202,51481780401,-243087611110,499367622597,-281520298752,183942102289,-352104016609,-411607044687,-462706494917,-405072342281,-443472456667,57859494326,340657028984,268146891294,319572181437,-328099124733,-499762864333,435940295598,310279498548,-450247211372,101309611345,508483612496,170564579262,-18976287892,-455590358368,171197058025,-370071394217,238505304901,201668743044,498589419201,297393267447,303651235875,504136702140,240153057419,227119976864,-54751959043,-389119831605,35618580405,-155315665549,539301360661,461515245841,-420790558552,-407621743214,512382547226,64401598442,75455583959,-422914101157,-444213359875,-464670739203,-151444593289,12666639431,366304035864,33213351756,-337126953996,469279395971,-318783703943,524684201810,-360908771731,-365270829375,95123780502,-392655992888,-76730831811,479382581014,-223793301821,-405318001331,-478562160184,-163914780202,-411178397558,-73093917592,322239790820,420249956833,-122752719617,-420777967956,-489170073738,232626269189,398537832770,136477711761,-117743069079,473757016199,461956975541,75333205695,122914427050,-277154707123,-344965932671,18790179442,242296707870,183037500718,380718816714,-433509147619,305765602753,436058308076,-140428136472,-289391463887,-530251700495,-306686789129,224410693891,-484184400934,463805089162,-501756254322,393903748222,-269147001559,-359942689809,-163943277620,74971067748,-202611183518,-308196672762,320023013452,75437650523,475680122061,446935336626,114910599577,-421539248344,-25530906498,-424571606102,-396438535665,354002379792,134141026509,-543141869270,-347289264435,333557662160,33168540124,-167015747466,268026632123,-65645693801,-196414232999,393080421747]++ref4 :: Scalar Int64+ref4 = fromList Z [-1982037004259]++test4 :: Acc (Scalar Int64)+test4 = A.foldAll (+) z xs+  where+    z = constant 0+    xs :: Acc (Array DIM2 Int64)+    xs = use $ fromList (Z :. 27 :. 5) [-516950650221,-198681319472,-62248207215,-368566588052,-221815889746,-404814200669,15045398798,430679777170,163443360209,58097521335,-87590898111,497607465075,-27049301510,149071552167,-119172901827,-108679661992,412502711937,-213838885992,-491807426758,-169121244505,377480661744,-364997600163,452887211838,498386633616,-196697034533,426777341897,-459406805363,-239048240471,250937389006,-453316577416,477182495522,-79624988438,-483304189443,141157669081,355197721240,-328308821798,10400185896,398549525265,-141936649498,218818467494,402542618206,456236393213,-503876199918,52591145304,-149056547666,-336820739966,-101305073619,-472113159559,-321357874802,-95088218225,47976047271,509800579620,-145214377978,258457805786,252700511510,537909713977,247668230739,-259697031014,-230995125913,77530842572,283307049087,-411792373178,324606551065,302376540936,500057254214,36752111995,-55143618182,-42362785469,-68090351859,-345780793879,485419604422,-525756197664,-67428156655,121298292757,-523227354037,542168812603,-63016595487,404709620252,492764196616,173842446373,-251029882829,53802486346,-530196219472,38098754466,-451928062539,-198941999979,-430777494835,356103891588,-478934564072,421540513969,129261909711,267834058695,-449200229070,-153755923804,548585896851,-362848223110,166182675419,272214294990,-530215315236,-342214087116,-474705180756,168367792089,-53404310532,-472623730372,-147327201280,519069543952,-135155501227,159093854025,-268230727831,529927846798,-135583708544,-435621161817,-482622020289,-337169671550,-199594728505,85511984309,389604901651,276696290309,336198922744,-456923645150,186500760911,388034346215,-121368960575,168640682551,-7576869074,69728513684,276429408489,-383852114311,-496978282447,-257731685849,286922686952,332263669356,-371802274827,144134413275,-524312126151]+++ref5 :: Vector Int32+ref5 = fromList (Z :. 1) [-564354555]++test5 :: Acc (Vector Int32)+test5 = A.fold (+) 0 xs+  where+    xs :: Acc (Array DIM2 Int32)+    xs = use $ fromList (Z :. 1 :. 130) [-4457702,-122533607,-128044610,-118567484,-51241069,207290580,-220286030,4228986,27469434,-150317120,-203604157,-825364,-5199079,33434421,-254928269,215941275,-84557225,155733915,171166525,94162372,46201848,74472984,-20540100,203227620,-205035659,139581872,-64200870,-95685833,-248817216,181149788,-51154438,5754365,-39623339,-30285278,-124075023,-116700449,198097791,-79621402,-6975987,-103294438,-193880739,-42554593,-52665481,-6774561,-145101208,217440464,-234644017,-165019600,-141695655,-110020351,179140674,66343428,43188757,192222207,196444242,72638801,260767189,-234015110,238745515,-12235263,114454889,-117207038,-56788533,-166739373,207303540,-52047526,-2280395,31679387,87315138,181256391,-197760275,147977350,-105987066,-126709084,-180021047,-91253871,88115823,-220087038,141701192,-100881541,197803243,-35493996,71878227,123953012,190031396,233047641,-172754808,-87849442,-82869836,-208702873,-91940076,-42225767,124028996,-129061972,7648559,28609363,258568067,-156621004,154765390,-15205853,-189458486,-55442626,133343504,-107377067,-153448167,-83812681,216682270,235806226,-155366374,-29170502,-113839485,-249632147,220516680,159108225,49056288,-14524239,148547005,151302845,53892421,-215278906,-59578587,-36754634,169714732,-4520583,40832244,159375461,236429345,-257962058,-19375172,-98736004]+++-- Scan tests+-- ----------++ref6 :: Vector Int64+ref6 = fromList (Z :. 748) [9125498,-16063035,-50980,-27239361,-28337646,-37708670,-21121249,-11217118,-13848672,-39334849,-46707491,-66531944,-43011362,-52687842,-22827761,-971267,-5223404,-4411473,-18981275,13313900,6542877,11493167,22215941,15573052,-4268436,13222384,11042779,-3043325,-30361025,-12714603,3072363,31204175,3603936,1445050,3106420,-10215901,-35287878,-41312051,-33332828,-8728274,-5932326,15089470,15341055,22710136,33070009,20938516,9183939,13338488,27196906,10726312,-19896886,-5528880,-25763431,-47546113,-21147316,8321444,1963928,-26863855,-250164,32934074,44835086,57843946,26305229,6456986,-26980567,-41996719,-70804933,-84259108,-87879612,-110692672,-142798291,-116098588,-85567404,-116207069,-123821326,12584983,25114364,-7860303,1367004,22680794,6730923,24499547,45160622,66310423,75777515,95908783,82670280,75336288,86887135,72442174,70887722,56336211,86112478,69983042,71665675,72070119,94687414,125141027,117692500,91136141,111363947,94258056,102908356,70818523,80142514,92859070,122763909,93075287,77155392,54968337,29421292,31177870,1920103,6519230,-19551499,-21222657,-570094,-24097292,-21808392,-10348212,-25233388,1173489,-9736680,16762526,28315631,29037674,11984290,21576469,34826173,1642762,32046691,35140081,58642652,77835445,80197959,89973092,115910407,129847184,118117169,95353096,79367357,62093373,28767797,-2146590,-10917398,20424644,4676917,7932556,3312401,-15966908,-7189949,5420963,8175943,4434171,-23666656,-10061080,-6041726,-31631217,-46272817,-61706087,-29314516,-7596012,14721710,37426611,63932827,37620518,28457552,40061842,31619691,27526728,56295666,80222812,105097861,88788604,97864477,79172130,10011195,-11909105,14225322,47137915,41586134,43468287,16346843,33297215,32170527,53289540,54985040,81533030,110490559,94932129,-13972154,-562189,-26994686,-56883836,-38812939,-13124808,-40371526,-52769442,-21433054,-38472715,-27141571,-29136605,-25500474,-3609550,2499409,-5483029,7386627,-24798720,-19594335,-27615046,-27638210,-60052370,-60759465,21354265,35287006,20122081,39265392,30972278,-57680,-32797288,-40752069,-27338717,-42161108,-14223907,-26783347,2619156,-14191849,6138144,7386063,-2032880,-1427633,24663443,12623199,41575592,41247980,57154315,51594681,59172894,71372344,62594824,88295328,58813946,37705204,28408628,16061632,9164297,-20127170,-9336346,-19571825,-52179514,-68566225,-54477198,-47004940,-29937062,-26901831,-4920101,3005622,7980962,8028145,29521179,4597970,28713400,59139068,43239497,14548340,-5703663,19550414,41133083,40431977,71464673,71868771,61227439,41134554,31050857,8517828,36666702,67999523,50219401,20584724,22991750,27378599,54105073,39320349,15820114,40457939,41491964,23091500,7320002,-21415520,9737506,37844167,55041071,80397844,102622122,100100178,86108928,104370032,96478192,129355326,154538582,125989958,143228198,145176468,139822044,153528336,178316046,164246971,175794520,146308152,146195800,176242327,204855629,175565103,7396173,21863242,35694390,20236011,2751512,20138366,15394266,-820941,-4081067,-14269206,6911689,-11814644,-29241281,-49447821,29070717,12178489,4706892,-12315553,-19458729,-21356132,32958033,45401858,53370676,28467559,19593822,-2362034,-22117369,-7304152,-39099651,-22225335,-11600163,-22285664,2291892,-7750742,-7695599,6170980,-15707745,-37482681,-55991916,-82981918,-83046513,-56843137,-84028152,-114039097,-143926441,-152072244,-126187325,-147424750,-167404074,-162720270,-190867797,-167936982,-141061455,-109557195,-97843277,-111686956,-136635385,-104293809,-74950582,25017856,23279847,50087106,44767052,28328844,44871147,17608101,35664270,61602884,52831414,70249540,1819043,3429541,11974074,-13604141,-9364540,-31853055,1318244,-32151004,-31320318,-44830769,-21132509,-13995287,9516139,-22382471,-15989865,-4087485,-14545639,-41647841,-35817861,-30140793,-62661641,-37684047,-10791435,-31361559,-28965957,-35074554,-18300410,5455270,23648211,32414689,50928057,84178047,64930378,93870236,79795842,86863035,105461553,79769102,80114784,54005743,33702322,65727435,62447610,52138169,43806272,31938677,37096050,70218042,77215870,106108777,139027677,114174251,126267131,140175411,160639557,193663077,206137637,220658257,202941018,-12251575,-23552773,-55866025,-23809513,-20926637,-31109913,-39762123,-46364008,-60594496,-42978446,-13334636,-30452598,-50434052,-61031253,-74842844,-93367283,-61532012,-84351158,-84841171,-104231070,-100891101,-126393754,-103372367,-130732559,-19187634,14573150,41644350,15935939,-17222201,13190162,18958067,-14125622,-24081209,3812159,26073207,1502885,27132466,50360103,32308017,43791273,28658841,-3014391,17498899,39691132,55285193,24930027,1313945,8269524,-3616873,-6270603,18469472,36099131,39395283,19467169,35946131,56127923,23068454,-3858447,127864,80862,7732537,-19112498,-51201127,-26195163,-56817262,-25264735,8237471,22946551,43448141,44527962,15371977,41182890,37330623,23803440,25133955,21428283,16975035,3669458,-3948266,-18836608,-46801069,-52964698,-22530552,-43387214,-61356367,-25196164,14528267,42710847,12057272,-28567150,-4999302,-9802327,-40044668,-50932747,-55517409,-42227774,-46720093,-55222219,-78741202,-85956859,-66535020,-46117937,-27770713,-58407711,-78187327,-69135214,1202125,-12657006,-36736334,-5285746,1284850,13974673,6428450,-2859916,11195300,21966510,41773652,75026766,86232546,65434150,56281777,31791084,-27496239,-11755947,-38243335,-15570305,-44944537,-56626147,-35689712,-29230541,-1790980,4913883,30309378,35999451,4247731,19877599,30464878,23724438,22283982,54499416,24386456,49397482,20056046,2245136,10370839,11303423,-17409033,-42771071,-74956837,-48166691,-43816115,-57542384,-70157229,-70862427,30408652,58898077,77293926,73729762,95277184,81563941,57283977,-771117,-456441,-29488849,22679627,5899338,-18076694,-37016795,-11679478,-41387957,-66065963,-88627508,-59231050,-72154351,-87239154,-98183118,-86163605,-100655815,-71105015,-71941883,-79022844,-95476326,-106781948,-122827571,-3991744,-12632889,-27237421,-19346941,-5049031,25932613,27025347,58034895,43432663,12227336,8100095,-24316081,-26074118,1861244,10308239,-14252133,-42882738,-11297680,-4134810,4642524,-2106749,4520659,4934233,-11147022,-19198158,-2631779,-7452327,10453095,2109765,-2103352,-13046685,5993258,-6044315,-8865526,-36469279,-34399945,-33492684,-66014105,-74152720,-100291068,-74237210,-51603820,-42707028,-25514375,-19566946,-28671426,-45101886,-57481104,-39262753,-53578037,-75105802,-8050453,-27079364,-31976388,-59853991,-76305099,-80118582,-75523310,-53358835,-33059777,23735157,-1173436,28637604,45579674,38153401,33484359,6520549,-19987615,-17046612,-49115976,-67297686,-76330959,-92100052,-78367933,-49573941,-47282497,-45204417,-26379619,-54724537,-31225313,-47054807,-31957234,-31249236,-45845237,-22124907,10320350,14739088,-4252207,-7762331,7155734,29164118,9070424,5290023,22450707,17614712,35173605,15421806,21377612,-11164562,-19598904,-6382529,-10075749,-31582043,-24288750,-17233764,-46634709,-51009691,-37586000,-22709095,-15330330,-41238844,-38766663,-55248088,-35014428,-8943742,5195603,18754494,8744144,17178020,48895778,81969511,58113659]++test6 :: Acc (Vector Int64)+test6 = A.scanl1Seg (+) xs seg+  where+    xs :: Acc (Vector Int64)+    xs = use $ fromList (Z :. 748) [9125498,-25188533,16012055,-27188381,-1098285,-9371024,16587421,9904131,-2631554,-25486177,-7372642,-19824453,23520582,-9676480,-22827761,21856494,-4252137,811931,-14569802,32295175,-6771023,4950290,10722774,-6642889,-19841488,17490820,-2179605,-14086104,-27317700,17646422,15786966,28131812,-27600239,-2158886,1661370,-13322321,-25071977,-6024173,7979223,24604554,2795948,21021796,251585,7369081,10359873,20938516,-11754577,4154549,13858418,-16470594,-30623198,14368006,-20234551,-21782682,26398797,29468760,-6357516,-28827783,26613691,33184238,11901012,13008860,-31538717,-19848243,-33437553,-15016152,-28808214,-13454175,-3620504,-22813060,-32105619,26699703,30531184,-30639665,-7614257,12584983,12529381,-32974667,9227307,21313790,-15949871,17768624,20661075,21149801,9467092,20131268,-13238503,-7333992,11550847,-14444961,-1554452,-14551511,29776267,-16129436,1682633,404444,22617295,30453613,-7448527,-26556359,20227806,-17105891,8650300,-32089833,9323991,12716556,29904839,-29688622,-15919895,-22187055,29421292,1756578,-29257767,4599127,-26070729,-1671158,20652563,-23527198,2288900,11460180,-14885176,26406877,-10910169,26499206,11553105,722043,-17053384,9592179,13249704,-33183411,30403929,3093390,23502571,19192793,2362514,9775133,25937315,13936777,-11730015,-22764073,-15985739,-17273984,-33325576,-30914387,-8770808,31342042,-15747727,7932556,-4620155,-19279309,8776959,12610912,2754980,-3741772,-28100827,13605576,4019354,-25589491,-14641600,-15433270,32391571,-7596012,22317722,22704901,26506216,-26312309,-9162966,11604290,-8442151,-4092963,28768938,23927146,24875049,-16309257,9075873,-18692347,10011195,-21920300,26134427,32912593,-5551781,1882153,-27121444,16950372,-1126688,21119013,1695500,26547990,28957529,-15558430,-13972154,13409965,-26432497,-29889150,18070897,25688131,-27246718,-12397916,31336388,-17039661,11331144,-1995034,3636131,21890924,6108959,-7982438,12869656,-32185347,5204385,-8020711,-23164,-32414160,-707095,21354265,13932741,-15164925,19143311,-8293114,-31029958,-32739608,-7954781,13413352,-14822391,27937201,-12559440,2619156,-16811005,20329993,1247919,-9418943,605247,26091076,-12040244,28952393,-327612,15906335,-5559634,7578213,12199450,-8777520,25700504,-29481382,-21108742,-9296576,-12346996,-6897335,-29291467,10790824,-10235479,-32607689,-16386711,14089027,7472258,17067878,3035231,21981730,7925723,4975340,47183,21493034,4597970,24115430,30425668,-15899571,-28691157,-20252003,25254077,21582669,-701106,31032696,404098,-10641332,-20092885,-10083697,-22533029,28148874,31332821,-17780122,-29634677,2407026,4386849,26726474,-14784724,-23500235,24637825,1034025,-18400464,-15771498,-21415520,31153026,28106661,17196904,25356773,22224278,-2521944,-13991250,18261104,-7891840,32877134,25183256,-28548624,17238240,1948270,-5354424,13706292,24787710,-14069075,11547549,-29486368,-112352,30046527,28613302,-29290526,7396173,14467069,13831148,-15458379,-17484499,17386854,-4744100,-16215207,-3260126,-10188139,21180895,-18726333,-17426637,-20206540,29070717,-16892228,4706892,-17022445,-7143176,-1897403,32958033,12443825,7968818,-24903117,-8873737,-21955856,-19755335,14813217,-31795499,16874316,10625172,-10685501,24577556,-10042634,55143,13866579,-21878725,-21774936,-18509235,-26990002,-64595,26203376,-27185015,-30010945,-29887344,-8145803,25884919,-21237425,-19979324,4683804,-28147527,22930815,26875527,31504260,11713918,-13843679,-24948429,32341576,29343227,25017856,-1738009,26807259,-5320054,-16438208,16542303,-27263046,18056169,25938614,-8771470,17418126,1819043,1610498,8544533,-25578215,4239601,-22488515,33171299,-33469248,830686,-13510451,23698260,7137222,23511426,-31898610,6392606,11902380,-10458154,-27102202,5829980,5677068,-32520848,24977594,26892612,-20570124,2395602,-6108597,-18300410,23755680,18192941,8766478,18513368,33249990,-19247669,28939858,-14074394,7067193,18598518,-25692451,345682,-26109041,-20303421,32025113,-3279825,-10309441,-8331897,-11867595,5157373,33121992,6997828,28892907,32918900,-24853426,12092880,13908280,20464146,33023520,12474560,14520620,-17717239,-12251575,-11301198,-32313252,32056512,2882876,-10183276,-8652210,-6601885,-14230488,17616050,29643810,-17117962,-19981454,-10597201,-13811591,-18524439,31835271,-22819146,-490013,-19389899,3339969,-25502653,23021387,-27360192,-19187634,14573150,27071200,-25708411,-33158140,30412363,5767905,-14125622,-9955587,27893368,22261048,-24570322,25629581,23227637,-18052086,11483256,-15132432,-31673232,20513290,22192233,15594061,-30355166,-23616082,6955579,-11886397,-2653730,24740075,17629659,3296152,-19928114,16478962,20181792,-33059469,-26926901,3986311,-47002,7732537,-26845035,-32088629,25005964,-30622099,31552527,33502206,14709080,20501590,1079821,-29155985,25810913,-3852267,-13527183,1330515,-3705672,-4453248,-13305577,-7617724,-14888342,-27964461,-6163629,30434146,-20856662,-17969153,-25196164,14528267,28182580,-30653575,-28567150,23567848,-4803025,-30242341,-10888079,-4584662,13289635,-4492319,-8502126,-23518983,-7215657,19421839,20417083,18347224,-30636998,-19779616,9052113,1202125,-13859131,-24079328,31450588,6570596,12689823,-7546223,-9288366,14055216,10771210,19807142,33253114,11205780,-20798396,-9152373,-24490693,-27496239,15740292,-26487388,22673030,-29374232,-11681610,20936435,6459171,27439561,6704863,25395495,5690073,-31751720,15629868,10587279,-6740440,-1440456,32215434,-30112960,25011026,-29341436,-17810910,8125703,932584,-28712456,-25362038,-32185766,26790146,4350576,-13726269,-12614845,-705198,30408652,28489425,18395849,-3564164,21547422,-13713243,-24279964,-771117,314676,-29032408,22679627,-16780289,-23976032,-18940101,25337317,-29708479,-24678006,-22561545,29396458,-12923301,-15084803,-10943964,12019513,-14492210,29550800,-836868,-7080961,-16453482,-11305622,-16045623,-3991744,-8641145,-14604532,7890480,14297910,30981644,27025347,31009548,-14602232,-31205327,-4127241,-32416176,-26074118,27935362,8446995,-24560372,-28630605,31585058,7162870,8777334,-6749273,6627408,413574,-16081255,-8051136,16566379,-4820548,17905422,-8343330,-4213117,-10943333,19039943,-12037573,-8865526,-27603753,2069334,907261,-32521421,-8138615,-26138348,26053858,22633390,8896792,17192653,5947429,-9104480,-16430460,-12379218,18218351,-14315284,-21527765,-8050453,-19028911,-4897024,-27877603,-16451108,-3813483,4595272,22164475,20299058,23735157,-24908593,29811040,16942070,-7426273,-4669042,-26963810,-26508164,2941003,-32069364,-18181710,-9033273,-15769093,13732119,28793992,2291444,2078080,18824798,-28344918,23499224,-15829494,15097573,-31249236,-14596001,23720330,32445257,4418738,-18991295,-3510124,14918065,22008384,-20093694,-3780401,17160684,-4835995,17558893,-19751799,5955806,-32542174,-8434342,13216375,-3693220,-21506294,7293293,7054986,-29400945,-4374982,13423691,14876905,7378765,-25908514,2472181,-16481425,20233660,26070686,14139345,13558891,-10010350,8433876,31717758,33073733,-23855852]++    seg :: Acc (Segments Int32)+    seg = use $ fromList (Z :. 40) [14,31,30,35,37,14,15,14,23,12,35,28,25,14,2,4,39,11,26,33,24,1,6,29,25,1,3,17,16,32,7,3,20,6,6,21,18,9,22,40]+++ref7 :: Vector Int64+ref7 = fromList (Z :. 738) [-48782707,-48069783,-76099136,-54652346,-25365627,-15287764,6356466,-12813466,-8407583,19978290,-9072659,-5915918,-36585578,-15711835,15422422,-9019547,-22292746,-32631763,-37371290,-15640610,71266024,76379806,62728369,44496969,47936553,67925416,42543207,28256825,46993513,68696441,62762548,88843983,77734052,65986283,34730508,52119715,67762330,58853279,38574549,13150417,14186593,36907720,65459740,40756535,72731638,74649918,46434954,15908233,-16539565,-31475560,-51915490,-26886587,-15628016,676507,80785577,97966741,122492495,96127350,125381692,121887919,114659417,115475678,82844858,67113463,85021319,117361113,94819908,69936468,84937047,90201353,56988036,23644741,45179661,23562116,38281224,66172480,73193812,82782863,65386382,50390098,43128359,36249064,14980469,108493316,92959780,62909215,43183526,43891523,28202405,38141961,38711587,22173107,33427444,5089227,-19895449,9446767,-9329550,15990062,27937078,10302744,-15427015,-24032122,220227,-244305648,-248544880,-216775110,-202718801,-203420228,-192771970,-167669427,-197813315,-199494672,-197082872,-207854928,-211196422,-193844772,-181103988,-181876034,-165735816,-133474822,-106956023,-82248081,-49842013,-69252000,-65369160,-46610625,-13293665,-86242428,-77700448,-54939430,-49026334,-81348375,-63863233,-81374276,-66370269,-64109103,-82546545,-101149747,-117134127,-97831968,-79075256,-93927664,-106999178,-116193016,-111355657,-142840401,-149392627,-128125153,-121344215,-116284247,-146348780,-122554770,-94499397,-65672590,-75420069,-49490678,-44521996,-49552615,-22516329,-31498419,-59429269,-30793092,-17012933,-19585098,-19894459,-11313269,17242975,26384275,20837140,-39580349,-32039154,-58779061,-31809529,-31860791,-62928294,-45073900,-71749150,-59563687,-46788878,-79384275,-68620575,-48661520,-21830363,-31430266,21524909,35884674,36972475,29674096,20377847,20983226,38258246,20827628,-14124025,-41503458,-57583707,-42613410,-71982937,-49774496,-41193192,-53347165,-62309796,-71478479,-45886895,-78704146,-59158164,-67547671,-44882655,-16244584,-38481867,-30340794,1470458,17149252,36086423,59062879,56262539,35254717,13744500,14429826,20662188,3507389,12225467,22022073,20840496,49430785,30701622,-176961463,-151524797,-172754811,-202787227,-209645388,-208244461,-196470369,-206049987,-190830353,-171109808,-139130211,-111671490,-132637043,-125735699,-106374742,-94463283,-74530374,-102363645,-88879041,-75249338,-86163630,-58293022,-71134360,-74292036,-41027036,-43611173,-45664281,-46838277,-14775189,-21989256,-215581,4895895,26505964,9881215,6006006,21791812,30399863,11059334,-15405962,-40457904,-51506444,-34718154,-12018577,6175960,31133560,-15381417,-24454448,-5290847,-23131138,-90166937,-94603634,-110598990,-102018157,-103077965,-101919562,-112451349,-79323195,-69828212,-41204487,-48476615,-16487710,-19288308,-19650316,-15196570,-14200432,14249659,26415718,-1787516,24530828,-3765711,22589689,20470588,11663379,13847971,-19004777,-8662105,-16191632,-16504147,-18339663,6010780,26824986,-263637509,-233180488,-217662025,-240293973,-229737496,-233942831,-266581338,-240283840,-221970049,-192160233,-186556300,-156510619,-157980671,-159298043,-191254443,-165340852,-181342218,-154490961,-142888991,-125613381,-105764731,-74423852,-43553208,-71733054,-38403655,-65769516,-41776811,-66580138,-58084207,-60606933,-31855509,-30976667,-60210984,-46087807,-45645362,-18703486,-11448733,-18539947,-44401293,-77378414,-104806024,-119161329,-145595331,-128577399,-102240384,-131731412,-153965054,-138203406,-136107911,-169236957,-171380864,-177805907,-154124779,-177987589,-154112100,-137736720,-122295605,-123319691,-152104867,-133462923,-163731604,-137346078,-141974369,-139229959,-115343677,-100246891,-101857581,-79635122,-58498597,-56956671,-27846111,2514723,14539638,-856211,6094147,-143939605,-114556906,-93259166,-62776322,-51886782,-49805668,-49431917,-74588752,-52582864,-69028392,-49573309,-53206133,-29967317,-15913522,-35424192,-42953149,-34525589,-22120615,-22458128,-37201856,-59870268,-63601712,-55156115,-39259547,-20561668,-13924991,-4343294,-3802313,122068251,133014364,106044038,103669137,134430169,148789334,141929442,110101523,78227591,63166498,42545018,37401662,43844352,61892182,38965269,61152447,43991599,42367631,56420014,48147227,16120995,13523168,-12973607,1166745,20340645,-8645743,69400609,62637313,33238840,5342820,17405647,4881263,10407925,-22227407,-9285528,-24279449,-31837105,-12669381,-34047179,-2711090,-26208960,2899657,-97174441,-112298451,-79439394,-84329209,-78384623,-105840777,-126752608,-110394917,-138128377,-134889126,-108654091,-114727725,-98923120,-66683703,-35041593,-51372583,-34976067,-61712406,-48730299,-26309307,-3152004,30193014,162071102,135062608,113614122,97742763,89441064,68362698,89887651,72658190,54790707,28888401,14596198,6934234,-51398793,-36048649,-64586259,-77001171,-108515514,-101660672,-120183736,-103974869,-107572971,-126104081,-97581382,-67174136,-69001306,-76561059,-48904254,-50376102,-47702115,-29837381,-44448701,-52078856,-20635428,-24924851,-35615675,-68278334,-96389847,-97000000,-80417765,-49553418,-27291772,-38508142,-30069928,-59576150,-51106683,-24593113,75962,138863600,158599246,130947464,109890205,82891951,55655298,43959461,18718460,27418095,1490441,-25173893,-41233589,-11411110,-4784998,21180595,-20092951,-19866345,-14625234,-1393509,-30003860,48038753,41278966,56150464,24427936,48510687,46956838,18206865,-14599729,-12438450,-12136742,-20552578,-34069029,-41733751,-22523991,-55669734,-46280266,-31205428,-27829333,-4518109,-37115511,-20546874,3069181,1104372,31215428,35398190,14119871,-8341624,-19741499,-6338114,7013637,-12550393,10571885,17180134,22004968,26290384,15424987,-12196414,-27805732,3893455,3705021,34303755,10858903,44234506,69653623,59799317,41855292,47636949,70210705,49577396,32263101,12862903,-3141227,8704244,-15735990,-42463538,-14281982,-34140899,-29944926,-48194015,-73380186,-53981004,-25683673,3436705,-347326,-13473324,-28337288,-6060609,-36670246,-40321076,-26406623,-25136754,-50993989,-19489063,11995210,-11523983,-31765052,-19746897,13123904,22054274,35973231,46315575,58458518,64785448,37087818,60336567,50407722,60213274,88311583,75588379,50392946,50310126,60156227,28023981,-4599077,-15670813,-480659,66326700,88952449,112560471,80424796,59167705,49073681,69439599,36559892,13608188,-10849505,-27511038,-18002566,-11679162,-14245301,-33196908,-59458637,-88762770,-76931280,-75985853,-73664670,-54646553,-73314781,-98519275,-131515581,-101578410,-70993721,-48717455,-34490455,-9721647,-33346014,-64431160,-74351523,-48527265,-47818443,-39778144,-27056813,3172756,16428504,32078563,27314822,-84911462,-70883891,-67734204,-58203952,-29560484,-7636085,-32316716,-33073244,-31465591,-19382415,-19463832,-51250364,-69332001,-43742902,-15587162,-18707052,-27391604,-8628411,-29019238,-14338164,-32687266,-34755132,-21912223,-40789415,-56697052,-30869305,8245928,22216157,-1300450,-8539733,15367658,-4898165,-23038236,-8233426,20237515,-1488029,-3344902,24899437,13240791,356287,30134185,24453047,-6857567,-11423381,8820097,40066727,55587484,72052998,100594380,76094952,61642627,29001112,9974448,42079530,9172704,-11553890,-34131793,-8675576,-36427927,-22535570,-42072165,-27144828]++test7 :: Acc (Vector Int64)+test7 = A.scanr1Seg (+) xs seg+  where+    xs :: Acc (Vector Int64)+    xs = use $ fromList (Z :. 738) [-712924,28029353,-21446790,-29286719,-10077863,-21644230,19169932,-4405883,-28385873,29050949,-3156741,30669660,-20873743,-31134257,24441969,13273199,10339017,4739527,-21730680,-15640610,-5113782,13651437,18231400,-3439584,-19988863,25382209,14286382,-18736688,-21702928,5933893,-26081435,11109931,11747769,31255775,-17389207,-15642615,8909051,20278730,25424132,-1036176,-22721127,-28552020,24703205,-31975103,-1918280,28214964,30526721,32447798,14935995,20439930,-25028903,-11258571,-16304523,676507,-17181164,-24525754,26365145,-29254342,3493773,7228502,-816261,32630820,15731395,-17907856,-32339794,22541205,24883440,-15000579,-5264306,33213317,33343295,-21534920,21617545,-14719108,-27891256,-7021332,-9589051,17396481,14996284,7261739,6879295,21268595,14980469,15533536,30050565,19725689,-707997,15689118,-9939556,-569626,16538480,-11254337,28338217,24984676,-29342216,18776317,-25319612,-11947016,17634334,25729759,8605107,-24252349,220227,4239232,-31769770,-14056309,701427,-10648258,-25102543,30143888,1681357,-2411800,10772056,3341494,-17351650,-12740784,772046,-16140218,-32260994,-26518799,-24707942,-32406068,19409987,-3882840,-18758535,-33316960,-13293665,-8541980,-22761018,-5913096,32322041,-17485142,17511043,-15004007,-2261166,18437442,18603202,15984380,-19302159,-18756712,14852408,13071514,9193838,-4837359,31484744,6552226,-21267474,-6780938,-5059968,30064533,-23794010,-28055373,-28826807,9747479,-25929391,-4968682,5030619,-27036286,8982090,-31498419,-28636177,-13780159,2572165,309361,-8581190,-28556244,-9141300,5547135,20837140,-7541195,26739907,-26969532,51262,31067503,-17854394,26675250,-12185463,-12774809,32595397,-10763700,-19959055,-26831157,9599903,-31430266,-14359765,-1087801,7298379,9296249,-605379,-17275020,17430618,20827628,27379433,16080249,-14970297,29369527,-22208441,-8581304,12153973,8962631,9168683,-25591584,32817251,-19545982,8389507,-22665016,-28638071,22237283,-8141073,-31811252,-15678794,-18937171,-22976456,2800340,21007822,21510217,-685326,-6232362,17154799,-8718078,-9796606,1181577,-28590289,18729163,30701622,-25436666,21230014,30032416,6858161,-1400927,-11774092,9579618,-15219634,-19720545,-31979597,-27458721,20965553,-6901344,-19360957,-11911459,-19932909,27833271,-13484604,-13629703,10914292,-27870608,12841338,3157676,-33265000,2584137,2053108,1173996,-32063088,7214067,-21773675,-5111476,-21610069,16624749,3875209,-15785806,21791812,19340529,26465296,25051942,11048540,-16788290,-22699577,-18194537,-24957600,31133560,9073031,-19163601,17840291,-23131138,4436697,15995356,-8580833,1059808,-1158403,10531787,-33128154,-9494983,-28623725,7272128,-31988905,2800598,362008,-4453746,-996138,-28450091,-12166059,28203234,-1787516,28296539,-26355400,2119101,8807209,-2184592,32852748,-10342672,7529527,312515,1835516,-24350443,-20814206,26824986,-30457021,-15518463,22631948,-10556477,4205335,32638507,-26297498,-18313791,-29809816,-5603933,-30045681,1470052,1317372,31956400,-25913591,16001366,-26851257,-11601970,-17275610,-19848650,-31340879,-30870644,28179846,-33329399,27365861,-23992705,24803327,-8495931,2522726,-28751424,-878842,29234317,-14123177,-442445,-26941876,-7254753,-11448733,25861346,32977121,27427610,14355305,26434002,-17017932,-26337015,29491028,22233642,-15761648,-2095495,33129046,2143907,6425043,-23681128,23862810,-23875489,-16375380,-15441115,1024086,28785176,-18641944,30268681,-26385526,4628291,-2744410,-23886282,-15096786,1610690,-22222459,-21136525,-1541926,-29110560,-30360834,-12024915,15395849,-6950358,6094147,-29382699,-21297740,-30482844,-10889540,-2081114,-373751,25156835,-22005888,16445528,-19455083,3632824,-23238816,-14053795,19510670,7528957,-8427560,-12404974,337513,14743728,22668412,3731444,-8445597,-15896568,-18697879,-20561668,-9581697,-540981,-3802313,-10946113,26970326,2374901,-30761032,-14359165,6859892,31827919,31873932,15061093,20621480,5143356,-6442690,-18047830,22926913,-22187178,17160848,1623968,-14052383,8272787,32026232,2597827,26496775,-14140352,-19173900,28986388,-8645743,6763296,29398473,27896020,-12062827,12524384,-5526662,32635332,-12941879,14993921,7557656,-19167724,21377798,-31336089,23497870,-29108617,2899657,15124010,-32859057,4889815,-5944586,27456154,20911831,-16357691,27733460,-3239251,-26235035,6073634,-15804605,-32239417,-31642110,16330990,-16396516,26736339,-12982107,-22420992,-23157303,-33345018,30193014,27008494,21448486,15871359,8301699,21078366,-21524953,17229461,17867483,25902306,14292203,7661964,6934234,-15350144,28537610,12414912,31514343,-6854842,18523064,-16208867,3598102,18531110,-28522699,-30407246,1827170,7559753,-27656805,1471848,-2673987,-17864734,14611320,7630155,-31443428,4289423,10690824,32662659,28111513,610153,-16582235,-30864347,-22261646,11216370,-8438214,29506222,-8469467,-26513570,-24669075,75962,-19735646,27651782,21057259,26998254,27236653,11695837,25241001,-8699635,25927654,26664334,16059696,-29822479,-6626112,-25965593,21180595,-226606,-5241111,-13231725,28610351,-30003860,6759787,-14871498,31722528,-24082751,1553849,28749973,32806594,-2161279,-301708,8415836,13516451,7664722,-19209760,33145743,-9389468,-15074838,-3376095,-23311224,32597402,-16568637,-23616055,1964809,-30111056,-4182762,21278319,22461495,11399875,-13403385,-13351751,19564030,-23122278,-6608249,-4824834,22004968,10865397,27621401,15609318,-31699187,188434,-30598734,23444852,-33375603,-25419117,9854306,17944025,-5781657,-22573756,20633309,17314295,19400198,16004130,-11845471,24440234,26727548,-28181556,19858917,-4195973,18249089,25186171,-19399182,-28297331,-29120378,3436705,13125998,14863964,-22276679,30609637,3650830,-13914453,-1269869,25857235,-31504926,-31484273,23519193,20241069,-12018155,-32870801,-8930370,-13918957,-10342344,-12142943,-6326930,27697630,-23248749,9928845,-9805552,-28098309,12723204,25195433,82820,-9846101,32132246,32623058,11071736,-15190154,-480659,-22625749,-23608022,32135675,21257091,10094024,-20365918,32879707,22951704,24457693,16661533,-9508472,-6323404,2566139,18951607,26261729,29304133,-11831490,-945427,-2321183,-19018117,18668228,25204494,32996306,-29937171,-30584689,-22276266,-14227000,-24768808,23624367,31085146,9920363,-25824258,-708822,-8040299,-12721331,-30229569,-13255748,-15650059,4763741,27314822,-14027571,-3149687,-9530252,-28643468,-21924399,24680631,756528,-1607653,-12083176,81417,31786532,18081637,-25589099,-28155740,3119890,8684552,-18763193,20390827,-14681074,18349102,2067866,-12842909,18877192,15907637,-25827747,-30869305,-13970229,23516607,7239283,-23907391,20265823,18140071,-23038236,-28470941,21725544,1856873,-28244339,11658646,12884504,-29777898,5681138,31310614,4565814,-20243478,-31246630,-15520757,-16465514,-28541382,24499428,14452325,32641515,19026664,-32105082,32906826,20726594,22577903,-25456217,27752351,-13892357,19536595,-14927337,-27144828]++    seg :: Acc (Segments Int32)+    seg = use $ fromList (Z :. 33) [20,34,29,20,24,33,9,15,8,33,36,9,4,19,13,37,38,25,3,26,16,22,12,35,15,5,34,29,33,40,26,7,29]+++ref8 :: Vector Int64+ref8 = fromList (Z :. 645) [0,-3770243,-5579205,-7046208,-10121610,-11747201,-13282326,-17283687,-18231759,-20046491,-21926492,-22713980,-26318076,-28006910,-31889802,-34194230,-38096679,-39693040,-35966076,-38959249,-41938765,-41994560,-41013600,-41922485,-39410829,-38960516,-35942875,-33376608,-29844503,-29318389,-28736296,-25580458,-29739876,-32401640,-36553276,-40171099,0,345952,-2993267,-5717922,-9907694,-10027890,-13870687,-11867126,-9328942,-6192885,-8184575,-11674536,-10400036,-11388719,-10353407,-8145138,-6678399,-2486811,-6487953,-8733058,-10561951,-6480166,-7972853,0,1139992,-104326,1079373,3348511,0,3395695,6337287,4100926,1022638,1452658,0,3593867,3814687,6806052,3747065,2713485,3570566,5270237,6848581,6155011,1966243,5365176,3983882,286985,2324988,721490,466546,-700995,-338083,2411347,3365002,3154319,3507792,4576100,0,-2285386,-4288389,-7082102,-4660000,-857446,721455,660475,273568,-2789646,-6674913,-9130960,-11826040,-9536699,-6104295,-9673441,-11613956,-10411885,-12286738,-8645110,-8436095,-7590486,-4452638,-1581976,0,-934927,1608397,304641,-2958108,-942792,-1396361,-3542834,0,2350876,227658,-3779069,-1035644,-972794,-3797476,-4505766,-4865910,-7425388,-7182479,-9067132,-10043764,-8627455,-4953615,-3166350,0,1298211,4883021,8143644,9991079,13383006,11704147,11985221,8647018,8086113,7664604,8718062,11039021,7936960,4598083,5635829,1450422,159881,3657858,4103183,3527017,883273,-1321504,-2478748,-1006972,455760,4266983,7194819,11232555,9833490,12524076,16207697,20249758,19286134,17160940,18352071,0,-1562519,-3710355,-2848884,0,741078,2195352,1715399,4902918,2472295,-1673954,951060,-205765,-410930,2925408,0,2661266,6376248,6698089,7240432,9214046,10362817,13102857,16942419,20040610,19554929,18142416,20333122,24002080,25936153,26861250,28286514,25107483,27772679,25952139,0,124429,3721751,0,4171155,4260049,3631576,713779,-1444554,1964929,2806146,4319313,995223,3554404,-282429,96550,1888015,3379400,3874424,5448190,8604326,7429367,4814852,0,-3835274,170581,-3872285,-4136902,-6586985,-8127633,-9740679,-10940596,-11302147,-14863360,-16636561,-15426039,-18342257,-16067741,-12830665,-14394729,-17308091,-13537763,-10075189,-6255542,-4427649,-8416077,-10456703,-8195749,-5827305,-4993142,-3673480,0,869492,1594197,4025097,2848783,0,2126507,3949710,4447981,1253204,3235070,7367011,5351006,6654097,2818742,5393616,4706372,3331207,1161359,0,1885699,1289175,-763581,2481999,2068732,6240239,9030236,6369832,3409522,1150603,-1677392,-773316,-3184156,404696,-683547,910053,-2491074,-94029,-2827691,-5512379,-7783991,-8736510,-6524861,-2725098,-5093277,-6514413,0,742604,-606571,-725780,1744947,3431452,-405237,-457263,709944,4319401,624627,-2608016,0,3642681,2908707,5512358,5530669,0,-3215609,-7345078,-8196654,-11105059,-12591552,-15198735,-11340348,-10281817,-12147811,-10530601,-11500997,-7477780,-10439606,-9986548,0,3533811,4486946,5531887,1511249,-557775,435067,1631130,1815263,-1867113,2273415,1514738,-1206877,555832,741913,-3166709,-287429,-4411008,-4700935,-3946601,-4617892,-7550664,-6112017,0,-667061,-1239970,1156892,-722075,-4186731,-7404810,-11407733,-13636105,-12949852,-11213787,-11386775,-15541235,-18076969,-21589829,-19336525,-21546880,-20418698,-24006743,-23003415,-19580602,-16414098,-17729103,-17560035,-21218247,0,-781526,1156089,-2142153,-419575,-3055657,-716334,-2312034,118635,711944,4112840,7878285,7762706,8255775,8380414,11299416,12714032,15289946,14300365,15027849,19200256,22844171,0,-1224713,1837521,62083,-2435081,-280845,3789736,4259660,7108468,3611361,1501427,4453169,6217988,9274431,13178646,16388059,15410829,13060952,14279789,17319316,14533179,13976967,9836157,7001049,5716786,5459256,5101104,7249617,8962409,9911065,7505371,7218925,8578944,5307366,0,859492,-3077001,-4576770,-8344542,-8263692,-9244057,-8761336,-10520101,-11364186,-10078629,-11263983,-11008053,-14512411,-14775947,-16672625,-14513613,0,694423,-1173637,-2704935,1260688,4786656,1709582,-249261,-2458089,-4733195,-3473620,-3843053,-150511,-4048267,-6698308,-2513431,-6005597,-4249435,-4821144,-8932215,-8692409,-4892474,-3015738,-914415,773709,4562402,8689641,8298796,12102005,13700416,12590982,9153649,7960537,6137906,4292150,2600272,-1457822,0,-1806374,1041907,-2078323,-842307,-3701664,0,-2626906,-2068475,1803835,-316068,-1526877,-3914878,-1840677,-2474665,-4520977,-6059889,0,-161266,2625449,4235821,4877373,1374740,118771,2880196,4463038,3245456,6984711,3642280,2229177,3494184,3387547,5293512,1401776,4539065,6886384,11057250,14889641,15259441,13231998,10138107,7266168,8228888,5129351,1841256,1082772,724230,-2146010,-859151,1049573,2686216,-1006176,1740846,0,-2567334,487038,-3421145,-4411824,-6418173,-4404660,0,2828945,6815455,7060886,6549094,9292080,13211354,12694643,14924363,12485234,14542169,14311383,16026086,17059251,18866314,15263353,18915246,20747408,20628390,21408706,20042728,24104321,21412324,24779975,23077325,20881558,22407427,20391992,21407566,19978783,0,1589469,-794608,-1541980,-1274750,-1931789,-3719881,-175562,1353495,3729793,4102597,330109,-90750,2740945,4316009,2734066,4093765,656207,-844822,-3930596,-1093202,-2998732,564186,3880070,5179086,6959784,10449214,14577355,13359512,0,1964984,3384303,1505373,3694802,6588743,0,1412262,5040779,5239461,9430965,6115620,10111491,10560650,8218897,4044049,4210501,1038630,1711549,0,-3317531,-4953062,-1809142,-1092410,-3951290,-7965161]++test8 :: Acc (Vector Int64)+test8 = A.scanlSeg (+) 0 xs seg+  where+    xs :: Acc (Vector Int64)+    xs = use $ fromList (Z :. 609) [-3770243,-1808962,-1467003,-3075402,-1625591,-1535125,-4001361,-948072,-1814732,-1880001,-787488,-3604096,-1688834,-3882892,-2304428,-3902449,-1596361,3726964,-2993173,-2979516,-55795,980960,-908885,2511656,450313,3017641,2566267,3532105,526114,582093,3155838,-4159418,-2661764,-4151636,-3617823,345952,-3339219,-2724655,-4189772,-120196,-3842797,2003561,2538184,3136057,-1991690,-3489961,1274500,-988683,1035312,2208269,1466739,4191588,-4001142,-2245105,-1828893,4081785,-1492687,1139992,-1244318,1183699,2269138,3395695,2941592,-2236361,-3078288,430020,3593867,220820,2991365,-3058987,-1033580,857081,1699671,1578344,-693570,-4188768,3398933,-1381294,-3696897,2038003,-1603498,-254944,-1167541,362912,2749430,953655,-210683,353473,1068308,-2285386,-2003003,-2793713,2422102,3802554,1578901,-60980,-386907,-3063214,-3885267,-2456047,-2695080,2289341,3432404,-3569146,-1940515,1202071,-1874853,3641628,209015,845609,3137848,2870662,-934927,2543324,-1303756,-3262749,2015316,-453569,-2146473,2350876,-2123218,-4006727,2743425,62850,-2824682,-708290,-360144,-2559478,242909,-1884653,-976632,1416309,3673840,1787265,1298211,3584810,3260623,1847435,3391927,-1678859,281074,-3338203,-560905,-421509,1053458,2320959,-3102061,-3338877,1037746,-4185407,-1290541,3497977,445325,-576166,-2643744,-2204777,-1157244,1471776,1462732,3811223,2927836,4037736,-1399065,2690586,3683621,4042061,-963624,-2125194,1191131,-1562519,-2147836,861471,741078,1454274,-479953,3187519,-2430623,-4146249,2625014,-1156825,-205165,3336338,2661266,3714982,321841,542343,1973614,1148771,2740040,3839562,3098191,-485681,-1412513,2190706,3668958,1934073,925097,1425264,-3179031,2665196,-1820540,124429,3597322,4171155,88894,-628473,-2917797,-2158333,3409483,841217,1513167,-3324090,2559181,-3836833,378979,1791465,1491385,495024,1573766,3156136,-1174959,-2614515,-3835274,4005855,-4042866,-264617,-2450083,-1540648,-1613046,-1199917,-361551,-3561213,-1773201,1210522,-2916218,2274516,3237076,-1564064,-2913362,3770328,3462574,3819647,1827893,-3988428,-2040626,2260954,2368444,834163,1319662,869492,724705,2430900,-1176314,2126507,1823203,498271,-3194777,1981866,4131941,-2016005,1303091,-3835355,2574874,-687244,-1375165,-2169848,1885699,-596524,-2052756,3245580,-413267,4171507,2789997,-2660404,-2960310,-2258919,-2827995,904076,-2410840,3588852,-1088243,1593600,-3401127,2397045,-2733662,-2684688,-2271612,-952519,2211649,3799763,-2368179,-1421136,742604,-1349175,-119209,2470727,1686505,-3836689,-52026,1167207,3609457,-3694774,-3232643,3642681,-733974,2603651,18311,-3215609,-4129469,-851576,-2908405,-1486493,-2607183,3858387,1058531,-1865994,1617210,-970396,4023217,-2961826,453058,3533811,953135,1044941,-4020638,-2069024,992842,1196063,184133,-3682376,4140528,-758677,-2721615,1762709,186081,-3908622,2879280,-4123579,-289927,754334,-671291,-2932772,1438647,-667061,-572909,2396862,-1878967,-3464656,-3218079,-4002923,-2228372,686253,1736065,-172988,-4154460,-2535734,-3512860,2253304,-2210355,1128182,-3588045,1003328,3422813,3166504,-1315005,169068,-3658212,-781526,1937615,-3298242,1722578,-2636082,2339323,-1595700,2430669,593309,3400896,3765445,-115579,493069,124639,2919002,1414616,2575914,-989581,727484,4172407,3643915,-1224713,3062234,-1775438,-2497164,2154236,4070581,469924,2848808,-3497107,-2109934,2951742,1764819,3056443,3904215,3209413,-977230,-2349877,1218837,3039527,-2786137,-556212,-4140810,-2835108,-1284263,-257530,-358152,2148513,1712792,948656,-2405694,-286446,1360019,-3271578,859492,-3936493,-1499769,-3767772,80850,-980365,482721,-1758765,-844085,1285557,-1185354,255930,-3504358,-263536,-1896678,2159012,694423,-1868060,-1531298,3965623,3525968,-3077074,-1958843,-2208828,-2275106,1259575,-369433,3692542,-3897756,-2650041,4184877,-3492166,1756162,-571709,-4111071,239806,3799935,1876736,2101323,1688124,3788693,4127239,-390845,3803209,1598411,-1109434,-3437333,-1193112,-1822631,-1845756,-1691878,-4058094,-1806374,2848281,-3120230,1236016,-2859357,-2626906,558431,3872310,-2119903,-1210809,-2388001,2074201,-633988,-2046312,-1538912,-161266,2786715,1610372,641552,-3502633,-1255969,2761425,1582842,-1217582,3739255,-3342431,-1413103,1265007,-106637,1905965,-3891736,3137289,2347319,4170866,3832391,369800,-2027443,-3093891,-2871939,962720,-3099537,-3288095,-758484,-358542,-2870240,1286859,1908724,1636643,-3692392,2747022,-2567334,3054372,-3908183,-990679,-2006349,2013513,2828945,3986510,245431,-511792,2742986,3919274,-516711,2229720,-2439129,2056935,-230786,1714703,1033165,1807063,-3602961,3651893,1832162,-119018,780316,-1365978,4061593,-2691997,3367651,-1702650,-2195767,1525869,-2015435,1015574,-1428783,1589469,-2384077,-747372,267230,-657039,-1788092,3544319,1529057,2376298,372804,-3772488,-420859,2831695,1575064,-1581943,1359699,-3437558,-1501029,-3085774,2837394,-1905530,3562918,3315884,1299016,1780698,3489430,4128141,-1217843,1964984,1419319,-1878930,2189429,2893941,1412262,3628517,198682,4191504,-3315345,3995871,449159,-2341753,-4174848,166452,-3171871,672919,-3317531,-1635531,3143920,716732,-2858880,-4013871]++    seg :: Acc (Segments Int32)+    seg = use $ fromList (Z :. 36) [35,22,4,5,23,23,7,15,35,3,10,19,2,19,27,4,13,26,11,4,14,22,24,21,33,16,36,5,10,35,6,29,28,5,12,6]+++ref9 :: Vector Int64+ref9 = fromList (Z :. 661) [-23545410,-19092190,-15199726,-12351144,-19787110,-24907783,-28924702,-22582323,-15004292,-7986712,-15814964,-12796809,-20874665,-23199295,-21814743,-14474247,-11428070,-11326540,-11987400,-14049880,-15904429,-16813716,-20127269,-27880670,-27115572,-22970078,-19161294,-20116738,-25696300,-20399870,-12598014,-4441841,-5339204,0,5258152,-3047807,-4983198,-152087,-6694074,-2774154,3094062,8979166,16074241,10127078,17254868,10052255,14618407,7297758,13556880,7757925,4862968,0,7035358,13265906,15886283,9773585,17111824,11482952,10360509,16178260,11573685,8057435,8957179,1861100,-4510903,2522742,-1952534,343602,-931257,1182026,8572670,9866510,5314905,0,9915533,6504277,14881592,17126294,9902843,9461226,11857883,12119033,7534110,13764697,17029680,12738298,10093900,9378149,1497597,4121921,6980765,5509560,13297927,19208174,13439826,9261637,3697126,1029090,5742435,7165092,9870407,4667463,9603255,3143595,0,19520337,24293005,18170289,16949209,24484583,25098797,16940571,17168669,20017902,18512677,17276624,20668621,23764749,18559293,19179431,13603545,6821021,4128258,5178140,1807923,625766,-5793038,557951,8468013,16821699,9014973,10154282,13712629,15418321,17772979,13187310,9341891,9346469,3562777,-4236026,3943064,1821268,0,-17597987,-14338111,-13160839,-21095607,-13659930,-5524189,-447843,3198401,-3906944,2444625,4930508,0,-1780995,4941517,3428221,6945832,5471438,-2089694,-1840520,-748417,-622281,-4266815,-3578951,4175923,1214444,-6157294,-11771424,-4253316,122413,-5115729,-2403737,-2280632,-7692875,-7176319,165603,-4608911,2275343,4121415,3691356,8960495,8220951,6560764,3361772,122451,2068485,2266879,0,-23261891,-21773982,-18640394,-16250482,-8288981,-14366391,-12019056,-4951591,0,10327511,16096523,11513457,3775062,1456323,950660,0,39500473,42134191,49326132,44908043,44189915,40545597,42583889,36771665,37976838,42637161,43042497,41877155,36320177,36033649,30456233,23955666,24578825,25647024,25212428,22072107,15320240,7407492,5131363,10409387,17711966,18345108,25613171,20134088,18672784,20466069,19103089,11665491,5005634,2753606,2758578,0,-23237696,-29354162,-28222112,-22820572,-18856465,-11451199,-6544145,-13678867,-15169991,-16665935,-8801766,-16956831,-22118443,-14855674,-19710134,-18333052,-12310671,-12903337,-8724596,-6190610,-12330615,-6733634,-2371106,277264,-6820245,0,9171599,16241475,9734750,11053683,4530017,-3696390,3735716,11641789,12422324,8541343,10317301,6602275,6515789,1853520,2351453,6520804,8199852,16513029,15956233,17535751,12479352,11996485,11488976,15956849,19335984,20273115,14309339,8502747,5054202,4792421,-1998961,6344690,0,8641635,14614220,22621519,24778420,22934500,30033834,31388539,31358268,35741081,35363404,28488749,35704092,39869443,33641031,41683686,43114143,37049122,42162389,38581957,30630741,33093671,29883603,26722722,28918564,23162080,17010863,15643511,8259148,0,67812641,73385203,68588801,71302771,70440392,68339659,72121169,71757257,71620440,66640453,59362044,56439252,50169030,50545377,46897589,42431129,34191912,25809204,22184527,16142939,18006336,15320689,8056937,4727494,4455178,4714354,-2929312,3315582,-712782,0,-10533559,-7453596,-7355822,-11184899,-5346034,-5517666,-5655507,-13233681,-11036355,-15169542,-11673998,-13330134,-12975730,-15731486,-23927365,-15672527,-7651033,-41473,5213372,8569093,5202320,-1932697,4629347,7838047,-310810,-1472760,-1483648,-7832330,-10302351,-7461765,0,56489872,57285707,49989598,56584906,62675766,58030500,53272676,57170277,51364588,45405741,41313157,33038217,27969264,30537052,29338965,24226308,21920794,18781965,16276111,17831599,19945279,12010786,11775519,15528815,8084160,6735740,1256501,0,-4316639,-649184,-2875249,-1265836,-8062475,-1039628,-4165745,2818361,3338123,3984362,-2416008,1539566,1949311,7282131,1416000,2812559,4846439,-1681841,0,17517431,20918622,15129697,12644787,9788494,4980177,4751268,5168036,12807316,6885561,0,-12911606,-7044558,-4259336,-1778572,3942903,-99590,-1755397,1187146,-5227554,-2697658,-5743694,-9164574,-17324325,-9573146,-9518972,-7544657,-3459738,4724166,-2766402,0,-28888665,-23766795,-17908909,-23193011,-18768818,-18321941,-12120774,-4097683,3882582,11680259,16891026,8958627,9777882,4023025,0,-28142843,-31706317,-23725731,-17057441,-23215793,-22411703,-21651678,-16896450,-9881916,-14102625,-16892825,-11726368,-6761066,-8913778,-8706274,-16789108,-15505593,-17559207,-10278334,-2276389,2567755,8618151,12914239,11325856,6127225,622598,8390786,12165621,9912453,4123344,214225,-3540061,-3451397,0,22049876,24841111,19336800,18657023,17237080,16187600,12259897,11391983,6247808,12737198,14285951,16115720,7891953,5229659,12852009,14056688,10927973,15415445,15884318,9189272,15118784,14926893,16328727,24176496,21498476,13130655,9949458,7428893,4075586,2266204,2732845,0,-5712816,-5352191,521344,-2229408,265697,7718151,0,10535066,8408094,12259060,5061913,7346875,12522051,9215406,7737787,3313157,9824900,8315680,14840204,13742226,6034361,12850753,5702446,-584149,-132181,5582800,12810567,7762879,5801224,3571657,2874166,0,-24212535,-26325437,-21693913,-14975748,-19464741,-17568114,-22144287,-26451701,-24659593,-27491447,-34368798,-33273519,-31645836,-27659172,-19824103,-17292768,-17232842,-21445918,-17409995,-11585791,-18676054,-13722054,-6234778,0,-26835027,-26837945,-31679362,-27828204,-24983789,-27977465,-22748208,-18058978,-9787299,-2368565,4785532,-149793,-1166138,-1765051,6274501,-215131,2298449,-4372183,-5668260,-4416255,570850,-3446772,2138867,-3249857,3212736,5020102,6795919,0,-22301653,-17085039,-17386088,-12674648,-7197062,-4438712,2099952,6419507,10331533,18614405,16136985,16786718,17272339,12394596,15925356,21566888,14364344,8727743,12639637,16706011,14337230,9800607,6454097,8805762,2901622,2003370,0]++test9 :: Acc (Vector Int64)+test9 = A.scanrSeg (+) 0 xs seg+  where+    xs :: Acc (Vector Int64)+    xs = use $ fromList (Z :. 634) [-4453220,-3892464,-2848582,7435966,5120673,4016919,-6342379,-7578031,-7017580,7828252,-3018155,8077856,2324630,-1384552,-7340496,-3046177,-101530,660860,2062480,1854549,909287,3313553,7753401,-765098,-4145494,-3808784,955444,5579562,-5296430,-7801856,-8156173,897363,-5339204,8305959,1935391,-4831111,6541987,-3919920,-5868216,-5885104,-7095075,5947163,-7127790,7202613,-4566152,7320649,-6259122,5798955,2894957,4862968,-6230548,-2620377,6112698,-7338239,5628872,1122443,-5817751,4604575,3516250,-899744,7096079,6372003,-7033645,4475276,-2296136,1274859,-2113283,-7390644,-1293840,4551605,5314905,3411256,-8377315,-2244702,7223451,441617,-2396657,-261150,4584923,-6230587,-3264983,4291382,2644398,715751,7880552,-2624324,-2858844,1471205,-7788367,-5910247,5768348,4178189,5564511,2668036,-4713345,-1422657,-2705315,5202944,-4935792,6459660,3143595,-4772668,6122716,1221080,-7535374,-614214,8158226,-228098,-2849233,1505225,1236053,-3391997,-3096128,5205456,-620138,5575886,6782524,2692763,-1049882,3370217,1182157,6418804,-6350989,-7910062,-8353686,7806726,-1139309,-3558347,-1705692,-2354658,4585669,3845419,-4578,5783692,7798803,-8179090,2121796,1821268,-3259876,-1177272,7934768,-7435677,-8135741,-5076346,-3646244,7105345,-6351569,-2485883,4930508,-6722512,1513296,-3517611,1474394,7561132,-249174,-1092103,-126136,3644534,-687864,-7754874,2961479,7371738,5614130,-7518108,-4375729,5238142,-2711992,-123105,5412243,-516556,-7341922,4774514,-6884254,-1846072,430059,-5269139,739544,1660187,3198992,3239321,-1946034,-198394,2266879,-1487909,-3133588,-2389912,-7961501,6077410,-2347335,-7067465,-4951591,-5769012,4583066,7738395,2318739,505663,950660,-2633718,-7191941,4418089,718128,3644318,-2038292,5812224,-1205173,-4660323,-405336,1165342,5556978,286528,5577416,6500567,-623159,-1068199,434596,3140321,6751867,7912748,2276129,-5278024,-7302579,-633142,-7268063,5479083,1461304,-1793285,1362980,7437598,6659857,2252028,-4972,2758578,6116466,-1132050,-5401540,-3964107,-7405266,-4907054,7134722,1491124,1495944,-7864169,8155065,5161612,-7262769,4854460,-1377082,-6022381,592666,-4178741,-2533986,6140005,-5596981,-4362528,-2648370,7097509,-6820245,-7069876,6506725,-1318933,6523666,8226407,-7432106,-7906073,-780535,3880981,-1775958,3715026,86486,4662269,-497933,-4169351,-1679048,-8313177,556796,-1579518,5056399,482867,507509,-4467873,-3379135,-937131,5963776,5806592,3448545,261781,6791382,-8343651,6344690,-5972585,-8007299,-2156901,1843920,-7099334,-1354705,30271,-4382813,377677,6874655,-7215343,-4165351,6228412,-8042655,-1430457,6065021,-5113267,3580432,7951216,-2462930,3210068,3160881,-2195842,5756484,6151217,1367352,7384363,8259148,-5572562,4796402,-2713970,862379,2100733,-3781510,363912,136817,4979987,7278409,2922792,6270222,-376347,3647788,4466460,8239217,8382708,3624677,6041588,-1863397,2685647,7263752,3329443,272316,-259176,7643666,-6244894,4028364,-712782,-3079963,-97774,3829077,-5838865,171632,137841,7578174,-2197326,4133187,-3495544,1656136,-354404,2755756,8195879,-8254838,-8021494,-7609560,-5254845,-3355721,3366773,7135017,-6562044,-3208700,8148857,1161950,10888,6348682,2470021,-2840586,-7461765,-795835,7296109,-6595308,-6090860,4645266,4757824,-3897601,5805689,5958847,4092584,8274940,5068953,-2567788,1198087,5112657,2305514,3138829,2505854,-1555488,-2113680,7934493,235267,-3753296,7444655,1348420,5479239,1256501,-3667455,2226065,-1609413,6796639,-7022847,3126117,-6984106,-519762,-646239,6400370,-3955574,-409745,-5332820,5866131,-1396559,-2033880,6528280,-1681841,-3401191,5788925,2484910,2856293,4808317,228909,-416768,-7639280,5921755,6885561,-5867048,-2785222,-2480764,-5721475,4042493,1655807,-2942543,6414700,-2529896,3046036,3420880,8159751,-7751179,-54174,-1974315,-4084919,-8183904,7490568,-2766402,-5121870,-5857886,5284102,-4424193,-446877,-6201167,-8023091,-7980265,-7797677,-5210767,7932399,-819255,5754857,4023025,3563474,-7980586,-6668290,6158352,-804090,-760025,-4755228,-7014534,4220709,2790200,-5166457,-4965302,2152712,-207504,8082834,-1283515,2053614,-7280873,-8001945,-4844144,-6050396,-4296088,1588383,5198631,5504627,-7768188,-3774835,2253168,5789109,3909119,3754286,-88664,-3451397,-2791235,5504311,679777,1419943,1049480,3927703,867914,5144175,-6489390,-1548753,-1829769,8223767,2662294,-7622350,-1204679,3128715,-4487472,-468873,6695046,-5929512,191891,-1401834,-7847769,2678020,8367821,3181197,2520565,3353307,1809382,-466641,2732845,-360625,-5873535,2750752,-2495105,-7452454,7718151,2126972,-3850966,7197147,-2284962,-5175176,3306645,1477619,4424630,-6511743,1509220,-6524524,1097978,7707865,-6816392,7148307,6286595,-451968,-5714981,-7227767,5047688,1961655,2229567,697491,2874166,2112902,-4631524,-6718165,4488993,-1896627,4576173,4307414,-1792108,2831854,6877351,-1095279,-1627683,-3986664,-7835069,-2531335,-59926,4213076,-4035923,-5824204,7090263,-4954000,-7487276,-6234778,2918,4841417,-3851158,-2844415,2993676,-5229257,-4689230,-8271679,-7418734,-7154097,4935325,1016345,598913,-8039552,6489632,-2513580,6670632,1296077,-1252005,-4987105,4017622,-5585639,5388724,-6462593,-1807366,-1775817,6795919,-5216614,301049,-4711440,-5477586,-2758350,-6538664,-4319555,-3912026,-8282872,2477420,-649733,-485621,4877743,-3530760,-5641532,7202544,5636601,-3911894,-4066374,2368781,4536623,3346510,-2351665,5904140,898252,2003370]++    seg :: Acc (Segments Int32)+    seg = use $ fromList (Z :. 27) [33,17,21,30,37,11,34,8,6,35,25,32,28,29,30,27,18,10,19,14,33,31,6,24,23,27,26]+++ref10 :: (Vector Int64, Vector Int64)+ref10 = (ps, rs)+  where+    ps = fromList (Z :. 569) [0,-66818,0,251795,699710,802697,480274,853290,752860,1138919,862260,939763,894697,1099711,1557688,1971825,2058686,2243003,2277978,1888289,1704690,1494021,1883285,2376628,2742325,2967694,0,-332732,-837801,-1190081,-1155758,-864618,-1011546,-1506561,-1455653,-1461081,-1468925,0,-17398,-499085,-748440,-252548,-711966,-497932,-195879,220930,-206548,-255380,-568898,-757326,-427050,-393296,-111710,-602208,-649037,-444294,-18070,-10846,275102,386815,-81884,-314019,-787111,-444473,-623219,-786284,-1224148,-948653,0,83288,141789,-376897,-801010,-1229392,-1437542,-1343774,-1252581,-1407581,-1230786,-1080778,-887420,-1407282,-1684415,-1586879,-1817380,-1644980,-2018396,-1578302,-2078661,-2403312,0,-348073,-61579,-410265,-889716,-590911,-305754,14324,90455,238709,0,-514467,-18980,-246615,-269435,47130,486843,133713,-235497,231266,18100,49540,309653,128285,358799,71567,-82550,-153304,220347,510910,469921,274902,621062,1078829,872577,737543,784276,1024881,903770,582412,557177,0,-79157,156274,608119,229318,288224,717375,977407,469445,324953,457611,641493,880116,360122,700100,821083,939413,1353849,1301020,1159702,1066315,1313991,1759726,0,64229,71186,-445530,-895389,-788935,-1273825,-1752166,-1318004,-925613,-1174396,-723669,-699056,-956311,-472962,-854802,-631555,-568744,-121748,262164,315678,286142,516418,774854,802149,0,242513,-78471,-447748,-208334,80367,353728,395938,349793,843076,665615,217631,152661,369532,391974,528953,54121,-213080,0,-379824,-596797,-930399,-1233561,0,49961,470555,-8966,-421041,-358131,-522150,-438106,-257326,-388186,-349745,-150297,-321019,196862,-303784,-753841,-673582,0,-214043,-451282,-817091,-960814,-680287,-213731,-513040,-214838,188079,567961,716777,411753,456206,168684,5973,275529,253742,173181,179486,571390,660839,1011720,1004275,736990,0,486399,121062,152334,-63078,263827,149145,660440,499071,805451,578235,959506,1402219,1313257,873908,1270627,845536,422653,125870,-131875,40533,-20688,217854,732938,722699,1196205,735699,266278,419403,821116,925710,0,370129,684573,735026,1258789,911909,583991,400539,247903,534707,541244,391465,0,-59023,-409311,-21312,-433939,-148438,-668644,-386892,-631301,-1038008,-574634,-1058043,0,265219,578285,758977,1231768,805524,487154,300489,389030,-120499,311989,-44810,-112116,-251032,-86539,-435986,-866365,-443801,-14900,309866,444678,-26681,324055,68761,544046,622794,0,74157,-317149,23825,481577,562395,875574,840706,1160287,1619936,1498032,1475610,1164467,949769,1280500,1015376,1063969,905518,615928,0,-87002,-594303,-548189,-192022,-133977,74580,549869,205817,162377,410494,90138,597008,664846,830524,377126,735741,778767,353906,382320,613333,979868,770860,604628,887587,1280914,956452,1320009,1428155,1055994,0,168619,-88538,-351560,109200,531151,46281,-461996,-305458,-431157,-351578,-445572,-193773,222034,454655,416443,229141,16838,482113,458503,-36529,37212,336796,-124876,-247953,-568505,-351627,0,174429,326398,0,479713,860680,1036211,514896,729323,669741,578086,375592,810904,1314492,0,516330,592423,921726,929593,1045808,747506,626620,597816,458291,216687,699340,216117,-132060,-312354,-2136,-520935,-569805,-970137,-1267749,-880767,-1038096,0,118085,-218891,-76411,-133008,70809,-229674,61482,463032,157647,74287,65534,406373,241452,697069,1054306,708766,949749,1455240,1211918,1300078,1171212,1214004,1127868,1159521,0,183087,153680,15177,-116973,21188,233956,-64713,-354746,-877965,-1342227,-1529732,-1008952,-1394152,-1765713,-1975211,0,-481619,-382778,78075,191489,507177,333103,613687,506194,597264,96635,-69800,-337325,-620875,-885881,-521276,-776467,-401089,-240095,-174539,-655262,-662689,-309418,-543461,-287504,-502363,-425626,-135632,-634977,-125686,0,-406528,-758206,-879047,-365289,-104346,-472971,-535915,-48760,328278,251722,321627,-127699,-192224,248204,-32639,-104266,-265995,207560,-284650,-231682,0,-61639,-279193,-294943,-445218,-331468,-365358,141884,-55123,-528518,-56843,-482234,-590206,-389883,-77870,42781,466913,753792,0,154707,337717,186947,-17501,-222052,-205272,247871,705,307861,459828,791604,945119,1286260,934495,425248,514350,276711,257592,748516,730039,673631]+    rs = fromList (Z :. 30)  [215752,2738275,-1800525,-1372798,-2118027,296082,207526,2063381,312429,-190965,-907082,-914710,442481,1282782,716990,-1224980,1060351,109154,849522,130337,247166,1435364,-1200037,1292937,-2157594,-649389,-498810,970579,243783,0]++test10 :: Acc (Vector Int64, Vector Int64)+test10 = A.scanl'Seg (+) 0 xs seg+  where+    xs :: Acc (Vector Int64)+    xs = use $ fromList (Z :. 569) [-66818,282570,251795,447915,102987,-322423,373016,-100430,386059,-276659,77503,-45066,205014,457977,414137,86861,184317,34975,-389689,-183599,-210669,389264,493343,365697,225369,-229419,-332732,-505069,-352280,34323,291140,-146928,-495015,50908,-5428,-7844,-331600,-17398,-481687,-249355,495892,-459418,214034,302053,416809,-427478,-48832,-313518,-188428,330276,33754,281586,-490498,-46829,204743,426224,7224,285948,111713,-468699,-232135,-473092,342638,-178746,-163065,-437864,275495,-424145,83288,58501,-518686,-424113,-428382,-208150,93768,91193,-155000,176795,150008,193358,-519862,-277133,97536,-230501,172400,-373416,440094,-500359,-324651,285285,-348073,286494,-348686,-479451,298805,285157,320078,76131,148254,57373,-514467,495487,-227635,-22820,316565,439713,-353130,-369210,466763,-213166,31440,260113,-181368,230514,-287232,-154117,-70754,373651,290563,-40989,-195019,346160,457767,-206252,-135034,46733,240605,-121111,-321358,-25235,-349651,-79157,235431,451845,-378801,58906,429151,260032,-507962,-144492,132658,183882,238623,-519994,339978,120983,118330,414436,-52829,-141318,-93387,247676,445735,303655,64229,6957,-516716,-449859,106454,-484890,-478341,434162,392391,-248783,450727,24613,-257255,483349,-381840,223247,62811,446996,383912,53514,-29536,230276,258436,27295,-489720,242513,-320984,-369277,239414,288701,273361,42210,-46145,493283,-177461,-447984,-64970,216871,22442,136979,-474832,-267201,22115,-379824,-216973,-333602,-303162,326479,49961,420594,-479521,-412075,62910,-164019,84044,180780,-130860,38441,199448,-170722,517881,-500646,-450057,80259,-241128,-214043,-237239,-365809,-143723,280527,466556,-299309,298202,402917,379882,148816,-305024,44453,-287522,-162711,269556,-21787,-80561,6305,391904,89449,350881,-7445,-267285,-294509,486399,-365337,31272,-215412,326905,-114682,511295,-161369,306380,-227216,381271,442713,-88962,-439349,396719,-425091,-422883,-296783,-257745,172408,-61221,238542,515084,-10239,473506,-460506,-469421,153125,401713,104594,357072,370129,314444,50453,523763,-346880,-327918,-183452,-152636,286804,6537,-149779,325525,-59023,-350288,387999,-412627,285501,-520206,281752,-244409,-406707,463374,-483409,-166937,265219,313066,180692,472791,-426244,-318370,-186665,88541,-509529,432488,-356799,-67306,-138916,164493,-349447,-430379,422564,428901,324766,134812,-471359,350736,-255294,475285,78748,437557,74157,-391306,340974,457752,80818,313179,-34868,319581,459649,-121904,-22422,-311143,-214698,330731,-265124,48593,-158451,-289590,-506774,-87002,-507301,46114,356167,58045,208557,475289,-344052,-43440,248117,-320356,506870,67838,165678,-453398,358615,43026,-424861,28414,231013,366535,-209008,-166232,282959,393327,-324462,363557,108146,-372161,-206472,168619,-257157,-263022,460760,421951,-484870,-508277,156538,-125699,79579,-93994,251799,415807,232621,-38212,-187302,-212303,465275,-23610,-495032,73741,299584,-461672,-123077,-320552,216878,481964,174429,151969,-79232,479713,380967,175531,-521315,214427,-59582,-91655,-202494,435312,503588,120872,516330,76093,329303,7867,116215,-298302,-120886,-28804,-139525,-241604,482653,-483223,-348177,-180294,310218,-518799,-48870,-400332,-297612,386982,-157329,-161941,118085,-336976,142480,-56597,203817,-300483,291156,401550,-305385,-83360,-8753,340839,-164921,455617,357237,-345540,240983,505491,-243322,88160,-128866,42792,-86136,31653,133416,183087,-29407,-138503,-132150,138161,212768,-298669,-290033,-523219,-464262,-187505,520780,-385200,-371561,-209498,-182383,-481619,98841,460853,113414,315688,-174074,280584,-107493,91070,-500629,-166435,-267525,-283550,-265006,364605,-255191,375378,160994,65556,-480723,-7427,353271,-234043,255957,-214859,76737,289994,-499345,509291,-523703,-406528,-351678,-120841,513758,260943,-368625,-62944,487155,377038,-76556,69905,-449326,-64525,440428,-280843,-71627,-161729,473555,-492210,52968,-267128,-61639,-217554,-15750,-150275,113750,-33890,507242,-197007,-473395,471675,-425391,-107972,200323,312013,120651,424132,286879,216787,154707,183010,-150770,-204448,-204551,16780,453143,-247166,307156,151967,331776,153515,341141,-351765,-509247,89102,-237639,-19119,490924,-18477,-56408,-429848]++    seg :: Acc (Segments Int32)+    seg = use $ fromList (Z :. 30) [2,24,11,31,22,10,31,23,25,18,5,17,25,31,12,12,26,19,30,27,3,11,22,25,16,30,21,18,22,0]+++ref11 :: (Vector Int64, Vector Int64)+ref11 = (ps, rs)+  where+    ps = fromList (Z :. 750) [300202,-3934108,-7293301,118329,0,-9620841,-6707242,194332,33523,-2362285,4356093,8130701,7381954,6320569,13020915,19242062,20405079,12162531,9328566,2344030,6249515,1195987,714789,-3387204,-1156156,-4385845,-1505374,3054547,10517703,14551257,7158564,5521908,4076566,9423606,9791035,15883498,13341839,5338906,7755970,0,8449937,14272421,7658262,4242448,106786,-1538494,6329826,-1969224,-3562793,-5238381,-11479790,-19204769,-23383409,-15529258,-9197176,-3153045,2044602,7324780,0,-4389691,3327745,6304656,5225571,10231407,12003136,8669740,11482531,16463383,14927577,18131497,21726278,19113902,24183865,18037487,12252168,20461643,15647208,19992282,16169909,8901867,3534110,5568184,6826591,1884406,-4706766,-6388012,94426,-8160379,-4083019,-10378695,-15486623,-7206171,-695686,4860798,0,10857061,3955448,-1061568,6951301,-1071594,0,-13446920,-12173160,-8243921,-11230304,-8734571,-16936920,-16750142,-9949134,-10991997,-3350146,-8268859,0,-14302173,-16276308,-11142092,-13546302,-15960168,-15744133,-20140592,-27616401,-23636225,-24849690,-18571631,-14996447,-8469842,-2690306,-1586836,1141087,-1808235,-5396094,-6508579,0,33601076,40110614,40470091,39158954,31965378,23662135,26792692,22837593,15375475,7595486,5806140,0,5557752,6250667,3210301,4771732,10208018,9244194,1488326,-6840876,-5503541,-6377388,1921887,8701362,436706,5155610,4702952,9854658,12359455,11367064,17274738,12815997,16178778,13979944,14676004,11309648,10910551,8856116,1692110,6290491,9917167,13883564,6354535,2315726,2456500,-3357012,-2245597,5286714,0,27838965,23929687,16271002,14334800,12447318,8856790,5550657,2872825,5216149,1984481,6519741,-380267,-2676926,5698169,-2416327,5822052,12780665,13247384,20633185,15313341,14149220,12991370,11193529,10073298,4257177,8166119,6158966,7167487,8065374,4626067,5253098,221789,0,-22666015,-19830708,-26450648,-22323702,-14812315,-12769333,-8380998,-124066,-3429801,1735354,8675238,5922004,3773612,4863814,8973510,8243987,8052797,-131886,-1218987,944425,-5693971,-10284458,-3771161,-6911370,1215128,6417910,7616391,10888675,12684613,15718607,12760177,4418538,0,-19124759,-16690729,-14466748,-7312246,-8934031,-14128478,-6391701,-5586522,-3281158,-6126513,-12086460,-11947805,-8977838,-4679499,-7044384,-3585849,2517797,4187257,1143610,5599470,12556,468724,0,-38086726,-38209271,-34895951,-29641991,-33756478,-34159294,-29272266,-24192985,-18907102,-10553406,-8755717,-5576171,1187225,5646949,0,-26021214,-24968854,-16606604,-23345266,-26556968,-27031671,-32169558,-29741461,-22232488,-21561792,-17815214,-9755318,-5676615,-1531928,0,-7082738,-2096546,69095,1247646,-2028294,278676,1852334,4571352,-3233037,-3429729,-6398514,-9422414,-2191733,2284645,-864442,-254370,1472191,0,3756457,650062,-4943727,-6384744,-850321,-5359348,-645558,-2506083,-3114762,-366178,-6339582,-4052845,0,65534,-7573163,-12029806,-18419840,-13680249,-6009158,-7346388,0,-39890208,-43517086,-35311112,-37123834,-36260718,-33030305,-34707046,-39911126,-35939603,-30275083,-36082502,-32249760,-27147583,-23233819,-25620860,-25554234,-22141128,-25506989,-22929605,-15879316,-24134083,-16570735,-9997301,-4200711,-2668164,1487850,3578750,-1305145,1080697,-6119380,-6192140,-4780925,-6340276,0,-26181571,-18058810,-10653064,-6588755,-9696374,-5833999,-9675119,-10632518,-11082908,-10756776,-10864096,-13002610,-7721565,-9182352,-6394042,-2752356,-9605533,-4366062,-8172748,0,-16273637,-12506792,-8904008,-8280500,-10173545,-6329127,-3926250,-8763799,-8461557,-5251290,1921403,9241406,2219290,2078592,1370230,2365533,0,-36174378,-34747120,-36960421,-38916018,-33713341,-27862565,-19493548,-13614863,-18329350,-13726747,-18636836,-21433533,-22047575,-17828457,-18477083,-18912228,-16845393,-14834848,-10961203,-4503372,2709924,-5670489,0,8244107,7371898,1062426,-5349784,-1530037,-4243202,1657954,0,58761276,64777759,62710415,55540126,63734805,67828569,66998117,65406433,58629880,51628041,49304089,52468514,44515601,37206921,40107031,36553913,32964413,28315600,22177065,24792502,21656741,20411694,28296854,21119658,16847130,10142928,6275059,10233804,7892690,6605617,812948,-4276554,421536,-282529,0,10264903,3489193,0,47453090,48772541,54603425,48519299,46216432,50441440,48516811,45678872,39908077,32646114,28833886,23180980,15877983,14237392,6679178,13066338,6271764,8380814,1833690,-4162730,-1918105,5114142,0,-25911951,-28491981,-26929631,-23869603,-20710623,-28958111,-23436032,-16629161,-16368397,-15117344,-13086145,-7862262,-3970195,-1325162,69199,2584855,-390927,-753348,-7662405,0,44746008,36954219,37811396,37926769,38442648,38288713,29989290,27015712,25484790,22372796,17537520,16774727,8552613,13943585,17093179,10142287,5721997,10994509,9787684,9382836,9256805,16015565,8545047,10254145,12213051,12551830,8902381,12267197,4492349,3729047,8190040,1659416,-5162630,0,-39096550,-32628259,-39002248,-31910093,-31760558,-26048323,-23199546,-18154141,-15577194,-20921838,-13620329,-5287668,-10372255,-7345019,-13225631,-8543390,-10782084,-10995673,-6251002,1830175,-5731084,-3491981,-9221778,-10184068,-15385965,-16015517,-7715802,-1442733,6174121,2371134,-1808823,5881932,0,-10833715,-9130099,-7149409,-89049,-6363174,-3030367,884814,0,4329246,-712705,-2477029,-4838047,-6361858,-758166,6976202,50092,-5046096,2007750,-5232448,-1895517,-5590470,-4630085,-5205817,-5003092,1356974,0,-30933008,-25815115,-26412272,-27208148,-28291145,-30761072,-24801972,-20136889,-20802009,-17119600,-9796191,-5951994,-3024348,-6817180,-10261727,-12018141,-6423630,-7809004,-12362519,-15505819,-17738534,-12482571,-16777356,-8514106,-10646693,-13579392,-17091140,-10886710,-8783584,-3787667,0,-10399417,-9783351,-11140112,-10286438,-18016415,-24699666,-29534073,-30173237,-22982316,-16232479,-20550054,-17508444,-20456501,-15338123,-16089893,-19682049,-17509739,-17545850,-20482200,-16092902,-10112370,-9857530,-7086012,-5758886,-13713007,-18431943,-12663085,-10395688,-9242682,-3627676,-4124458,324696,0,-1239916,-1099231,0,-52728448,-49740852,-53462736,-48128709,-51184308,-50512793,-51205907,-44973519,-45435372,-48750664,-42361329,-35515045,-32329339,-31125840,-23377216,-15586974,-16058124,-22592883,-17078262,-10577077,-10527747,-13404618,-8157252,-2726103,-4759099,-9619550,-11889364,-13992613,-14997209,-7958218,0,11463857,11389338,6395972,4491458,0,9908832,4627071,2514558,5454929,3049640,-3347579,-4585603,-8139773,-4727321,-5405095,-5516549,-1072707,2091727,10164364,8109479,13221076,11835227,5915534,7266805,10176116,7976055,487672,-1039582,4809829,-3150159,0,-5576241,2649236,-4909388,2973172,0]+    rs = fromList (Z :. 37)  [1828591,-5649957,12711572,-882080,8724897,-5592479,-16715596,30682536,8434130,20924927,-21828584,-20372532,-33000591,-25847170,-2348236,7144729,-7521765,-37600334,-21413350,-17584160,-30265145,2716955,54962523,15814454,52796336,-29414196,44937491,-41772916,-13871531,5751378,-32142219,-11167891,-5978481,-54925970,6000925,17510325,-13863452]++test11 :: Acc (Vector Int64, Vector Int64)+test11 = A.scanr'Seg (+) 0 xs seg+  where+    xs :: Acc (Vector Int64)+    xs = use $ fromList (Z :. 750) [1528389,4234310,3359193,-7411630,118329,3970884,-2913599,-6901574,160809,2395808,-6718378,-3774608,748747,1061385,-6700346,-6221147,-1163017,8242548,2833965,6984536,-3905485,5053528,481198,4101993,-2231048,3229689,-2880471,-4559921,-7463156,-4033554,7392693,1636656,1445342,-5347040,-367429,-6092463,2541659,8002933,-2417064,7755970,4261635,-5822484,6614159,3415814,4135662,1645280,-7868320,8299050,1593569,1675588,6241409,7724979,4178640,-7854151,-6332082,-6044131,-5197647,-5280178,7324780,3507611,-7717436,-2976911,1079085,-5005836,-1771729,3333396,-2812791,-4980852,1535806,-3203920,-3594781,2612376,-5069963,6146378,5785319,-8209475,4814435,-4345074,3822373,7268042,5367757,-2034074,-1258407,4942185,6591172,1681246,-6482438,8254805,-4077360,6295676,5107928,-8280452,-6510485,-5556484,4860798,-2132164,6901613,5017016,-8012869,8022895,-1071594,7854441,-1273760,-3929239,2986383,-2495733,8202349,-186778,-6801008,1042863,-7641851,4918713,-8268859,-2413423,1974135,-5134216,2404210,2413866,-216035,4396459,7475809,-3980176,1213465,-6278059,-3575184,-6526605,-5779536,-1103470,-2727923,2949322,3587859,1112485,-6508579,-2918540,-6509538,-359477,1311137,7193576,8303243,-3130557,3955099,7462118,7779989,1789346,5806140,2876378,-692915,3040366,-1561431,-5436286,963824,7755868,8329202,-1337335,873847,-8299275,-6779475,8264656,-4718904,452658,-5151706,-2504797,992391,-5907674,4458741,-3362781,2198834,-696060,3366356,399097,2054435,7164006,-4598381,-3626676,-3966397,7529029,4038809,-140774,5813512,-1111415,-7532311,5286714,-6914038,3909278,7658685,1936202,1887482,3590528,3306133,2677832,-2343324,3231668,-4535260,6900008,2296659,-8375095,8114496,-8238379,-6958613,-466719,-7385801,5319844,1164121,1157850,1797841,1120231,5816121,-3908942,2007153,-1008521,-897887,3439307,-627031,5031309,221789,837431,-2835307,6619940,-4126946,-7511387,-2042982,-4388335,-8256932,3305735,-5165155,-6939884,2753234,2148392,-1090202,-4109696,729523,191190,8184683,1087101,-2163412,6638396,4590487,-6513297,3140209,-8126498,-5202782,-1198481,-3272284,-1795938,-3033994,2958430,8341639,4418538,-1247773,-2434030,-2223981,-7154502,1621785,5194447,-7736777,-805179,-2305364,2845355,5959947,-138655,-2969967,-4298339,2364885,-3458535,-6103646,-1669460,3043647,-4455860,5586914,-456168,468724,5086135,122545,-3313320,-5253960,4114487,402816,-4887028,-5079281,-5285883,-8353696,-1797689,-3179546,-6763396,-4459724,5646949,174044,-1052360,-8362250,6738662,3211702,474703,5137887,-2428097,-7508973,-670696,-3746578,-8059896,-4078703,-4144687,-1531928,4734502,-4986192,-2165641,-1178551,3275940,-2306970,-1573658,-2719018,7804389,196692,2968785,3023900,-7230681,-4476378,3149087,-610072,-1726561,1472191,3388272,3106395,5593789,1441017,-5534423,4509027,-4713790,1860525,608679,-2748584,5973404,-2286737,-4052845,-7587299,7638697,4456643,6390034,-4739591,-7671091,1337230,-7346388,2289874,3626878,-8205974,1812722,-863116,-3230413,1676741,5204080,-3971523,-5664520,5807419,-3832742,-5102177,-3913764,2387041,-66626,-3413106,3365861,-2577384,-7050289,8254767,-7563348,-6573434,-5796590,-1532547,-4156014,-2090900,4883895,-2385842,7200077,72760,-1411215,1559351,-6340276,4768221,-8122761,-7405746,-4064309,3107619,-3862375,3841120,957399,450390,-326132,107320,2138514,-5281045,1460787,-2788310,-3641686,6853177,-5239471,3806686,-8172748,-1310523,-3766845,-3602784,-623508,1893045,-3844418,-2402877,4837549,-302242,-3210267,-7172693,-7320003,7022116,140698,708362,-995303,2365533,5909233,-1427258,2213301,1955597,-5202677,-5850776,-8369017,-5878685,4714487,-4602603,4910089,2796697,614042,-4219118,648626,435145,-2066835,-2010545,-3873645,-6457831,-7213296,8380413,-5670489,-5527152,872209,6309472,6412210,-3819747,2713165,-5901156,1657954,-3798753,-6016483,2067344,7170289,-8194679,-4093764,830452,1591684,6776553,7001839,2323952,-3164425,7952913,7308680,-2900110,3553118,3589500,4648813,6138535,-2615437,3135761,1245047,-7885160,7177196,4272528,6704202,3867869,-3958745,2341114,1287073,5792669,5089502,-4698090,704065,-282529,5549551,6775710,3489193,5343246,-1319451,-5830884,6084126,2302867,-4225008,1924629,2837939,5770795,7261963,3812228,5652906,7302997,1640591,7558214,-6387160,6794574,-2109050,6547124,5996420,-2244625,-7032247,5114142,-3502245,2580030,-1562350,-3060028,-3158980,8247488,-5522079,-6806871,-260764,-1251053,-2031199,-5223883,-3892067,-2645033,-1394361,-2515656,2975782,362421,6909057,-7662405,191483,7791789,-857177,-115373,-515879,153935,8299423,2973578,1530922,3111994,4835276,762793,8222114,-5390972,-3149594,6950892,4420290,-5272512,1206825,404848,126031,-6758760,7470518,-1709098,-1958906,-338779,3649449,-3364816,7774848,763302,-4460993,6530624,6822046,-5162630,-2676366,-6468291,6373989,-7092155,-149535,-5712235,-2848777,-5045405,-2576947,5344644,-7301509,-8332661,5084587,-3027236,5880612,-4682241,2238694,213589,-4744671,-8081177,7561259,-2239103,5729797,962290,5201897,629552,-8299715,-6273069,-7616854,3802987,4179957,-7690755,5881932,-3037816,-1703616,-1980690,-7060360,6274125,-3332807,-3915181,884814,1422132,5041951,1764324,2361018,1523811,-5603692,-7734368,6926110,5096188,-7053846,7240198,-3336931,3694953,-960385,575732,-202725,-6360066,1356974,-1209211,-5117893,597157,795876,1082997,2469927,-5959100,-4665083,665120,-3682409,-7323409,-3844197,-2927646,3792832,3444547,1756414,-5594511,1385374,4553515,3143300,2232715,-5255963,4294785,-8263250,2132587,2932699,3511748,-6204430,-2103126,-4995917,-3787667,-768474,-616066,1356761,-853674,7729977,6683251,4834407,639164,-7190921,-6749837,4317575,-3041610,2948057,-5118378,751770,3592156,-2172310,36111,2936350,-4389298,-5980532,-254840,-2771518,-1327126,7954121,4718936,-5768858,-2267397,-1153006,-5615006,496782,-4449154,324696,-4738565,-140685,-1099231,-2197522,-2987596,3721884,-5334027,3055599,-671515,693114,-6232388,461853,3315292,-6389335,-6846284,-3185706,-1203499,-7748624,-7790242,471150,6534759,-5514621,-6501185,-49330,2876871,-5247366,-5431149,2032996,4860451,2269814,2103249,1004596,-7038991,-7958218,-5462932,74519,4993366,1904514,4491458,7601493,5281761,2112513,-2940371,2405289,6397219,1238024,3554170,-3412452,677774,111454,-4443842,-3164434,-8072637,2054885,-5111597,1385849,5919693,-1351271,-2909311,2200061,7488383,1527254,-5849411,7959988,-3150159,-8287211,-8225477,7558624,-7882560,2973172]++    seg :: Acc (Segments Int32)+    seg = use $ fromList (Z :. 37) [5,35,19,36,6,12,20,12,37,33,33,23,15,15,18,13,8,34,20,17,23,8,35,3,23,20,34,33,8,18,31,33,3,31,5,26,5]+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue123+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/123+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue123 (++  test_issue123++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue123 :: RunN -> TestTree+test_issue123 runN =+  testCase "123"  $ ref1 @=? runN (test1 n)+  where+    n     = 100+    ref1  = fromList Z [n]+++test1 :: Int -> Acc (Scalar Int)+test1 n+  = fold (+) 0+  $ fill (constant (Z:.n)) 1+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue137+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/137+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue137 (++  test_issue137++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit++import Prelude                                                      as P+++test_issue137 :: RunN -> TestTree+test_issue137 runN =+  testCase "137"  $ ref1 @=? runN test1+++ref1 :: Vector (Int,Int)+ref1 = fromList (Z:.384) [(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000)]++test1 :: Acc (Vector (Int,Int))+test1 =+  let+      sz          = 3000 :: Int+      interm_arrA = use $ A.fromList (Z :. sz) [ P.fromIntegral $ 8 - (a `mod` 17) | a <- [1..sz]]+      msA         = use $ A.fromList (Z :. sz) [ P.fromIntegral $ (a `div` 8) | a <- [1..sz]]+      inf         = 10000 :: Exp Int+      infsA       = A.generate (index1 (384 :: Exp Int)) (\_ -> lift (inf,inf))+      inpA        = A.map (\v -> lift (abs v,inf) :: Exp (Int,Int)) interm_arrA+  in+  A.permute (\a12 b12 -> let (a1,a2) = unlift a12+                             (b1,b2) = unlift b12+                         in (a1 A.<= b1)+                          ? ( lift (a1, A.min a2 b1)+                            , lift (b1, A.min b2 a1)+                            ))+            infsA+            (\ix -> index1 (msA A.! ix))+            inpA+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue168+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/168+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue168 (++  test_issue168++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit++import Prelude                                                      as P+++test_issue168 :: RunN -> TestTree+test_issue168 runN =+  testGroup "168"+    [ testCase "A"  $ ref1 @=? runN (A.fill sh test1)+    , testCase "B"  $ ref2 @=? runN (A.fill sh test2)+    , testCase "C"  $ ref3 @=? runN (A.fill sh test3)+    ]+  where+    sh          = index1 (constant 1) :: Exp DIM1++    -- Test 1+    -- ------+    dqc1 :: (Exp Float, Exp Float)+    dqc1 = (2,1)++    qMult1 :: (Exp Float, Exp Float) -> (Exp Float, Exp Float)+    qMult1 (a1,_) = (3, a1)++    ref1 = fromList (Z:.1) [(3.0,2.0)]++    test1 :: Exp (Float, Float)+    test1 = P.iterate (lift1 qMult1) (lift dqc1) P.!! 1++    ref2 = ref1++    test2 :: Exp (Float, Float)+    test2 = A.iterate (constant 1) (lift1 qMult1) (lift dqc1)++    -- Test 2+    -- ------+    ref3 = fromList (Z:.1) [(1.0,2.0,3.0,4.0,5.0,6.0)]++    dqc3 :: (Exp Float, Exp Float, Exp Float, Exp Float, Exp Float, Exp Float)+    dqc3 = (6,5,4,3,2,1)++    qMult3 :: (Exp Float, Exp Float, Exp Float, Exp Float, Exp Float, Exp Float)+           -> (Exp Float, Exp Float, Exp Float, Exp Float, Exp Float, Exp Float)+    qMult3 (a1,b1,c1,d1,e1,f1) = (f1,e1,d1,c1,b1,a1)++    test3 :: Exp (Float,Float,Float,Float,Float,Float)+    test3 = A.iterate (constant 1) (lift1 qMult3) (lift dqc3)+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes        #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue184+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/184+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue184 (++  test_issue184++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue184 :: RunN -> TestTree+test_issue184 runN =+  testGroup "184"+    [ testCase "A"  $ ref1 @=? runN test1+    , testCase "B"  $ ref2 @=? runN test2+    , testCase "C"  $ ref3 @=? runN test3+    ]+++ref1 :: Vector Int+ref1 = fromList (Z :. 1000) [1,4,9,16,25,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,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,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,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,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,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,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,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,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,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]++test1 :: Acc (Vector Int)+test1 =+  let v   = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)+      f x = x < 5 ? (let y = v !! x in y*y, 0)+  in generate (index1 1000) (f . unindex1)+++ref2 :: Scalar Bool+ref2 = fromList Z [True]++test2 :: Acc (Scalar Bool)+test2 =+  let x = constant 1 :: Exp Int+      v = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)+      y = (x == 1 || v !! (-1) == 1)+  in unit y+++ref3 :: Scalar Bool+ref3 = fromList Z [False]++test3 :: Acc (Scalar Bool)+test3 =+  let x = constant 1 :: Exp Int+      v = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)+      y = (x /= 1 && v !! (-1) == 1)+  in unit y+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue185+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/185+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue185 (++  test_issue185++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit++import Prelude                                                      as P+++test_issue185 :: RunN -> TestTree+test_issue185 runN =+  testGroup "185"+    [ testCase "A"  $ ref1 @=? (runN acc1 :: Vector Int)+    , testCase "B"  $ ref2 @=? (runN acc2 :: Vector Int)+    , testCase "C"  $ ref3 @=? (runN acc3 :: Vector Int)+    , testCase "D"  $ ref4 @=? (runN acc4 :: Vector Int)+    , testCase "E"  $ ref5 @=? (runN acc5 :: Vector Int)+    , testCase "F"  $ ref6 @=? (runN acc6 :: Vector Int)+    ]+++ref1 :: (Elt a, P.Num a) => Vector a+ref1 = fromList (Z :. 9) [0,1,4,9,0,4,0,6,2]++acc1 :: (Elt a, P.Num a) => Acc (Vector a)+acc1 = A.scatter to over xs+  where+    over        = use [0, 0, 0, 0, 0, 0, 0, 0, 0]+    xs          = use [1, 9, 6, 4, 4, 2, 5]+    to          = use [1, 3, 7, 2, 5, 8]+++ref2 :: (Elt a, P.Num a) => Vector a+ref2 = fromList (Z :. 9) [0,1,0,9,0,0,0,6,0]++acc2 :: (Elt a, P.Num a) => Acc (Vector a)+acc2 = A.scatter to over xs+  where+    over        = use [0, 0, 0, 0, 0, 0, 0, 0, 0]+    xs          = use [1, 9, 6]+    to          = use [1, 3, 7, 2, 5, 8]+++ref3 :: (Elt a, P.Num a) => Vector a+ref3 = fromList (Z :. 9) [0,0,0,0,0,4,0,6,2]++acc3 :: (Elt a, P.Num a) => Acc (Vector a)+acc3 = scatterIf to mask p over xs+  where+    over        = use [0, 0, 0, 0, 0, 0, 0, 0, 0]+    to          = use [1, 3, 7, 2, 5, 8]+    xs          = use [1, 9, 6, 4, 4, 2, 5]++    mask :: Acc (Vector Int32)+    mask        = use [3, 4, 9, 2, 7, 5]+    p           = (A.> 4)+++ref4 :: (Elt a, P.Num a) => Vector a+ref4 = fromList (Z :. 9) [0,0,0,0,0,0,0,6,0]++acc4 :: (Elt a, P.Num a) => Acc (Vector a)+acc4 = scatterIf to mask p over xs+  where+    over        = use [0, 0, 0, 0, 0, 0, 0, 0, 0]+    to          = use [1, 3, 7, 2, 5, 8]+    xs          = use [1, 9, 6]++    mask :: Acc (Vector Int32)+    mask        = use [3, 4, 9, 2, 7, 5]+    p           = (A.> 4)+++ref5 :: (Elt a, P.Num a) => Vector a+ref5 = fromList (Z :. 6) [9,4,1,6,2,4]++acc5 :: (Elt a, P.Num a) => Acc (Vector a)+acc5 = A.gather from xs+  where+    from        = use [1, 3, 7, 2, 5, 3]+    xs          = use [1, 9, 6, 4, 4, 2, 0, 1, 2]+++ref6 :: (Elt a, P.Num a) => Vector a+ref6 = fromList (Z :. 6) [6,6,1,6,2,4]++acc6 :: (Elt a, P.Num a) => Acc (Vector a)+acc6 = gatherIf from mask p over xs+  where+    over        = use [6, 6, 6, 6, 6, 6]+    from        = use [1, 3, 7, 2, 5, 3]+    xs          = use [1, 9, 6, 4, 4, 2, 0, 1, 2]++    mask :: Acc (Vector Int32)+    mask        = use [3, 4, 9, 2, 7, 5]+    p           = (A.> 4)+++gatherIf+    :: (Elt a, Elt b)+    => Acc (Vector Int)           -- ^ source indices to gather from+    -> Acc (Vector a)             -- ^ mask vector+    -> (Exp a -> Exp Bool)        -- ^ predicate function+    -> Acc (Vector b)             -- ^ default values+    -> Acc (Vector b)             -- ^ source values+    -> Acc (Vector b)+gatherIf from maskV p def input = A.zipWith zf pf gatheredV+  where+    zf ok g     = ok ? (unlift g)+    gatheredV   = A.zip (gather from input) def+    pf          = A.map p maskV++scatterIf+    :: (Elt e, Elt e')+    => Acc (Vector Int)           -- ^ destination indices to scatter into+    -> Acc (Vector e)             -- ^ mask vector+    -> (Exp e -> Exp Bool)        -- ^ predicate function+    -> Acc (Vector e')            -- ^ default values+    -> Acc (Vector e')            -- ^ source values+    -> Acc (Vector e')+scatterIf to maskV p def input = permute const def pf input'+  where+    pf ix       = p (maskV ! ix) ? ( index1 (to ! ix), ignore )+    input'      = backpermute (shape to `intersect` shape input) id input+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes        #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue187+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/187+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue187 (++  test_issue187++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue187 :: RunN -> TestTree+test_issue187 runN =+  testGroup "187"+    [ testCase "A"  $ ref1 @=? runN test1+    , testCase "B"  $ ref2 @=? runN test2+    ]+++ref1 :: Scalar Bool+ref1 = fromList Z [True]++test1 :: Acc (Scalar Bool)+test1 =+  let x = constant 1 :: Exp Int+      v = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)+      y = (x == 1 || v A.!! (-1) == 1)+  in generate (constant Z) (const y)+++ref2 :: Scalar Bool+ref2 = fromList Z [True]++test2 :: Acc (Scalar Bool)+test2 =+  let x  = constant 1 :: Exp Int+      x' = unit x+      v  = use (fromList (Z :. 5) [1,2,3,4,5] :: Vector Int)+      y  = (x == the x' || let y' = v A.!! (-1) in y'*y' == 1)+  in generate (constant Z) (const y)+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ConstraintKinds  #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue228+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/228+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue228 (++  test_issue228++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit++import Prelude                                                    as P+++test_issue228 :: RunN -> TestTree+test_issue228 runN =+  testGroup "228"+    [ testCase "A"  $ ref1 @=? runN (A.fold  mergeExp z1 (use test1))+    , testCase "B"  $ ref1 @=? runN (A.fold1 mergeExp    (use test1))+    ]+++test1 :: Vector (Int,Int)+test1 = fromList (Z:.3) [(1,1),(0,0),(1,1)]++z1 :: Exp (Int,Int)+z1 = constant (1,0)++ref1 :: Scalar (Int,Int)+ref1 = fromList Z [(0,1)]++{--+testAssociativity =+  quickCheck $ \(x, y, z) -> mergeB x (mergeB y z) == mergeB (mergeB x y) z++mergeB :: (Bool,Int) -> (Bool,Int) -> (Bool,Int)+mergeB (b1,l1) (b2,l2) = (toEnum v3,l3)+  where+    (v3,l3) = merge (fromEnum b1,l1) (fromEnum b2,l2)+--}++merge :: P.Num a => (a,a) -> (a,a) -> (a,a)+merge (onL, lenL) (onR, lenR) = (onL * onR, onL * lenR + lenL)++mergeExp :: Exp (Int,Int) -> Exp (Int,Int) -> Exp (Int,Int)+mergeExp e1 e2 =+  let+    v1 = unlift e1 :: (Exp Int,Exp Int)+    v2 = unlift e2 :: (Exp Int,Exp Int)+  in+  lift $ merge v1 v2+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue255+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/255+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue255 (++  test_issue255++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config++import Test.Tasty+import Test.Tasty.HUnit++import Data.List                                                    as P+import Prelude                                                      as P+++test_issue255 :: RunN -> TestTree+test_issue255 runN =+  askOption $ \(Interpreter slow) ->+    if slow+      then testGroup "255 (skipped due to interpreter backend)" []+      else testGroup "255"+            [ within lIMIT $ testCase "0"   (force $ total (as P.!! 0))+            , within lIMIT $ testCase "2"   (force $ total (as P.!! 2))+            , within lIMIT $ testCase "4"   (force $ total (as P.!! 4))+            , within lIMIT $ testCase "20"  (force $ total (as P.!! 20))+            , within lIMIT $ testCase "100" (force $ total (as P.!! 100))+            -- , within lIMIT $ testCase "200" (force $ total (as P.!! 200))+            -- , within lIMIT $ testCase "300" (force $ total (as P.!! 300))+            ]+  where+    lIMIT = 30 * 1000 * 1000  -- microseconds+    n     = 20 * 1024 * 1024  -- 160 * MiB (8 bytes per Double)++    as :: [A.Vector Double]+    as = sums (A.fromList (Z:.n) (repeat 0)) (A.fromList (Z:.n) (repeat 1))++    scalar :: Elt e => e -> Scalar e+    scalar x = fromFunction Z (const x)++    sums :: A.Vector Double -> A.Vector Double -> [A.Vector Double]+    sums a0 b+      = a0+      : ( P.snd+        $ P.mapAccumL+            (\a' i -> let !go = runN step+                          a   = go (a', b, scalar i)+                      in (a, a))+            a0+            [0 .. 500]+        )++    step :: Acc (A.Vector Double, A.Vector Double, A.Scalar Int) -> Acc (A.Vector Double)+    step (unlift -> (a, b, A.the -> _i::Exp Int)) = A.zipWith (+) a b++    total :: A.Vector Double -> A.Scalar Double+    total a = go a+      where+        !go = runN (A.sum . A.map id)+        -- runN $ A.sum $ A.map id $ A.use a++    force :: A.Scalar Double -> Assertion+    force x = () @=? (indexArray x Z `seq` ())++  -- print $ total $ as P.!! 0+  -- print $ total $ as P.!! 2+  -- print $ total $ as P.!! 4+  -- print $ total $ as P.!! 20+  -- print $ total $ as P.!! 100+  -- print $ total $ as P.!! 200+  -- print $ total $ as P.!! 300+++within :: Integer -> TestTree -> TestTree+within usec = localOption (mkTimeout usec)++-- within :: Int -> Scalar Double -> Assertion+-- within n arr = do+--   r <- timeout n $ evaluate (indexArray arr Z `seq` ())+--   case r of+--     Nothing -> assertFailure "timeout: backend is too slow or memory manager stuck?"+--     Just () -> return ()+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue264+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/264+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue264 (++  test_issue264++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Array.Sugar                            as S+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen++import Test.Tasty+import Test.Tasty.Hedgehog+++test_issue264 :: RunN -> TestTree+test_issue264 runN =+  testGroup "264"+    [ testBool+    , at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt+        :: forall a. (Similar a, P.Num a, A.Num a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testProperty "neg.neg"        $ test_neg_neg runN e+        ]++    testBool :: TestTree+    testBool =+      testGroup "Bool"+        [ testProperty "not.not"        $ test_not_not runN+        , testProperty "not(&&)"        $ test_not_and runN+        , testProperty "not(||)"        $ test_not_or runN+        , testProperty "not(not(&&))"   $ test_not_not_and runN+        , testProperty "not(not(||))"   $ test_not_not_or runN+        ]++test_not_not+    :: RunN+    -> Property+test_not_not runN =+  property $ do+    xs <- forAll (array Z Gen.bool)+    let !go = runN (A.map A.not . A.map A.not) in go xs === mapRef (P.not . P.not) xs++test_not_and+    :: RunN+    -> Property+test_not_and runN =+  property $ do+    xs <- forAll (array Z Gen.bool)+    ys <- forAll (array Z Gen.bool)+    let !go = runN (A.zipWith (\u v -> A.not (u A.&& v))) in go xs ys === zipWithRef (\u v -> P.not (u P.&& v)) xs ys++test_not_or+    :: RunN+    -> Property+test_not_or runN =+  property $ do+    xs <- forAll (array Z Gen.bool)+    ys <- forAll (array Z Gen.bool)+    let !go = runN (A.zipWith (\u v -> A.not (u A.|| v))) in go xs ys === zipWithRef (\u v -> P.not (u P.|| v)) xs ys++test_not_not_and+    :: RunN+    -> Property+test_not_not_and runN =+  property $ do+    xs <- forAll (array Z Gen.bool)+    ys <- forAll (array Z Gen.bool)+    let !go = runN (A.zipWith (\u v -> A.not (A.not (u A.&& v)))) in go xs ys === zipWithRef (\u v -> P.not (P.not (u P.&& v))) xs ys++test_not_not_or+    :: RunN+    -> Property+test_not_not_or runN =+  property $ do+    xs <- forAll (array Z Gen.bool)+    ys <- forAll (array Z Gen.bool)+    let !go = runN (A.zipWith (\u v -> A.not (A.not (u A.|| v)))) in go xs ys === zipWithRef (\u v -> P.not (P.not (u P.|| v))) xs ys++test_neg_neg+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_neg_neg runN e =+  property $ do+    sh <- forAll dim1+    xs <- forAll (array sh e)+    let !go = runN (A.map negate . A.map negate) in go xs ~~~ mapRef (negate . negate) xs++++mapRef :: (Shape sh, Elt b) => (a -> b) -> Array sh a -> Array sh b+mapRef f xs = fromFunction (S.shape xs) (\ix -> f (xs S.! ix))++zipWithRef+    :: (Shape sh, Elt c)+    => (a -> b -> c)+    -> Array sh a+    -> Array sh b+    -> Array sh c+zipWithRef f xs ys =+  fromFunction+    (S.shape xs `S.intersect` S.shape ys)+    (\ix -> f (xs S.! ix) (ys S.! ix))+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes          #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue287+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/287+-- https://gist.github.com/cpdurham/7c11134bc345f12a8863+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue287 (++  test_issue287++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue287 :: RunN -> TestTree+test_issue287 runN =+  testGroup "287"+    [ testCase "A"  $ ref1 @=? runN (\x -> A.scanl1 f x) arr1+    , testCase "B"  $ ref1 @=? runN (\x -> A.scanl1Seg (\_ b -> b) x (use segs)) arr1+    , testCase "C"  $ ref1 @=? runN (\x -> A.scanl1Seg f x (use segs)) arr1+    ]++ref1 :: Vector (Int,Int,Int,Int,Int,Int)+ref1 = fromList (Z:.4) [(0,0,0,0,0,0),(0,0,0,0,0,0),(0,0,0,0,0,0),(0,0,0,0,0,0)]++arr1 :: Vector (Int,Int,Int,Int,Int,Int)+arr1 = fromList (Z:.4) [(0,0,0,0,0,0),(0,0,0,0,0,0),(0,0,0,0,0,0),(0,0,0,0,0,0)]++segs :: Segments Int+segs = A.fromList (Z:.2) [2,2]++f :: forall a. (A.Num a, A.Ord a)+  => Exp (a,a,a,a,a,a)+  -> Exp (a,a,a,a,a,a)+  -> Exp (a,a,a,a,a,a)+f x y = lift (mi3,l3,c3,r3,li3,ri3)+  where+    ( mi1,l1, c1,r1, li1,ri1) = unlift x :: (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)+    (_mi2,l2,_c2,r2,_li2,ri2) = unlift y :: (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)+    --+    l3  = l1+    c3  = c1+    r3  = r2 * r1+    mi3 = A.max mi1 (ri1+l2)+    li3 = li1+    ri3 = ri2++-- fExp+--   :: Exp (Int,Int,Int,Int,Int,Int)+--   -> Exp (Int,Int,Int,Int,Int,Int)+--   -> Exp (Int,Int,Int,Int,Int,Int)+-- fExp e1 e2 =+--     let+--         v1 = unlift6E e1+--         v2 = unlift6E e2+--     in+--       lift $ f v1 v2++-- unlift6E+--   :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+--   => Exp (a,b,c,d,e,f)+--   -> (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)+-- unlift6E = unlift++-- lift6E+--   :: (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)+--   => (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f)+--   -> Exp (a,b,c,d,e,f)+-- lift6E = lift++-- convert+--   :: Acc (Array DIM1 Int)+--   -> Acc (Array DIM1 (Int,Int,Int,Int,Int,Int))+-- convert = A.map (\_ -> lift6E (0,0,0,0,0,0))++-- arr2 = I.run1 convert (A.fromList (Z :. 4 :: DIM1) ([1,1,1,1]) :: Array DIM1 Int)++-- print $ C.run1 (\x -> A.scanl1 fExp x) $ arr2+-- --no problem++-- print $ C.run1 (\x -> A.scanl1Seg (\_ b -> b) x segs) $ arr2+-- --no problem++-- print $ C.run1 (\x -> A.scanl1Seg fExp x segs) $ arr2+-- -- CUDA exception: invalid argument+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue288+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/288+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue288 (++  test_issue288++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit++import Prelude                                                      as P+++test_issue288 :: RunN -> TestTree+test_issue288 runN =+  testCase "288"  $ xs @=? runN (A.map f) xs++f :: Exp (Int, Int) -> Exp (Int, Int)+f e = while (const (lift False)) id e++xs :: Vector (Int, Int)+xs = fromList (Z:.10) (P.zip [1..] [1..])+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue362+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate-llvm/issues/12+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue362 (++  test_issue362++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue362 :: RunN -> TestTree+test_issue362 runN =+  testGroup "362"+    [ testCase "A"  $ e1 @=? runN t1+    , testCase "B"  $ e2 @=? runN t2+    ]++-- should work+e1 :: Vector (Int,Int,Int,Int)+e1 = fromList (Z:.10) [(0,0,0,0),(1,1,1,1),(3,3,3,3),(6,6,6,6),(10,10,10,10),(15,15,15,15),(21,21,21,21),(28,28,28,28),(36,36,36,36),(45,45,45,45)]++t1 :: Acc (Vector (Int,Int,Int,Int))+t1 = A.scanl1 (lift2 f) xs+  where+    xs = use $ fromList (Z:.10) [ (x,x,x,x) | x <- [0..9] ]+    --+    f :: (Exp Int, Exp Int, Exp Int, Exp Int)+      -> (Exp Int, Exp Int, Exp Int, Exp Int)+      -> (Exp Int, Exp Int, Exp Int, Exp Int)+    f (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)+++-- was broken on pascal+e2 :: Vector (Int,Int,Int,Int,Int)+e2 = fromList (Z:.10) [(0,0,0,0,0),(1,1,1,1,1),(3,3,3,3,3),(6,6,6,6,6),(10,10,10,10,10),(15,15,15,15,15),(21,21,21,21,21),(28,28,28,28,28),(36,36,36,36,36),(45,45,45,45,45)]++t2 :: Acc (Vector (Int,Int,Int,Int,Int))+t2 = A.scanl1 (lift2 f) xs+  where+    xs = use $ fromList (Z:.10) [ (x,x,x,x,x) | x <- [0..9] ]+    --+    f :: (Exp Int, Exp Int, Exp Int, Exp Int, Exp Int)+      -> (Exp Int, Exp Int, Exp Int, Exp Int, Exp Int)+      -> (Exp Int, Exp Int, Exp Int, Exp Int, Exp Int)+    f (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedLists     #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue407+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/407+-- https://github.com/AccelerateHS/accelerate-llvm/pull/27+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue407 (++  test_issue407++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue407 :: RunN -> TestTree+test_issue407 runN =+  testGroup "407"+    [ testElt (Proxy::Proxy Float)+    , testElt (Proxy::Proxy Double)+    ]+  where+    testElt+        :: forall a. (P.Fractional a, A.RealFloat a)+        => Proxy a+        -> TestTree+    testElt _ =+      testGroup (show (typeOf (undefined :: a)))+        [ testCase "isNaN"      $ eNaN @=? runN (A.map A.isNaN) xs+        , testCase "isInfinite" $ eInf @=? runN (A.map A.isInfinite) xs+        ]+        where+          xs :: Vector a+          xs   = [0/0,   -2/0,  -0/0,  0.1,   1/0,   0.5,   5/0]+          eNaN = [True,  False, True,  False, False, False, False]  -- expected: isNaN+          eInf = [False, True,  False, False, True,  False, True]   -- expected: isInfinite+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue409+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/409+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue409 (++  test_issue409++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue409 :: RunN -> TestTree+test_issue409 runN =+  testGroup "409"+    [ testElt (Proxy::Proxy Float)+    , testElt (Proxy::Proxy Double)+    ]+  where+    testElt+        :: forall a. (P.Floating a, P.Eq a, A.Floating a)+        => Proxy a+        -> TestTree+    testElt _ =+      testGroup (show (typeOf (undefined :: a)))+        [ testCase "A" $ e1 @=? indexArray (runN (A.map f) t1) Z+        ]+      where+        e1 :: a+        e1 = 1 + tanh (-1)++        t1 :: Scalar a+        t1 = fromList Z [1]++        f :: A.Floating a => Exp a -> Exp a+        f x = let y = recip x+                  b = (-y) * y+              in+              y + tanh b+
+ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Issues.Issue93+-- Copyright   : [2009..2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- https://github.com/AccelerateHS/accelerate/issues/93+--++module Data.Array.Accelerate.Test.NoFib.Issues.Issue93 (++  test_issue93++) where++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Test.NoFib.Base++import Test.Tasty+import Test.Tasty.HUnit+++test_issue93 :: RunN -> TestTree+test_issue93 runN =+  testCase "93" $ xs @=? runN test1++xs :: Array DIM2 Int+xs = fromList (Z :. 1 :. 1) [5]++test1 :: Acc (Array DIM2 Int)+test1 = permute (\c _ -> c) (fill (shape xs') (constant 0)) id xs'+  where+    xs' = use xs+
+ src/Data/Array/Accelerate/Test/NoFib/Prelude.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Prelude+-- Copyright   : [2009..2017] 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.Test.NoFib.Prelude (++  test_prelude,++  module Data.Array.Accelerate.Test.NoFib.Prelude.Map,+  module Data.Array.Accelerate.Test.NoFib.Prelude.ZipWith,+  module Data.Array.Accelerate.Test.NoFib.Prelude.Fold,+  module Data.Array.Accelerate.Test.NoFib.Prelude.Scan,+  module Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute,+  module Data.Array.Accelerate.Test.NoFib.Prelude.Permute,+  module Data.Array.Accelerate.Test.NoFib.Prelude.Filter,+  module Data.Array.Accelerate.Test.NoFib.Prelude.Stencil,++) where++import Test.Tasty++import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Prelude.Map+import Data.Array.Accelerate.Test.NoFib.Prelude.ZipWith+import Data.Array.Accelerate.Test.NoFib.Prelude.Fold+import Data.Array.Accelerate.Test.NoFib.Prelude.Scan+import Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute+import Data.Array.Accelerate.Test.NoFib.Prelude.Permute+import Data.Array.Accelerate.Test.NoFib.Prelude.Filter+import Data.Array.Accelerate.Test.NoFib.Prelude.Stencil+++test_prelude :: RunN -> TestTree+test_prelude runN =+  testGroup "prelude"+    [ test_map runN+    , test_zipWith runN+    , test_fold runN+    , test_foldSeg runN+    , test_backpermute runN+    , test_permute runN+    , test_scanl runN+    , test_scanl1 runN+    , test_scanl' runN+    , test_scanr runN+    , test_scanr1 runN+    , test_scanr' runN+    , test_scanlSeg runN+    , test_scanl1Seg runN+    , test_scanl'Seg runN+    , test_scanrSeg runN+    , test_scanr1Seg runN+    , test_scanr'Seg runN+    , test_filter runN+    , test_stencil runN+    -- , test_replicate runN conf+    -- , test_sequences runN conf+    ]+
+ src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute+-- Copyright   : [2009..2017] 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.Test.NoFib.Prelude.Backpermute (++  test_backpermute++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Array.Sugar                            as S+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_backpermute :: RunN -> TestTree+test_backpermute runN =+  testGroup "backpermute"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestHalf)   $ testElt f16+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt+        :: forall a. (Similar a, Elt a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [+              testProperty "take"         $ test_take runN sh e+            , testProperty "drop"         $ test_drop runN sh e+            , testProperty "gather->DIM1" $ test_gather runN sh dim1 e+            , testProperty "gather->DIM2" $ test_gather runN sh dim2 e+            , testProperty "gather->DIM3" $ test_gather runN sh dim3 e+            ]++test_take+    :: (Shape sh, Slice sh, Similar e, P.Eq sh, Elt e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_take runN dim e =+  property $ do+    sh@(_:.n) <- forAll dim+    xs        <- forAll (array sh e)+    i         <- forAll (Gen.int (Range.linear 0 (n-1)))+    let !go = runN (\v -> A.take (the v)) in go (scalar i) xs ~~~ takeRef i xs++test_drop+    :: (Shape sh, Slice sh, Similar e, P.Eq sh, Elt e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_drop runN dim e =+  property $ do+    sh@(_:.n) <- forAll dim+    xs        <- forAll (array sh e)+    i         <- forAll (Gen.int (Range.linear 0 (n-1)))+    let !go = runN (\v -> A.drop (the v)) in go (scalar i) xs ~~~ dropRef i xs++test_gather+    :: (Shape sh, Shape sh', P.Eq sh', Similar e, Elt e)+    => RunN+    -> Gen sh+    -> Gen sh'+    -> Gen e+    -> Property+test_gather runN dim dim' e =+  property $ do+    sh  <- forAll (dim `except` \v -> S.size v P.== 0)+    sh' <- forAll dim'+    let+        n       = S.size sh+        n'      = S.size sh'+        toIxArr = fromList sh' . P.map (S.fromIndex sh)+    --+    xs  <- forAll (array sh e)+    ix  <- forAll (toIxArr <$> Gen.list (Range.singleton n') (Gen.int (Range.linear 0 (n-1))))+    --+    let !go = runN $ \i -> A.backpermute (A.shape i) (i A.!)+    --+    go ix xs ~~~ backpermuteRef sh' (ix S.!) xs+++scalar :: Elt e => e -> Scalar e+scalar x = fromFunction Z (const x)++backpermuteRef+    :: (Shape sh, Shape sh', Elt e)+    => sh'+    -> (sh' -> sh)+    -> Array sh  e+    -> Array sh' e+backpermuteRef sh' p arr =+  fromFunction sh' (\ix -> arr S.! p ix)++takeRef+    :: (Shape sh, Slice sh, Elt e)+    => Int+    -> Array (sh:.Int) e+    -> Array (sh:.Int) e+takeRef n arr =+  let sh :. m = S.shape arr+  in  fromFunction (sh :. P.min m n) (arr S.!)++dropRef+    :: (Shape sh, Slice sh, Elt e)+    => Int+    -> Array (sh:.Int) e+    -> Array (sh:.Int) e+dropRef n arr =+  let sh :. m = S.shape arr+  in  fromFunction (sh :. P.max 0 (m-n)) (\(sz:.i) -> arr S.! (sz :. i+n))+
+ src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE MonoLocalBinds      #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Prelude.Filter+-- Copyright   : [2009..2017] 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.Test.NoFib.Prelude.Filter (++  test_filter++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Array.Sugar                            as S+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog++import Test.Tasty+import Test.Tasty.Hedgehog+++test_filter :: RunN -> TestTree+test_filter runN =+  testGroup "filter"+    [ at (Proxy::Proxy TestInt8)   $ testIntegralElt i8+    , at (Proxy::Proxy TestInt16)  $ testIntegralElt i16+    , at (Proxy::Proxy TestInt32)  $ testIntegralElt i32+    , at (Proxy::Proxy TestInt64)  $ testIntegralElt i64+    , at (Proxy::Proxy TestWord8)  $ testIntegralElt w8+    , at (Proxy::Proxy TestWord16) $ testIntegralElt w16+    , at (Proxy::Proxy TestWord32) $ testIntegralElt w32+    , at (Proxy::Proxy TestWord64) $ testIntegralElt w64+    , at (Proxy::Proxy TestHalf)   $ testFloatingElt f16+    , at (Proxy::Proxy TestFloat)  $ testFloatingElt f32+    , at (Proxy::Proxy TestDouble) $ testFloatingElt f64+    ]+  where+    testIntegralElt+        :: forall a. (P.Integral a, A.Integral a, Similar a)+        => Gen a+        -> TestTree+    testIntegralElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "even"     $ test_even runN sh e+            ]++    testFloatingElt+        :: forall a. (P.Floating a, P.Ord a, A.Floating a, A.Ord a, Similar a)+        => Gen a+        -> TestTree+    testFloatingElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "positive" $ test_positive runN sh e+            ]+++test_even+    :: (Shape sh, Slice sh, Similar e, P.Eq sh, P.Integral e, A.Integral e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_even runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.filter A.even) in go xs ~~~ filterRef P.even xs++test_positive+    :: (Shape sh, Slice sh, Similar e, P.Eq sh, P.Num e, P.Ord e, A.Num e, A.Ord e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_positive runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.filter (A.> 0)) in go xs ~~~ filterRef (P.> 0) xs+++filterRef+    :: (Shape sh, Elt e)+    => (e -> Bool)+    -> Array (sh:.Int) e+    -> (Vector e, Array sh Int)+filterRef f arr = (fromList (Z:.total) (concat result), fromList sh len)+  where+    sh :. n   = S.shape arr+    result    = P.take (S.size sh) [ P.filter f sub | sub <- splitEvery n (toList arr) ]+    len       = P.map P.length result+    total     = P.sum len+
+ src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Prelude.Fold+-- Copyright   : [2009..2017] 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.Test.NoFib.Prelude.Fold (++  test_fold,+  test_foldSeg,++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_fold :: RunN -> TestTree+test_fold runN =+  testGroup "fold"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8  (Gen.int8   (Range.linearFrom 0 (-1) 1))+    , at (Proxy::Proxy TestInt16)  $ testElt i16 (Gen.int16  (Range.linearFrom 0 (-10) 10))+    , at (Proxy::Proxy TestInt32)  $ testElt i32 (Gen.int32  (Range.linearFrom 0 (-1000) 1000))+    , at (Proxy::Proxy TestInt64)  $ testElt i64 (Gen.int64  (Range.linearFrom 0 (-10000) 10000))+    , at (Proxy::Proxy TestWord8)  $ testElt w8  (Gen.word8  (Range.linear 0 1))+    , at (Proxy::Proxy TestWord16) $ testElt w16 (Gen.word16 (Range.linear 0 10))+    , at (Proxy::Proxy TestWord32) $ testElt w32 (Gen.word32 (Range.linear 0 1000))+    , at (Proxy::Proxy TestWord64) $ testElt w64 (Gen.word64 (Range.linear 0 10000))+    , at (Proxy::Proxy TestHalf)   $ testElt f16 f16+    , at (Proxy::Proxy TestFloat)  $ testElt f32 f32+    , at (Proxy::Proxy TestDouble) $ testElt f64 f64+    ]+  where+    testElt+        :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> Gen a+        -> TestTree+    testElt e small =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [+              testProperty "sum"              $ test_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_sum runN sh e e+            , testProperty "non-commutative"  $ test_mss runN sh small+            , testProperty "minimum"          $ test_minimum runN sh e+            , testProperty "maximum"          $ test_maximum runN sh e+            ]+++test_foldSeg :: RunN -> TestTree+test_foldSeg runN =+  testGroup "foldSeg"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [+              testProperty "sum"              $ test_segmented_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_segmented_sum runN sh e e+            , testProperty "minimum"          $ test_segmented_minimum runN sh e+            , testProperty "maximum"          $ test_segmented_maximum runN sh e+            ]+++scalar :: Elt e => e -> Scalar e+scalar x = fromFunction Z (const x)++test_sum+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e+    -> Property+test_sum runN dim z e =+  property $ do+    x  <- forAll z+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (\v -> A.fold (+) (the v)) in go (scalar x) xs ~~~ foldRef (+) x xs++test_mss+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, P.Ord e, A.Num e, A.Ord e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_mss runN dim e =+  property $ do+    sh <- forAll (dim `except` \(_:.v) -> v P.== 0)+    xs <- forAll (array sh e)+    let !go = runN maximumSegmentSum in go xs ~~~ maximumSegmentSumRef xs++test_minimum+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, P.Ord e, A.Num e, A.Ord e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_minimum runN dim e =+  property $ do+    sh <- forAll (dim `except` \(_:.v) -> v P.== 0)+    xs <- forAll (array sh e)+    let !go = runN A.minimum in go xs ~~~ fold1Ref P.min xs++test_maximum+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, P.Ord e, A.Num e, A.Ord e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_maximum runN dim e =+  property $ do+    sh <- forAll (dim `except` \(_:.v) -> v P.== 0)+    xs <- forAll (array sh e)+    let !go = runN A.maximum in go xs ~~~ fold1Ref P.max xs++test_segmented_sum+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e+    -> Property+test_segmented_sum runN dim z e =+  property $ do+    x       <- forAll z+    sh:.n1  <- forAll dim+    n2      <- forAll (Gen.int (Range.linear 0 64))+    n       <- return (P.min n1 n2) -- don't generate too many segments+    seg     <- forAll (array (Z:.n) (Gen.int (Range.linear 0 (128 `quot` 2 P.^ (rank (undefined::sh))))))+    xs      <- forAll (array (sh:.P.sum (toList seg)) e)+    let !go = runN (\v -> A.foldSeg (+) (the v)) in go (scalar x) xs seg ~~~ foldSegRef (+) x xs seg++test_segmented_minimum+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.Num e, P.Ord e, A.Num e, A.Ord e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_segmented_minimum runN dim e =+  property $ do+    sh:.n1  <- forAll dim+    n2      <- forAll (Gen.int (Range.linear 0 64))+    n       <- return (P.min n1 n2) -- don't generate too many segments+    seg     <- forAll (array (Z:.n) (Gen.int (Range.linear 1 (128 `quot` 2 P.^ (rank (undefined::sh))))))+    xs      <- forAll (array (sh:.P.sum (toList seg)) e)+    let !go = runN (A.fold1Seg A.min) in go xs seg ~~~ fold1SegRef P.min xs seg++test_segmented_maximum+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.Num e, P.Ord e, A.Num e, A.Ord e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_segmented_maximum runN dim e =+  property $ do+    sh:.n1  <- forAll dim+    n2      <- forAll (Gen.int (Range.linear 0 64))+    n       <- return (P.min n1 n2) -- don't generate too many segments+    seg     <- forAll (array (Z:.n) (Gen.int (Range.linear 1 (128 `quot` 2 P.^ (rank (undefined::sh))))))+    xs      <- forAll (array (sh:.P.sum (toList seg)) e)+    let !go = runN (A.fold1Seg A.max) in go xs seg ~~~ fold1SegRef P.max xs seg+++-- Reference implementation+-- ------------------------++foldRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh :. Int) e+    -> Array sh e+foldRef f z arr =+  let (sh :. n) = arrayShape arr+  in  fromList sh [ foldl f z sub | sub <- splitEvery n (toList arr) ]++fold1Ref+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> Array (sh :. Int) e+    -> Array sh e+fold1Ref f arr =+  let (sh :. n) = arrayShape arr+  in  fromList sh [ foldl1 f sub | sub <- splitEvery n (toList arr) ]++foldSegRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh :. Int) e+    -> Segments Int+    -> Array (sh :. Int) e+foldSegRef f z arr seg =+  let+      (sh :. n)   = arrayShape arr+      (Z  :. sz)  = arrayShape seg+      seg'        = toList seg+      arr'        = [ foldl f z sec | sub <- splitEvery n (toList arr)+                                    , sec <- splitPlaces seg' sub ]+  in+  fromList (sh :. sz) arr'++fold1SegRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> Array (sh :. Int) e+    -> Segments Int+    -> Array (sh :. Int) e+fold1SegRef f arr seg =+  let+      (sh :. n)   = arrayShape arr+      (Z  :. sz)  = arrayShape seg+      seg'        = toList seg+      arr'        = [ foldl1 f sec | sub <- splitEvery n (toList arr)+                                   , sec <- splitPlaces seg' sub ]+  in+  fromList (sh :. sz) arr'++maximumSegmentSum+    :: forall sh e. (Shape sh, A.Num e, A.Ord e)+    => Acc (Array (sh :. Int) e)+    -> Acc (Array sh e)+maximumSegmentSum+  = A.map (\v -> let (x,_,_,_) = unlift v :: (Exp e, Exp e, Exp e, Exp e) in x)+  . A.fold1 f+  . A.map g+  where+    f :: (A.Num a, A.Ord a) => Exp (a,a,a,a) -> Exp (a,a,a,a) -> Exp (a,a,a,a)+    f x y =+      let (mssx, misx, mcsx, tsx) = unlift x+          (mssy, misy, mcsy, tsy) = unlift y+      in+      lift ( mssx `A.max` (mssy `A.max` (mcsx+misy))+           , misx `A.max` (tsx+misy)+           , mcsy `A.max` (mcsx+tsy)+           , tsx+tsy+           )++    g :: (A.Num a, A.Ord a) => Exp a -> Exp (a,a,a,a)+    g x = let y = A.max x 0+          in  lift (y,y,y,x)++maximumSegmentSumRef+    :: (P.Num e, P.Ord e, Shape sh, Elt e)+    => Array (sh :. Int) e+    -> Array sh e+maximumSegmentSumRef arr = fromList sh [ go 0 0 sub | sub <- splitEvery n (toList arr) ]+  where+    sh :. n       = arrayShape arr+    --+    go _ v []     = v+    go u v (x:xs) =+      let u' = 0 `P.max` (u+x)+          v' = v `P.max` u'+      in+      go u' v' xs+
+ src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE MonoLocalBinds      #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Prelude.Map+-- Copyright   : [2009..2017] 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.Test.NoFib.Prelude.Map (++  test_map++) where++import Data.Proxy+import Data.Bits                                                    as P+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Data.Bits                              as A+import Data.Array.Accelerate.Array.Sugar                            as Sugar+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_map :: RunN -> TestTree+test_map runN =+  testGroup "map"+    [ at (Proxy::Proxy TestInt8)   $ testIntegralElt i8+    , at (Proxy::Proxy TestInt16)  $ testIntegralElt i16+    , at (Proxy::Proxy TestInt32)  $ testIntegralElt i32+    , at (Proxy::Proxy TestInt64)  $ testIntegralElt i64+    , at (Proxy::Proxy TestWord8)  $ testIntegralElt w8+    , at (Proxy::Proxy TestWord16) $ testIntegralElt w16+    , at (Proxy::Proxy TestWord32) $ testIntegralElt w32+    , at (Proxy::Proxy TestWord64) $ testIntegralElt w64+    , at (Proxy::Proxy TestHalf)   $ testFloatingElt (Gen.realFloat :: Range Half -> Gen Half)+    , at (Proxy::Proxy TestFloat)  $ testFloatingElt Gen.float+    , at (Proxy::Proxy TestDouble) $ testFloatingElt Gen.double+    ]+  where+    testIntegralElt+        :: forall a. ( P.Integral a, P.FiniteBits a+                     , A.Integral a, A.FiniteBits a+                     , A.FromIntegral a Double, Similar a )+        => Gen a+        -> TestTree+    testIntegralElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim0+        , testDim dim1+        , testDim dim2+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen sh+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::sh)))+            [ -- operators on Num+              testProperty "neg"                $ test_negate runN sh e+            , testProperty "abs"                $ test_abs runN sh e+            , testProperty "signum"             $ test_signum runN sh e++              -- operators on Integral & Bits+            , testProperty "complement"         $ test_complement runN sh e+            , testProperty "popCount"           $ test_popCount runN sh e+            , testProperty "countLeadingZeros"  $ test_countLeadingZeros runN sh e+            , testProperty "countTrailingZeros" $ test_countTrailingZeros runN sh e++              -- conversions+            , testProperty "fromIntegral"       $ test_fromIntegral runN sh e+            ]++    testFloatingElt+        :: forall a. (P.RealFloat a, A.Floating a, A.RealFrac a, Similar a)+        => (Range a -> Gen a)+        -> TestTree+    testFloatingElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim0+        , testDim dim1+        , testDim dim2+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen sh+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::sh)))+            [ -- operators on Num+              testProperty "neg"        $ test_negate runN sh (fullrange e)+            , testProperty "abs"        $ test_abs runN sh (fullrange e)+            , testProperty "signum"     $ test_abs runN sh (fullrange e)++              -- operators on Fractional, Floating, RealFrac & RealFloat+            , testProperty "recip"      $ test_recip runN sh (fullrange e)+            , testProperty "sin"        $ test_sin runN sh (fullrange e)+            , testProperty "cos"        $ test_cos runN sh (fullrange e)+            , testProperty "tan"        $ test_tan runN sh (fullrange e `except` \v -> cos v ~= 0)+            , testProperty "asin"       $ test_asin runN sh (e (Range.linearFracFrom 0 (-1) 1))+            , testProperty "acos"       $ test_acos runN sh (e (Range.linearFracFrom 0 (-1) 1))+            , testProperty "atan"       $ test_atan runN sh (fullrange e)+            , testProperty "asinh"      $ test_asinh runN sh (e (Range.linearFracFrom 0 (-log_flt_max) (log_flt_max)))+            , testProperty "acosh"      $ test_acosh runN sh (e (Range.linearFrac 1 (sqrt flt_max)))+            , testProperty "atanh"      $ test_atanh runN sh (e (Range.linearFracFrom 0 (-1) 1))+            , testProperty "exp"        $ test_exp runN sh (fullrange e)+            , testProperty "sqrt"       $ test_sqrt runN sh (e (Range.linearFrac 0 flt_max))+            , testProperty "log"        $ test_log runN sh (e (Range.linearFrac 0 flt_max) `except` \v -> v P.== 0)+            , testProperty "truncate"   $ test_truncate runN sh (e (Range.linearFracFrom 0 (P.fromIntegral (minBound :: Int)) (P.fromIntegral (maxBound :: Int))))+            , testProperty "round"      $ test_round runN sh (e (Range.linearFracFrom 0 (P.fromIntegral (minBound :: Int)) (P.fromIntegral (maxBound :: Int))))+            , testProperty "floor"      $ test_floor runN sh (e (Range.linearFracFrom 0 (P.fromIntegral (minBound :: Int)) (P.fromIntegral (maxBound :: Int))))+            , testProperty "ceiling"    $ test_ceiling runN sh (e (Range.linearFracFrom 0 (P.fromIntegral (minBound :: Int)) (P.fromIntegral (maxBound :: Int))))+            ]++        -- NOTE: [asinh and acosh]+        --+        -- GHC uses an approximation for asinh and acosh which gives incorrect+        -- answers for extremely large values. I guess I should submit a bug+        -- report for that, but "for now" just test with a reduced range.++        fullrange :: P.RealFloat e => (Range e -> Gen e) -> Gen e+        fullrange gen = gen (Range.linearFracFrom 0 (-flt_max) flt_max)+++test_negate+    :: (Shape sh, Similar e, A.Num e, P.Num e, P.Eq sh)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_negate runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map negate) in go xs ~~~ mapRef negate xs++test_abs+    :: (Shape sh, Similar e, A.Num e, P.Num e, P.Eq sh)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_abs runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map abs) in go xs ~~~ mapRef abs xs++test_signum+    :: (Shape sh, Similar e, A.Num e, P.Num e, P.Eq sh)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_signum runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map signum) in go xs ~~~ mapRef signum xs++test_complement+    :: (Shape sh, Similar e, A.Bits e, P.Bits e, P.Eq sh)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_complement runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map A.complement) in go xs ~~~ mapRef P.complement xs++test_popCount+    :: (Shape sh, Similar e, A.Bits e, P.Bits e, P.Eq sh)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_popCount runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map A.popCount) in go xs ~~~ mapRef P.popCount xs++test_countLeadingZeros+    :: (Shape sh, Similar e, A.FiniteBits e, P.FiniteBits e, P.Eq sh)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_countLeadingZeros runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map A.countLeadingZeros) in go xs ~~~ mapRef countLeadingZerosRef xs++test_countTrailingZeros+    :: (Shape sh, Similar e, A.FiniteBits e, P.FiniteBits e, P.Eq sh)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_countTrailingZeros runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map A.countTrailingZeros) in go xs ~~~ mapRef countTrailingZerosRef xs++test_fromIntegral+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.Integral e, A.Integral e, A.FromIntegral e Double)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_fromIntegral runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map A.fromIntegral) in go xs ~~~ mapRef (P.fromIntegral :: e -> Double) xs++test_recip+    :: (Shape sh, Similar e, P.Eq sh, P.Fractional e, A.Fractional e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_recip runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map recip) in go xs ~~~ mapRef recip xs++test_sin+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_sin runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map sin) in go xs ~~~ mapRef sin xs++test_cos+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_cos runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map cos) in go xs ~~~ mapRef cos xs++test_tan+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_tan runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map tan) in go xs ~~~ mapRef tan xs++test_asin+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_asin runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map asin) in go xs ~~~ mapRef asin xs++test_acos+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_acos runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map acos) in go xs ~~~ mapRef acos xs++test_atan+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_atan runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map atan) in go xs ~~~ mapRef atan xs++test_asinh+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_asinh runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map asinh) in go xs ~~~ mapRef asinh xs++test_acosh+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_acosh runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map acosh) in go xs ~~~ mapRef acosh xs++test_atanh+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_atanh runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map atanh) in go xs ~~~ mapRef atanh xs++test_exp+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_exp runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map exp) in go xs ~~~ mapRef exp xs++test_sqrt+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_sqrt runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map sqrt) in go xs ~~~ mapRef sqrt xs++test_log+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_log runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map log) in go xs ~~~ mapRef log xs++test_truncate+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.RealFrac e, A.RealFrac e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_truncate runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map A.truncate) in go xs ~~~ mapRef (P.truncate :: e -> Int) xs++test_round+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.RealFrac e, A.RealFrac e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_round runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map A.round) in go xs ~~~ mapRef (P.round :: e -> Int) xs++test_floor+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.RealFrac e, A.RealFrac e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_floor runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map A.floor) in go xs ~~~ mapRef (P.floor :: e -> Int) xs++test_ceiling+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.RealFrac e, A.RealFrac e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_ceiling runN dim e =+  property $ do+    sh <- forAll dim+    xs <- forAll (array sh e)+    let !go = runN (A.map A.ceiling) in go xs ~~~ mapRef (P.ceiling :: e -> Int) xs+++-- Reference Implementation+-- ------------------------++mapRef :: (Shape sh, Elt b) => (a -> b) -> Array sh a -> Array sh b+mapRef f xs = fromFunction (arrayShape xs) (\ix -> f (xs Sugar.! ix))++countLeadingZerosRef :: P.FiniteBits a => a -> Int+#if __GLASGOW_HASKELL__ >= 710+countLeadingZerosRef = P.countLeadingZeros+#else+countLeadingZerosRef = clz+  where+    clz x = (w-1) - go (w-1)+      where+        go i | i < 0         = i  -- no bit set+             | P.testBit x i = i+             | otherwise     = go (i-1)+        w = P.finiteBitSize x+#endif++countTrailingZerosRef :: P.FiniteBits a => a -> Int+#if __GLASGOW_HASKELL__ >= 710+countTrailingZerosRef = P.countTrailingZeros+#else+countTrailingZerosRef = ctz+  where+    ctz x = go 0+      where+        go i | i >= w        = i+             | P.testBit x i = i+             | otherwise     = go (i+1)+        w = P.finiteBitSize x+#endif+
+ src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Prelude.Permute+-- Copyright   : [2009..2017] 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.Test.NoFib.Prelude.Permute (++  test_permute++) where++import Control.Monad+import Data.Proxy+import Data.Typeable+import System.IO.Unsafe+import Prelude                                                      as P+import qualified Data.Set                                           as Set++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Array.Sugar                            as S+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_permute :: RunN -> TestTree+test_permute runN =+  testGroup "permute"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestHalf)   $ testElt f16+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt+        :: forall a. (Similar a, P.Num a, A.Num a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [+              testProperty "scatter->DIM1"      $ test_scatter runN sh dim1 e+            , testProperty "scatter->DIM2"      $ test_scatter runN sh dim2 e+            , testProperty "scatter->DIM3"      $ test_scatter runN sh dim3 e+            , testProperty "accumulate->DIM1"   $ test_accumulate runN sh dim1 e+            , testProperty "accumulate->DIM2"   $ test_accumulate runN sh dim2 e+            , testProperty "accumulate->DIM3"   $ test_accumulate runN sh dim3 e+            ]+++test_scatter+    :: forall sh sh' e. (Shape sh, Shape sh', P.Eq sh', Similar e, Elt e)+    => RunN+    -> Gen sh+    -> Gen sh'+    -> Gen e+    -> Property+test_scatter runN dim dim' e =+  property $ do+    sh  <- forAll dim+    sh' <- forAll (dim' `except` \v -> S.size v P.== 0)+    let+        n   = S.size sh+        n'  = S.size sh'+        --+        shfl seen i+          | i P.>= n  = return []+          | otherwise = do+              t  <- Gen.choice [ return  (-1)+                               , Gen.int (Range.linear 0 (n'-1))+                               ]+              ts <- shfl (Set.insert t seen) (i+1)+              --+              case Set.member t seen of+                True  -> return (S.ignore          : ts)+                False -> return (S.fromIndex sh' t : ts)+    --+    def <- forAll (array sh' e)+    new <- forAll (array sh  e)+    ix  <- forAll (fromList sh <$> shfl (Set.singleton (-1)) 0)+    --+    let !go = runN $ \i d v -> A.permute const d (i A.!) v+    go ix def new ~~~ permuteRef const def (ix S.!) new+++test_accumulate+    :: (Shape sh, Shape sh', P.Eq sh', Similar e, P.Num e, A.Num e)+    => RunN+    -> Gen sh+    -> Gen sh'+    -> Gen e+    -> Property+test_accumulate runN dim dim' e =+  property $ do+    sh  <- forAll dim+    sh' <- forAll (dim' `except` \v -> S.size v P.== 0)+    let+        n'  = S.size sh'+        def = S.fromFunction sh' (const 0)+    --+    xs  <- forAll (array sh e)+    ix  <- forAll (array sh (Gen.choice [ return S.ignore+                                        , S.fromIndex sh' <$> Gen.int (Range.linear 0 (n'-1))+                                        ]))+    let !go = runN $ \i d v -> A.permute (+) d (i A.!) v+    go ix def xs ~~~ permuteRef (+) def (ix S.!) xs+++permuteRef+    :: (Shape sh, Shape sh', P.Eq sh', Elt e)+    => (e -> e -> e)+    -> Array sh' e+    -> (sh -> sh')+    -> Array sh e+    -> Array sh' e+permuteRef f def@(Array _ aold) p arr@(Array _ anew) =+  unsafePerformIO $ do+    let+        sh  = S.shape arr+        sh' = S.shape def+        n   = S.size sh+        --+        go !i+          | i P.>= n  = return ()+          | otherwise = do+              let ix  = S.fromIndex sh i+                  ix' = p ix+              --+              unless (ix' P.== S.ignore) $ do+                let i'  = S.toIndex sh' ix'+                x  <- toElt <$> unsafeReadArrayData anew i+                x' <- toElt <$> unsafeReadArrayData aold i'+                unsafeWriteArrayData aold i' (fromElt (f x x'))+              --+              go (i+1)+    --+    go 0+    return def+
+ src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs view
@@ -0,0 +1,929 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Prelude.Scan+-- Copyright   : [2009..2017] 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.Test.NoFib.Prelude.Scan (++  test_scanl, test_scanlSeg,+  test_scanl1, test_scanl1Seg,+  test_scanl', test_scanl'Seg,++  test_scanr, test_scanrSeg,+  test_scanr1, test_scanr1Seg,+  test_scanr', test_scanr'Seg,++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Array.Sugar                            as S+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_scanl :: RunN -> TestTree+test_scanl runN =+  testGroup "scanl"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestHalf)   $ testElt f16+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt+        :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanl_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_scanl_sum runN sh e e+            , testProperty "non-commutative"  $ test_scanl_interval runN sh e+            ]++test_scanl1 :: RunN -> TestTree+test_scanl1 runN =+  testGroup "scanl1"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanl1_sum runN sh e+            , testProperty "non-commutative"  $ test_scanl1_interval runN sh e+            ]++test_scanl' :: RunN -> TestTree+test_scanl' runN =+  testGroup "scanl'"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanl'_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_scanl'_sum runN sh e e+            , testProperty "non-commutative"  $ test_scanl'_interval runN sh e+            ]++test_scanr :: RunN -> TestTree+test_scanr runN =+  testGroup "scanr"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanr_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_scanr_sum runN sh e e+            , testProperty "non-commutative"  $ test_scanr_interval runN sh e+            ]++test_scanr1 :: RunN -> TestTree+test_scanr1 runN =+  testGroup "scanr1"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanr1_sum runN sh e+            , testProperty "non-commutative"  $ test_scanr1_interval runN sh e+            ]++test_scanr' :: RunN -> TestTree+test_scanr' runN =+  testGroup "scanr'"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanr'_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_scanr'_sum runN sh e e+            , testProperty "non-commutative"  $ test_scanr'_interval runN sh e+            ]++test_scanlSeg :: RunN -> TestTree+test_scanlSeg runN =+  testGroup "scanlSeg"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanlSeg_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_scanlSeg_sum runN sh e e+            ]++test_scanl1Seg :: RunN -> TestTree+test_scanl1Seg runN =+  testGroup "scanl1Seg"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"  $ test_scanl1Seg_sum runN sh e+            ]++test_scanl'Seg :: RunN -> TestTree+test_scanl'Seg runN =+  testGroup "scanl'Seg"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanl'Seg_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_scanl'Seg_sum runN sh e e+            ]++test_scanrSeg :: RunN -> TestTree+test_scanrSeg runN =+  testGroup "scanrSeg"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanrSeg_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_scanrSeg_sum runN sh e e+            ]++test_scanr1Seg :: RunN -> TestTree+test_scanr1Seg runN =+  testGroup "scanr1Seg"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"  $ test_scanr1Seg_sum runN sh e+            ]++test_scanr'Seg :: RunN -> TestTree+test_scanr'Seg runN =+  testGroup "scanr'Seg"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim1+        , testDim dim2+        , testDim dim3+        ]+      where+        testDim+            :: forall sh. (Shape sh, Slice sh, P.Eq sh)+            => Gen (sh:.Int)+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::(sh:.Int))))+            [ testProperty "sum"              $ test_scanr'Seg_sum runN sh (return 0) e+            , testProperty "non-neutral sum"  $ test_scanr'Seg_sum runN sh e e+            ]+++scalar :: Elt e => e -> Scalar e+scalar x = fromFunction Z (const x)++test_scanl_sum+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e+    -> Property+test_scanl_sum runN dim z e =+  property $ do+    x   <- forAll z+    sh  <- forAll dim+    arr <- forAll (array sh e)+    let !go = runN (\v -> A.scanl (+) (the v)) in go (scalar x) arr ~~~ scanlRef (+) x arr++test_scanl1_sum+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanl1_sum runN dim e =+  property $ do+    sh  <- forAll (dim `except` \(_:.n) -> n P.== 0)+    arr <- forAll (array sh e)+    let !go = runN (A.scanl1 (+)) in go arr ~~~ scanl1Ref (+) arr++test_scanl'_sum+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e+    -> Property+test_scanl'_sum runN dim z e =+  property $ do+    x   <- forAll z+    sh  <- forAll dim+    arr <- forAll (array sh e)+    let !go = runN (\v -> A.scanl' (+) (the v)) in go (scalar x) arr ~~~ scanl'Ref (+) x arr++test_scanr_sum+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e -> Property+test_scanr_sum runN dim z e =+  property $ do+    x   <- forAll z+    sh  <- forAll dim+    arr <- forAll (array sh e)+    let !go = runN (\v -> A.scanr (+) (the v)) in go (scalar x) arr ~~~ scanrRef (+) x arr++test_scanr1_sum+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanr1_sum runN dim e =+  property $ do+    sh  <- forAll (dim `except` \(_:.n) -> n P.== 0)+    arr <- forAll (array sh e)+    let !go = runN (A.scanr1 (+)) in go arr ~~~ scanr1Ref (+) arr++test_scanr'_sum+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e+    -> Property+test_scanr'_sum runN dim z e =+  property $ do+    x   <- forAll z+    sh  <- forAll dim+    arr <- forAll (array sh e)+    let !go = runN (\v -> A.scanr' (+) (the v)) in go (scalar x) arr ~~~ scanr'Ref (+) x arr++test_scanl_interval+    :: (Shape sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanl_interval runN dim e =+  property $ do+    sh :. n <- forAll (dim `except` \(_:.n) -> n P.== 0)+    let arr  = intervalArray sh n e+    let !go = runN (A.scanl iappend (constant one)) in go arr ~~~ scanlRef iappendRef one arr++test_scanl1_interval+    :: (Shape sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanl1_interval runN dim e =+  property $ do+    sh :. n <- forAll (dim `except` \v -> S.size v P.== 0)+    let arr  = intervalArray sh n e+    let !go = runN (A.scanl1 iappend) in go arr ~~~ scanl1Ref iappendRef arr++test_scanl'_interval+    :: (Shape sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanl'_interval runN dim e =+  property $ do+    sh :. n <- forAll (dim `except` \(_:.n) -> n P.== 0)+    let arr  = intervalArray sh n e+    let !go = runN (A.scanl' iappend (constant one)) in go arr ~~~ scanl'Ref iappendRef one arr++test_scanr_interval+    :: (Shape sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanr_interval runN dim e =+  property $ do+    sh :. n <- forAll (dim `except` \(_:.n) -> n P.== 0)+    let arr  = intervalArray sh n e+    let !go = runN (A.scanr iappend (constant one)) in go arr ~~~ scanrRef iappendRef one arr++test_scanr1_interval+    :: (Shape sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanr1_interval runN dim e =+  property $ do+    sh :. n <- forAll (dim `except` \(_:.n) -> n P.== 0)+    let arr  = intervalArray sh n e+    let !go = runN (A.scanr1 iappend) in go arr ~~~ scanr1Ref iappendRef arr++test_scanr'_interval+    :: (Shape sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanr'_interval runN dim e =+  property $ do+    sh :. n <- forAll (dim `except` \(_:.n) -> n P.== 0)+    let arr  = intervalArray sh n e+    let !go = runN (A.scanr' iappend (constant one)) in go arr ~~~ scanr'Ref iappendRef one arr++test_scanlSeg_sum+    :: forall sh e. (Shape sh, Slice sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e+    -> Property+test_scanlSeg_sum runN dim z e =+  property $ do+    x       <- forAll z+    sh:.n1  <- forAll dim+    n2      <- forAll (Gen.int (Range.linear 0 64))+    n       <- return (P.min n1 n2) -- don't generate too many segments+    seg     <- forAll (array (Z:.n) (Gen.int (Range.linear 0 (128 `quot` 2 P.^ (rank (undefined::sh))))))+    arr     <- forAll (array (sh:.P.sum (toList seg)) e)+    let !go = runN (\v -> A.scanlSeg (+) (the v)) in go (scalar x) arr seg ~~~ scanlSegRef (+) x arr seg++test_scanl1Seg_sum+    :: forall sh e. (Shape sh, Slice sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanl1Seg_sum runN dim e =+  property $ do+    sh:.n1  <- forAll (dim `except` \v -> S.size v P.== 0)+    n2      <- forAll (Gen.int (Range.linear 1 64))+    n       <- return (P.min n1 n2) -- don't generate too many segments+    seg     <- forAll (array (Z:.n) (Gen.int (Range.linear 1 (128 `quot` 2 P.^ (rank (undefined::sh))))))+    arr     <- forAll (array (sh:.P.sum (toList seg)) e)+    let !go = runN (A.scanl1Seg (+)) in go arr seg ~~~ scanl1SegRef (+) arr seg++test_scanl'Seg_sum+    :: forall sh e. (Shape sh, Slice sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e+    -> Property+test_scanl'Seg_sum runN dim z e =+  property $ do+    x       <- forAll z+    sh:.n1  <- forAll dim+    n2      <- forAll (Gen.int (Range.linear 0 64))+    n       <- return (P.min n1 n2) -- don't generate too many segments+    seg     <- forAll (array (Z:.n) (Gen.int (Range.linear 0 (128 `quot` 2 P.^ (rank (undefined::sh))))))+    arr     <- forAll (array (sh:.P.sum (toList seg)) e)+    let !go = runN (\v -> A.scanl'Seg (+) (the v)) in go (scalar x) arr seg ~~~ scanl'SegRef (+) x arr seg++test_scanrSeg_sum+    :: forall sh e. (Shape sh, Slice sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e+    -> Property+test_scanrSeg_sum runN dim z e =+  property $ do+    x       <- forAll z+    sh:.n1  <- forAll dim+    n2      <- forAll (Gen.int (Range.linear 0 64))+    n       <- return (P.min n1 n2) -- don't generate too many segments+    seg     <- forAll (array (Z:.n) (Gen.int (Range.linear 0 (128 `quot` 2 P.^ (rank (undefined::sh))))))+    arr     <- forAll (array (sh:.P.sum (toList seg)) e)+    let !go = runN (\v -> A.scanrSeg (+) (the v)) in go (scalar x) arr seg ~~~ scanrSegRef (+) x arr seg++test_scanr1Seg_sum+    :: forall sh e. (Shape sh, Slice sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Property+test_scanr1Seg_sum runN dim e =+  property $ do+    sh:.n1  <- forAll (dim `except` \v -> S.size v P.== 0)+    n2      <- forAll (Gen.int (Range.linear 1 64))+    n       <- return (P.min n1 n2) -- don't generate too many segments+    seg     <- forAll (array (Z:.n) (Gen.int (Range.linear 1 (128 `quot` 2 P.^ (rank (undefined::sh))))))+    arr     <- forAll (array (sh:.P.sum (toList seg)) e)+    let !go = runN (A.scanr1Seg (+)) in go arr seg ~~~ scanr1SegRef (+) arr seg++test_scanr'Seg_sum+    :: forall sh e. (Shape sh, Slice sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen (sh:.Int)+    -> Gen e+    -> Gen e+    -> Property+test_scanr'Seg_sum runN dim z e =+  property $ do+    x       <- forAll z+    sh:.n1  <- forAll dim+    n2      <- forAll (Gen.int (Range.linear 0 64))+    n       <- return (P.min n1 n2) -- don't generate too many segments+    seg     <- forAll (array (Z:.n) (Gen.int (Range.linear 0 (128 `quot` 2 P.^ (rank (undefined::sh))))))+    arr     <- forAll (array (sh:.P.sum (toList seg)) e)+    let !go = runN (\v -> A.scanr'Seg (+) (the v)) in go (scalar x) arr seg ~~~ scanr'SegRef (+) x arr seg+++-- Interval of summations monoid+--+one, top :: P.Num e => (e,e)+one = (-1,-1)+top = (-2,-2)++iappendRef :: (P.Num e, P.Eq e) => (e,e) -> (e,e) -> (e,e)+iappendRef x y+  | x P.== one                 = y+  | y P.== one                 = x+  | x P.== top P.|| y P.== top = top+iappendRef (x1,x2) (y1,y2)+  | x2 + 1 P.== y1             = (x1,y2)+  | otherwise                  = top++iappend :: forall e. (A.Eq e, A.Num e, P.Num e) => Exp (e,e) -> Exp (e,e) -> Exp (e,e)+iappend x y+  = x A.== constant one ? ( y+  , y A.== constant one ? ( x+  , x A.== constant top ? ( constant top -- A.|| y A.== constant top; see AccelerateHS/accelerate#364+  , let+        (x1,x2) = unlift x :: (Exp e, Exp e)+        (y1,y2) = unlift y :: (Exp e, Exp e)+    in+    x2 + 1 A.== y1 ? ( lift (x1,y2) , constant top )+  )))++intervalArray :: (Shape sh, Elt e, P.Num e) => sh -> Int -> proxy e -> Array (sh:.Int) (e,e)+intervalArray sh n _ = fromFunction (sh:.n) (\(_:.i) -> let x = P.fromIntegral i in (x,x))+++-- Reference implementation+-- ------------------------++scanlRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh:.Int) e+    -> Array (sh:.Int) e+scanlRef f z arr =+  let sz :. n     = arrayShape arr+      arr'        = [ P.scanl f z sub | sub <- splitEvery n (toList arr) ]+  in+  A.fromList (sz :. n+1) (concat arr')++scanl'Ref+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh:.Int) e+    -> (Array (sh:.Int) e, Array sh e)+scanl'Ref f z arr =+  let sz :. n     = arrayShape arr+      (arr',sums) = P.unzip [ P.splitAt n (P.scanl f z sub) | sub <- splitEvery n (toList arr) ]+  in+  ( A.fromList (sz:.n) (concat arr'), A.fromList sz (concat sums) )++scanl1Ref+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> Array (sh:.Int) e+    -> Array (sh:.Int) e+scanl1Ref f arr =+  let sz :. n     = arrayShape arr+      arr'        = [ P.scanl1 f sub | sub <- splitEvery n (toList arr) ]+  in+  A.fromList (sz:.n) (concat arr')++scanrRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh:.Int) e+    -> Array (sh:.Int) e+scanrRef f z arr =+  let sz :. n     = arrayShape arr+      arr'        = [ P.scanr f z sub | sub <- splitEvery n (toList arr) ]+  in+  A.fromList (sz :. n+1) (concat arr')++scanr'Ref+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh:.Int) e+    -> (Array (sh:.Int) e, Array sh e)+scanr'Ref f z arr =+  let sz :. n     = arrayShape arr+      (sums,arr') = P.unzip [ P.splitAt 1 (P.scanr f z sub) | sub <- splitEvery n (toList arr) ]+  in+  ( A.fromList (sz:.n) (concat arr'), A.fromList sz (concat sums) )++scanr1Ref+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> Array (sh:.Int) e+    -> Array (sh:.Int) e+scanr1Ref f arr =+  let sz :. n     = arrayShape arr+      arr'        = [ P.scanr1 f sub | sub <- splitEvery n (toList arr) ]+  in+  A.fromList (sz:.n) (concat arr')+++-- segmented operations+--+scanlSegRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh:.Int) e+    -> Segments Int+    -> Array (sh:.Int) e+scanlSegRef f z arr seg =+  let+      sz :. n   = arrayShape arr+      seg'      = toList seg+      n'        = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg'+      arr'      = [ P.scanl f z sec | sub <- splitEvery n (toList arr)+                                    , sec <- splitPlaces seg' sub ]+  in+  A.fromList (sz:.n') (concat arr')++scanl1SegRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> Array (sh:.Int) e+    -> Segments Int+    -> Array (sh:.Int) e+scanl1SegRef f arr seg =+  let+      sz :. n   = arrayShape arr+      seg'      = toList seg+      n'        = P.fromIntegral (P.sum seg')+      arr'      = [ P.scanl1 f sec | sub <- splitEvery n (toList arr)+                                   , sec <- splitPlaces seg' sub ]+  in+  A.fromList (sz:.n') (concat arr')++scanl'SegRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh:.Int) e+    -> Segments Int+    -> (Array (sh:.Int) e, Array (sh:.Int) e)+scanl'SegRef f z arr seg =+  let+      sz :. n     = arrayShape arr+      Z  :. s     = arrayShape seg+      scanl'_ v   = P.splitAt (P.length v) (P.scanl f z v)+      (arr',sums) = P.unzip [ scanl'_ sec | sub <- splitEvery n (toList arr)+                                          , sec <- splitPlaces (toList seg) sub ]+  in+  ( A.fromList (sz:.n) (concat arr'), A.fromList (sz:.s) (concat sums) )++scanrSegRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh:.Int) e+    -> Segments Int+    -> Array (sh:.Int) e+scanrSegRef f z arr seg =+  let+      sz :. n   = arrayShape arr+      seg'      = toList seg+      n'        = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg'+      arr'      = [ P.scanr f z sec | sub <- splitEvery n (toList arr)+                                    , sec <- splitPlaces seg' sub ]+  in+  A.fromList (sz:.n') (concat arr')++scanr1SegRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> Array (sh:.Int) e+    -> Segments Int+    -> Array (sh:.Int) e+scanr1SegRef f arr seg =+  let sz :. n   = arrayShape arr+      seg'      = toList seg+      n'        = P.fromIntegral (P.sum seg')+      arr'      = [ P.scanr1 f sec | sub <- splitEvery n (toList arr)+                                   , sec <- splitPlaces seg' sub ]+  in+  A.fromList (sz:.n') (concat arr')++scanr'SegRef+    :: (Shape sh, Elt e)+    => (e -> e -> e)+    -> e+    -> Array (sh:.Int) e+    -> Segments Int+    -> (Array (sh:.Int) e, Array (sh:.Int) e)+scanr'SegRef f z arr seg =+  let+      sz :. n       = arrayShape arr+      Z  :. s       = arrayShape seg+      (sums, arr')  = P.unzip [ P.splitAt 1 (P.scanr f z sec) | sub <- splitEvery n (toList arr)+                                                              , sec <- splitPlaces (toList seg) sub ]+  in+  ( A.fromList (sz:.n) (concat arr'), A.fromList (sz:.s) (concat sums) )+
+ src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs view
@@ -0,0 +1,662 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Prelude.Stencil+-- Copyright   : [2009..2017] 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.Test.NoFib.Prelude.Stencil (++  test_stencil++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Array.Sugar                            as S+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_stencil :: RunN -> TestTree+test_stencil runN =+  testGroup "stencil"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    , at (Proxy::Proxy TestHalf)   $ testElt f16+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt+        :: forall a. (P.Num a, A.Num a, Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim1+        , testDim2+        , testDim3+        ]+      where+        testDim1 :: TestTree+        testDim1 =+          testGroup "DIM1"+            [ testProperty "stencil3"     $ test_stencil3 runN e+            , testProperty "stencil5"     $ test_stencil5 runN e+            , testProperty "stencil7"     $ test_stencil7 runN e+            , testProperty "stencil9"     $ test_stencil9 runN e+            ]++        testDim2 :: TestTree+        testDim2 =+          testGroup "DIM2"+            [ testProperty "stencil3x3"   $ test_stencil3x3 runN e+            , testProperty "stencil5x5"   $ test_stencil5x5 runN e+            , testProperty "stencil7x7"   $ test_stencil7x7 runN e+            , testProperty "stencil9x9"   $ test_stencil9x9 runN e+            ]++        testDim3 :: TestTree+        testDim3 =+          testGroup "DIM3"+            [ testProperty "stencil3x3x3" $ test_stencil3x3x3 runN e+            ]+++test_stencil3+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_stencil3 runN e =+  property $ do+    sh        <- forAll ((Z :.) <$> Gen.int (Range.linear 2 256))+    xs        <- forAll (array sh e)+    b         <- forAll (boundary e)+    P3 _ a r  <- forAll pattern3+    let !go = case b of+                Clamp      -> runN (A.stencil a A.clamp)+                Wrap       -> runN (A.stencil a A.wrap)+                Mirror     -> runN (A.stencil a A.mirror)+                Constant x -> runN (A.stencil a (A.function (\_ -> constant x)))+    --+    go xs ~~~ stencil3Ref r b xs++test_stencil5+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_stencil5 runN e =+  property $ do+    sh        <- forAll ((Z :.) <$> Gen.int (Range.linear 3 256))+    xs        <- forAll (array sh e)+    b         <- forAll (boundary e)+    P5 _ a r  <- forAll pattern5+    let !go = case b of+                Clamp      -> runN (A.stencil a A.clamp)+                Wrap       -> runN (A.stencil a A.wrap)+                Mirror     -> runN (A.stencil a A.mirror)+                Constant x -> runN (A.stencil a (A.function (\_ -> constant x)))+    --+    go xs ~~~ stencil5Ref r b xs++test_stencil7+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_stencil7 runN e =+  property $ do+    sh        <- forAll ((Z :.) <$> Gen.int (Range.linear 4 256))+    xs        <- forAll (array sh e)+    b         <- forAll (boundary e)+    P7 _ a r  <- forAll pattern7+    let !go = case b of+                Clamp      -> runN (A.stencil a A.clamp)+                Wrap       -> runN (A.stencil a A.wrap)+                Mirror     -> runN (A.stencil a A.mirror)+                Constant x -> runN (A.stencil a (A.function (\_ -> constant x)))+    --+    go xs ~~~ stencil7Ref r b xs++test_stencil9+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_stencil9 runN e =+  property $ do+    sh        <- forAll ((Z :.) <$> Gen.int (Range.linear 5 256))+    xs        <- forAll (array sh e)+    b         <- forAll (boundary e)+    P9 _ a r  <- forAll pattern9+    let !go = case b of+                Clamp      -> runN (A.stencil a A.clamp)+                Wrap       -> runN (A.stencil a A.wrap)+                Mirror     -> runN (A.stencil a A.mirror)+                Constant x -> runN (A.stencil a (A.function (\_ -> constant x)))+    --+    go xs ~~~ stencil9Ref r b xs+++test_stencil3x3+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_stencil3x3 runN e =+  property $ do+    sy <- forAll (Gen.int (Range.linear 2 96))+    sx <- forAll (Gen.int (Range.linear 2 96))+    let sh = Z :. sy :. sx+    xs          <- forAll (array sh e)+    b           <- forAll (boundary e)+    P3x3 _ a r  <- forAll pattern3x3+    let !go = case b of+                Clamp      -> runN (A.stencil a A.clamp)+                Wrap       -> runN (A.stencil a A.wrap)+                Mirror     -> runN (A.stencil a A.mirror)+                Constant x -> runN (A.stencil a (A.function (\_ -> constant x)))+    --+    go xs ~~~ stencil3x3Ref r b xs++test_stencil5x5+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_stencil5x5 runN e =+  property $ do+    sy <- forAll (Gen.int (Range.linear 3 96))+    sx <- forAll (Gen.int (Range.linear 3 96))+    let sh = Z :. sy :. sx+    xs          <- forAll (array sh e)+    b           <- forAll (boundary e)+    P5x5 _ a r  <- forAll pattern5x5+    let !go = case b of+                Clamp      -> runN (A.stencil a A.clamp)+                Wrap       -> runN (A.stencil a A.wrap)+                Mirror     -> runN (A.stencil a A.mirror)+                Constant x -> runN (A.stencil a (A.function (\_ -> constant x)))+    --+    go xs ~~~ stencil5x5Ref r b xs++test_stencil7x7+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_stencil7x7 runN e =+  property $ do+    sy <- forAll (Gen.int (Range.linear 4 96))+    sx <- forAll (Gen.int (Range.linear 4 96))+    let sh = Z :. sy :. sx+    xs          <- forAll (array sh e)+    b           <- forAll (boundary e)+    P7x7 _ a r  <- forAll pattern7x7+    let !go = case b of+                Clamp      -> runN (A.stencil a A.clamp)+                Wrap       -> runN (A.stencil a A.wrap)+                Mirror     -> runN (A.stencil a A.mirror)+                Constant x -> runN (A.stencil a (A.function (\_ -> constant x)))+    --+    go xs ~~~ stencil7x7Ref r b xs++test_stencil9x9+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_stencil9x9 runN e =+  property $ do+    sy <- forAll (Gen.int (Range.linear 5 96))+    sx <- forAll (Gen.int (Range.linear 5 96))+    let sh = Z :. sy :. sx+    xs          <- forAll (array sh e)+    b           <- forAll (boundary e)+    P9x9 _ a r  <- forAll pattern9x9+    let !go = case b of+                Clamp      -> runN (A.stencil a A.clamp)+                Wrap       -> runN (A.stencil a A.wrap)+                Mirror     -> runN (A.stencil a A.mirror)+                Constant x -> runN (A.stencil a (A.function (\_ -> constant x)))+    --+    go xs ~~~ stencil9x9Ref r b xs++test_stencil3x3x3+    :: (P.Num e, A.Num e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_stencil3x3x3 runN e =+  property $ do+    sz <- forAll (Gen.int (Range.linear 2 32))+    sy <- forAll (Gen.int (Range.linear 2 32))+    sx <- forAll (Gen.int (Range.linear 2 32))+    let sh = Z :. sz :. sy :. sx+    xs            <- forAll (array sh e)+    b             <- forAll (boundary e)+    P3x3x3 _ a r  <- forAll pattern3x3x3+    let !go = case b of+                Clamp      -> runN (A.stencil a A.clamp)+                Wrap       -> runN (A.stencil a A.wrap)+                Mirror     -> runN (A.stencil a A.mirror)+                Constant x -> runN (A.stencil a (A.function (\_ -> constant x)))+    --+    go xs ~~~ stencil3x3x3Ref r b xs+++type Stencil3Ref a = (a,a,a)+type Stencil5Ref a = (a,a,a,a,a)+type Stencil7Ref a = (a,a,a,a,a,a,a)+type Stencil9Ref a = (a,a,a,a,a,a,a,a,a)++type Stencil3x3Ref a = (Stencil3Ref a, Stencil3Ref a, Stencil3Ref a)+type Stencil5x5Ref a = (Stencil5Ref a, Stencil5Ref a, Stencil5Ref a, Stencil5Ref a, Stencil5Ref a)+type Stencil7x7Ref a = (Stencil7Ref a, Stencil7Ref a, Stencil7Ref a, Stencil7Ref a, Stencil7Ref a, Stencil7Ref a, Stencil7Ref a)+type Stencil9x9Ref a = (Stencil9Ref a, Stencil9Ref a, Stencil9Ref a, Stencil9Ref a, Stencil9Ref a, Stencil9Ref a, Stencil9Ref a, Stencil9Ref a, Stencil9Ref a)++type Stencil3x3x3Ref a = (Stencil3x3Ref a, Stencil3x3Ref a, Stencil3x3Ref a)++type Stencil7x7 a = (Stencil7 a, Stencil7 a, Stencil7 a, Stencil7 a, Stencil7 a, Stencil7 a, Stencil7 a)+type Stencil9x9 a = (Stencil9 a, Stencil9 a, Stencil9 a, Stencil9 a, Stencil9 a, Stencil9 a, Stencil9 a, Stencil9 a, Stencil9 a)+++data SimpleBoundary e+  = Wrap+  | Clamp+  | Mirror+  | Constant e+  deriving (P.Eq, Show)++boundary+    :: Elt e+    => Gen e+    -> Gen (SimpleBoundary e)+boundary e =+  Gen.choice+    [ Constant <$> e+    , return Clamp+    , return Wrap+    , return Mirror+    ]++data Pattern3 a = P3 [Int] (Stencil3 a -> Exp a) (Stencil3Ref a -> a)+data Pattern5 a = P5 [Int] (Stencil5 a -> Exp a) (Stencil5Ref a -> a)+data Pattern7 a = P7 [Int] (Stencil7 a -> Exp a) (Stencil7Ref a -> a)+data Pattern9 a = P9 [Int] (Stencil9 a -> Exp a) (Stencil9Ref a -> a)++data Pattern3x3 a = P3x3 [[Int]] (Stencil3x3 a -> Exp a) (Stencil3x3Ref a -> a)+data Pattern5x5 a = P5x5 [[Int]] (Stencil5x5 a -> Exp a) (Stencil5x5Ref a -> a)+data Pattern7x7 a = P7x7 [[Int]] (Stencil7x7 a -> Exp a) (Stencil7x7Ref a -> a)+data Pattern9x9 a = P9x9 [[Int]] (Stencil9x9 a -> Exp a) (Stencil9x9Ref a -> a)++data Pattern3x3x3 a = P3x3x3 [[[Int]]] (Stencil3x3x3 a -> Exp a) (Stencil3x3x3Ref a -> a)++instance Show (Pattern3 a) where show (P3 ix _ _) = show ix+instance Show (Pattern5 a) where show (P5 ix _ _) = show ix+instance Show (Pattern7 a) where show (P7 ix _ _) = show ix+instance Show (Pattern9 a) where show (P9 ix _ _) = show ix++instance Show (Pattern3x3 a) where show (P3x3 ix _ _) = show ix+instance Show (Pattern5x5 a) where show (P5x5 ix _ _) = show ix+instance Show (Pattern7x7 a) where show (P7x7 ix _ _) = show ix+instance Show (Pattern9x9 a) where show (P9x9 ix _ _) = show ix++instance Show (Pattern3x3x3 a) where show (P3x3x3 ix _ _) = show ix+++pattern3 :: (P.Num a, A.Num a) => Gen (Pattern3 a)+pattern3 = do+  i <- Gen.subsequence [0..2]+  return $+    P3 i (\(x0,x1,x2) -> P.sum (P.map ([x0,x1,x2] P.!!) i))+         (\(x0,x1,x2) -> P.sum (P.map ([x0,x1,x2] P.!!) i))++pattern5 :: (P.Num a, A.Num a) => Gen (Pattern5 a)+pattern5 = do+  i <- Gen.subsequence [0..4]+  return $+    P5 i (\(x0,x1,x2,x3,x4) -> P.sum (P.map ([x0,x1,x2,x3,x4] P.!!) i))+         (\(x0,x1,x2,x3,x4) -> P.sum (P.map ([x0,x1,x2,x3,x4] P.!!) i))++pattern7 :: (P.Num a, A.Num a) => Gen (Pattern7 a)+pattern7 = do+  i <- Gen.subsequence [0..6]+  return $+    P7 i (\(x0,x1,x2,x3,x4,x5,x6) -> P.sum (P.map ([x0,x1,x2,x3,x4,x5,x6] P.!!) i))+         (\(x0,x1,x2,x3,x4,x5,x6) -> P.sum (P.map ([x0,x1,x2,x3,x4,x5,x6] P.!!) i))++pattern9 :: (P.Num a, A.Num a) => Gen (Pattern9 a)+pattern9 = do+  i <- Gen.subsequence [0..8]+  return $+    P9 i (\(x0,x1,x2,x3,x4,x5,x6,x7,x8) -> P.sum (P.map ([x0,x1,x2,x3,x4,x5,x6,x7,x8] P.!!) i))+         (\(x0,x1,x2,x3,x4,x5,x6,x7,x8) -> P.sum (P.map ([x0,x1,x2,x3,x4,x5,x6,x7,x8] P.!!) i))++pattern3x3 :: (P.Num a, A.Num a) => Gen (Pattern3x3 a)+pattern3x3 = do+  P3 i0 a0 r0 <- pattern3+  P3 i1 a1 r1 <- pattern3+  P3 i2 a2 r2 <- pattern3+  return $+    P3x3 [i0,i1,i2]+         (\(x0,x1,x2) -> P.sum [a0 x0, a1 x1, a2 x2])+         (\(x0,x1,x2) -> P.sum [r0 x0, r1 x1, r2 x2])++pattern5x5 :: (P.Num a, A.Num a) => Gen (Pattern5x5 a)+pattern5x5 = do+  P5 i0 a0 r0 <- pattern5+  P5 i1 a1 r1 <- pattern5+  P5 i2 a2 r2 <- pattern5+  P5 i3 a3 r3 <- pattern5+  P5 i4 a4 r4 <- pattern5+  return $+    P5x5 [i0,i1,i2,i3,i4]+         (\(x0,x1,x2,x3,x4) -> P.sum [a0 x0, a1 x1, a2 x2, a3 x3, a4 x4])+         (\(x0,x1,x2,x3,x4) -> P.sum [r0 x0, r1 x1, r2 x2, r3 x3, r4 x4])++pattern7x7 :: (P.Num a, A.Num a) => Gen (Pattern7x7 a)+pattern7x7 = do+  P7 i0 a0 r0 <- pattern7+  P7 i1 a1 r1 <- pattern7+  P7 i2 a2 r2 <- pattern7+  P7 i3 a3 r3 <- pattern7+  P7 i4 a4 r4 <- pattern7+  P7 i5 a5 r5 <- pattern7+  P7 i6 a6 r6 <- pattern7+  return $+    P7x7 [i0,i1,i2,i3,i4,i5,i6]+         (\(x0,x1,x2,x3,x4,x5,x6) -> P.sum [a0 x0, a1 x1, a2 x2, a3 x3, a4 x4, a5 x5, a6 x6])+         (\(x0,x1,x2,x3,x4,x5,x6) -> P.sum [r0 x0, r1 x1, r2 x2, r3 x3, r4 x4, r5 x5, r6 x6])++pattern9x9 :: (P.Num a, A.Num a) => Gen (Pattern9x9 a)+pattern9x9 = do+  P9 i0 a0 r0 <- pattern9+  P9 i1 a1 r1 <- pattern9+  P9 i2 a2 r2 <- pattern9+  P9 i3 a3 r3 <- pattern9+  P9 i4 a4 r4 <- pattern9+  P9 i5 a5 r5 <- pattern9+  P9 i6 a6 r6 <- pattern9+  P9 i7 a7 r7 <- pattern9+  P9 i8 a8 r8 <- pattern9+  return $+    P9x9 [i0,i1,i2,i3,i4,i5,i6,i7,i8]+         (\(x0,x1,x2,x3,x4,x5,x6,x7,x8) -> P.sum [a0 x0, a1 x1, a2 x2, a3 x3, a4 x4, a5 x5, a6 x6, a7 x7, a8 x8])+         (\(x0,x1,x2,x3,x4,x5,x6,x7,x8) -> P.sum [r0 x0, r1 x1, r2 x2, r3 x3, r4 x4, r5 x5, r6 x6, r7 x7, r8 x8])++pattern3x3x3 :: (P.Num a, A.Num a) => Gen (Pattern3x3x3 a)+pattern3x3x3 = do+  P3x3 i0 a0 r0 <- pattern3x3+  P3x3 i1 a1 r1 <- pattern3x3+  P3x3 i2 a2 r2 <- pattern3x3+  return $+    P3x3x3 [i0,i1,i2]+           (\(x0,x1,x2) -> P.sum [a0 x0, a1 x1, a2 x2])+           (\(x0,x1,x2) -> P.sum [r0 x0, r1 x1, r2 x2])++++stencil3Ref+    :: Elt a+    => (Stencil3Ref a -> a)+    -> SimpleBoundary a+    -> Vector a+    -> Vector a+stencil3Ref st bnd arr =+  let sh = S.shape arr+  in+  fromFunction sh+    (\ix@(Z:.n) -> let x0 = either id (arr S.!) (bound bnd sh (Z :. n-1))+                       x1 = arr S.! ix+                       x2 = either id (arr S.!) (bound bnd sh (Z :. n+1))+                   in+                   st (x0,x1,x2))++stencil5Ref+    :: Elt a+    => (Stencil5Ref a -> a)+    -> SimpleBoundary a+    -> Vector a+    -> Vector a+stencil5Ref st bnd arr =+  let sh = S.shape arr+  in+  fromFunction sh+    (\(Z:.i) ->+        let get it  = either id (arr S.!) (bound bnd sh it)+            --+            x0 = get (Z:.i-2)+            x1 = get (Z:.i-1)+            x2 = get (Z:.i)+            x3 = get (Z:.i+1)+            x4 = get (Z:.i+2)+        in+        st (x0,x1,x2,x3,x4))++stencil7Ref+    :: Elt a+    => (Stencil7Ref a -> a)+    -> SimpleBoundary a+    -> Vector a+    -> Vector a+stencil7Ref st bnd arr =+  let sh = S.shape arr+  in+  fromFunction sh+    (\(Z:.i) ->+        let get it  = either id (arr S.!) (bound bnd sh it)+            --+            x0 = get (Z:.i-3)+            x1 = get (Z:.i-2)+            x2 = get (Z:.i-1)+            x3 = get (Z:.i)+            x4 = get (Z:.i+1)+            x5 = get (Z:.i+2)+            x6 = get (Z:.i+3)+        in+        st (x0,x1,x2,x3,x4,x5,x6))++stencil9Ref+    :: Elt a+    => (Stencil9Ref a -> a)+    -> SimpleBoundary a+    -> Vector a+    -> Vector a+stencil9Ref st bnd arr =+  let sh = S.shape arr+  in+  fromFunction sh+    (\(Z:.i) ->+        let get it  = either id (arr S.!) (bound bnd sh it)+            --+            x0 = get (Z:.i-4)+            x1 = get (Z:.i-3)+            x2 = get (Z:.i-2)+            x3 = get (Z:.i-1)+            x4 = get (Z:.i)+            x5 = get (Z:.i+1)+            x6 = get (Z:.i+2)+            x7 = get (Z:.i+3)+            x8 = get (Z:.i+4)+        in+        st (x0,x1,x2,x3,x4,x5,x6,x7,x8))++stencil3x3Ref+    :: Elt a+    => (Stencil3x3Ref a -> a)+    -> SimpleBoundary a+    -> Matrix a+    -> Matrix a+stencil3x3Ref st bnd arr =+  let sh = S.shape arr+  in+  fromFunction sh+    (\(Z:.j:.i) ->+        let get it  = either id (arr S.!) (bound bnd sh it)+            --+            x0 = ( get (Z :. j-1 :. i-1), get (Z :. j-1 :. i), get (Z :. j-1 :. i+1) )+            x1 = ( get (Z :. j   :. i-1), get (Z :. j   :. i), get (Z :. j   :. i+1) )+            x2 = ( get (Z :. j+1 :. i-1), get (Z :. j+1 :. i), get (Z :. j+1 :. i+1) )+        in+        st (x0,x1,x2))++stencil5x5Ref+    :: Elt a+    => (Stencil5x5Ref a -> a)+    -> SimpleBoundary a+    -> Matrix a+    -> Matrix a+stencil5x5Ref st bnd arr =+  let sh = S.shape arr+  in+  fromFunction sh+    (\(Z:.j:.i) ->+        let get it  = either id (arr S.!) (bound bnd sh it)+            --+            x0 = ( get (Z :. j-2 :. i-2), get (Z :. j-2 :. i-1), get (Z :. j-2 :. i), get (Z :. j-2 :. i+1), get (Z :. j-2 :. i+2) )+            x1 = ( get (Z :. j-1 :. i-2), get (Z :. j-1 :. i-1), get (Z :. j-1 :. i), get (Z :. j-1 :. i+1), get (Z :. j-1 :. i+2) )+            x2 = ( get (Z :. j   :. i-2), get (Z :. j   :. i-1), get (Z :. j   :. i), get (Z :. j   :. i+1), get (Z :. j   :. i+2) )+            x3 = ( get (Z :. j+1 :. i-2), get (Z :. j+1 :. i-1), get (Z :. j+1 :. i), get (Z :. j+1 :. i+1), get (Z :. j+1 :. i+2) )+            x4 = ( get (Z :. j+2 :. i-2), get (Z :. j+2 :. i-1), get (Z :. j+2 :. i), get (Z :. j+2 :. i+1), get (Z :. j+2 :. i+2) )+        in+        st (x0,x1,x2,x3,x4))++stencil7x7Ref+    :: Elt a+    => (Stencil7x7Ref a -> a)+    -> SimpleBoundary a+    -> Matrix a+    -> Matrix a+stencil7x7Ref st bnd arr =+  let sh = S.shape arr+  in+  fromFunction sh+    (\(Z:.j:.i) ->+        let get it  = either id (arr S.!) (bound bnd sh it)+            --+            x0 = ( get (Z :. j-3 :. i-3), get (Z :. j-3 :. i-2), get (Z :. j-3 :. i-1), get (Z :. j-3 :. i), get (Z :. j-3 :. i+1), get (Z :. j-3 :. i+2), get (Z :. j-3 :. i+3) )+            x1 = ( get (Z :. j-2 :. i-3), get (Z :. j-2 :. i-2), get (Z :. j-2 :. i-1), get (Z :. j-2 :. i), get (Z :. j-2 :. i+1), get (Z :. j-2 :. i+2), get (Z :. j-2 :. i+3) )+            x2 = ( get (Z :. j-1 :. i-3), get (Z :. j-1 :. i-2), get (Z :. j-1 :. i-1), get (Z :. j-1 :. i), get (Z :. j-1 :. i+1), get (Z :. j-1 :. i+2), get (Z :. j-1 :. i+3) )+            x3 = ( get (Z :. j   :. i-3), get (Z :. j   :. i-2), get (Z :. j   :. i-1), get (Z :. j   :. i), get (Z :. j   :. i+1), get (Z :. j   :. i+2), get (Z :. j   :. i+3) )+            x4 = ( get (Z :. j+1 :. i-3), get (Z :. j+1 :. i-2), get (Z :. j+1 :. i-1), get (Z :. j+1 :. i), get (Z :. j+1 :. i+1), get (Z :. j+1 :. i+2), get (Z :. j+1 :. i+3) )+            x5 = ( get (Z :. j+2 :. i-3), get (Z :. j+2 :. i-2), get (Z :. j+2 :. i-1), get (Z :. j+2 :. i), get (Z :. j+2 :. i+1), get (Z :. j+2 :. i+2), get (Z :. j+2 :. i+3) )+            x6 = ( get (Z :. j+3 :. i-3), get (Z :. j+3 :. i-2), get (Z :. j+3 :. i-1), get (Z :. j+3 :. i), get (Z :. j+3 :. i+1), get (Z :. j+3 :. i+2), get (Z :. j+3 :. i+3) )+        in+        st (x0,x1,x2,x3,x4,x5,x6))++stencil9x9Ref+    :: Elt a+    => (Stencil9x9Ref a -> a)+    -> SimpleBoundary a+    -> Matrix a+    -> Matrix a+stencil9x9Ref st bnd arr =+  let sh = S.shape arr+  in+  fromFunction sh+    (\(Z:.j:.i) ->+        let get it  = either id (arr S.!) (bound bnd sh it)+            --+            x0 = ( get (Z :. j-4 :. i-4), get (Z :. j-4 :. i-3), get (Z :. j-4 :. i-2), get (Z :. j-4 :. i-1), get (Z :. j-4 :. i), get (Z :. j-4 :. i+1), get (Z :. j-4 :. i+2), get (Z :. j-4 :. i+3), get (Z :. j-4 :. i+4) )+            x1 = ( get (Z :. j-3 :. i-4), get (Z :. j-3 :. i-3), get (Z :. j-3 :. i-2), get (Z :. j-3 :. i-1), get (Z :. j-3 :. i), get (Z :. j-3 :. i+1), get (Z :. j-3 :. i+2), get (Z :. j-3 :. i+3), get (Z :. j-3 :. i+4) )+            x2 = ( get (Z :. j-2 :. i-4), get (Z :. j-2 :. i-3), get (Z :. j-2 :. i-2), get (Z :. j-2 :. i-1), get (Z :. j-2 :. i), get (Z :. j-2 :. i+1), get (Z :. j-2 :. i+2), get (Z :. j-2 :. i+3), get (Z :. j-2 :. i+4) )+            x3 = ( get (Z :. j-1 :. i-4), get (Z :. j-1 :. i-3), get (Z :. j-1 :. i-2), get (Z :. j-1 :. i-1), get (Z :. j-1 :. i), get (Z :. j-1 :. i+1), get (Z :. j-1 :. i+2), get (Z :. j-1 :. i+3), get (Z :. j-1 :. i+4) )+            x4 = ( get (Z :. j   :. i-4), get (Z :. j   :. i-3), get (Z :. j   :. i-2), get (Z :. j   :. i-1), get (Z :. j   :. i), get (Z :. j   :. i+1), get (Z :. j   :. i+2), get (Z :. j   :. i+3), get (Z :. j   :. i+4) )+            x5 = ( get (Z :. j+1 :. i-4), get (Z :. j+1 :. i-3), get (Z :. j+1 :. i-2), get (Z :. j+1 :. i-1), get (Z :. j+1 :. i), get (Z :. j+1 :. i+1), get (Z :. j+1 :. i+2), get (Z :. j+1 :. i+3), get (Z :. j+1 :. i+4) )+            x6 = ( get (Z :. j+2 :. i-4), get (Z :. j+2 :. i-3), get (Z :. j+2 :. i-2), get (Z :. j+2 :. i-1), get (Z :. j+2 :. i), get (Z :. j+2 :. i+1), get (Z :. j+2 :. i+2), get (Z :. j+2 :. i+3), get (Z :. j+2 :. i+4) )+            x7 = ( get (Z :. j+3 :. i-4), get (Z :. j+3 :. i-3), get (Z :. j+3 :. i-2), get (Z :. j+3 :. i-1), get (Z :. j+3 :. i), get (Z :. j+3 :. i+1), get (Z :. j+3 :. i+2), get (Z :. j+3 :. i+3), get (Z :. j+3 :. i+4) )+            x8 = ( get (Z :. j+4 :. i-4), get (Z :. j+4 :. i-3), get (Z :. j+4 :. i-2), get (Z :. j+4 :. i-1), get (Z :. j+4 :. i), get (Z :. j+4 :. i+1), get (Z :. j+4 :. i+2), get (Z :. j+4 :. i+3), get (Z :. j+4 :. i+4) )+        in+        st (x0,x1,x2,x3,x4,x5,x6,x7,x8))++stencil3x3x3Ref+    :: forall a. Elt a+    => (Stencil3x3x3Ref a -> a)+    -> SimpleBoundary a+    -> Array DIM3 a+    -> Array DIM3 a+stencil3x3x3Ref st bnd arr =+  let sh = S.shape arr+  in+  fromFunction sh+    (\(Z:.k:.j:.i) ->+        let get it  = either id (arr S.!) (bound bnd sh it)+            --+            x0 z = ( get (Z :. z :. j-1 :. i-1), get (Z :. z :. j-1 :. i), get (Z :. z :. j-1 :. i+1) )+            x1 z = ( get (Z :. z :. j   :. i-1), get (Z :. z :. j   :. i), get (Z :. z :. j   :. i+1) )+            x2 z = ( get (Z :. z :. j+1 :. i-1), get (Z :. z :. j+1 :. i), get (Z :. z :. j+1 :. i+1) )+        in+        st ((x0 (k-1), x1 (k-1), x2 (k-1))+           ,(x0 k    , x1 k,     x2 k)+           ,(x0 (k+1), x1 (k+1), x2 (k+1))))+++bound :: forall sh e. Shape sh => SimpleBoundary e -> sh -> sh -> Either e sh+bound bnd sh0 ix0 =+  case go (eltType sh0) (fromElt sh0) (fromElt ix0) of+    Left e    -> Left e+    Right ix' -> Right (toElt ix')+  where+    go :: TupleType t -> t -> t -> Either e t+    go TypeRunit           ()      ()      = Right ()+    go (TypeRpair tsh tsz) (sh,sz) (ih,iz) = go tsh sh ih `addDim` go tsz sz iz+    go (TypeRscalar t)     sh      i+      | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)+      = if i P.< 0+          then case bnd of+                 Clamp      -> Right 0+                 Mirror     -> Right (-i)+                 Wrap       -> Right (sh+i)+                 Constant e -> Left e++        else if i P.>= sh+          then case bnd of+                 Clamp      -> Right (sh-1)+                 Mirror     -> Right (sh-(i-sh+2))+                 Wrap       -> Right (i-sh)+                 Constant e -> Left e+        else+          Right i+      --+      | otherwise+      = error "bound: expected shape with Int dimensions"++    Right ds `addDim` Right d = Right (ds, d)+    _        `addDim` Left e  = Left e+    Left e   `addDim` _       = Left e+
+ src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs view
@@ -0,0 +1,599 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE MonoLocalBinds      #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Prelude.ZipWith+-- Copyright   : [2009..2017] 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.Test.NoFib.Prelude.ZipWith (++  test_zipWith++) where++import Data.Bits                                                    as P+import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Data.Bits                              as A+import Data.Array.Accelerate.Array.Sugar                            as S+import Data.Array.Accelerate.Smart                                  ( ($$) )+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_zipWith :: RunN -> TestTree+test_zipWith runN =+  testGroup "zipWith"+    [ at (Proxy::Proxy TestInt8)   $ testIntegralElt i8+    , at (Proxy::Proxy TestInt16)  $ testIntegralElt i16+    , at (Proxy::Proxy TestInt32)  $ testIntegralElt i32+    , at (Proxy::Proxy TestInt64)  $ testIntegralElt i64+    , at (Proxy::Proxy TestWord8)  $ testIntegralElt w8+    , at (Proxy::Proxy TestWord16) $ testIntegralElt w16+    , at (Proxy::Proxy TestWord32) $ testIntegralElt w32+    , at (Proxy::Proxy TestWord64) $ testIntegralElt w64+    , at (Proxy::Proxy TestHalf)   $ testFloatingElt (Gen.realFloat :: Range Half -> Gen Half)+    , at (Proxy::Proxy TestFloat)  $ testFloatingElt Gen.float+    , at (Proxy::Proxy TestDouble) $ testFloatingElt Gen.double+    ]+  where+    testIntegralElt+        :: forall a. ( P.Integral a, P.FiniteBits a+                     , A.Integral a, A.FiniteBits a+                     , Similar a )+        => Gen a+        -> TestTree+    testIntegralElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim0+        , testDim dim1+        , testDim dim2+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen sh+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::sh)))+            [ -- operators on Num+              testProperty "(+)"          $ test_plus runN sh e+            , testProperty "(-)"          $ test_minus runN sh e+            , testProperty "(*)"          $ test_mult runN sh e++              -- operators on Integral & Bits+            , testProperty "quot"         $ test_quot runN sh e+            , testProperty "rem"          $ test_rem runN sh e+            , testProperty "quotRem"      $ test_quotRem runN sh e+            , testProperty "div"          $ test_idiv runN sh e+            , testProperty "mod"          $ test_mod runN sh e+            , testProperty "divMod"       $ test_divMod runN sh e+            , testProperty "(.&.)"        $ test_band runN sh e+            , testProperty "(.|.)"        $ test_bor runN sh e+            , testProperty "xor"          $ test_xor runN sh e+            , testProperty "shift"        $ test_shift runN sh e+            , testProperty "shiftL"       $ test_shiftL runN sh e+            , testProperty "shiftR"       $ test_shiftR runN sh e+            , testProperty "rotate"       $ test_rotate runN sh e+            , testProperty "rotateL"      $ test_rotateL runN sh e+            , testProperty "rotateR"      $ test_rotateR runN sh e++              -- relational and equality operators+            , testProperty "(<)"          $ test_lt runN sh e+            , testProperty "(>)"          $ test_gt runN sh e+            , testProperty "(<=)"         $ test_lte runN sh e+            , testProperty "(>=)"         $ test_gte runN sh e+            , testProperty "(==)"         $ test_eq runN sh e+            , testProperty "(/=)"         $ test_neq runN sh e+            , testProperty "min"          $ test_min runN sh e+            , testProperty "max"          $ test_max runN sh e+            ]++    testFloatingElt+        :: forall a. (P.RealFloat a, A.RealFloat a, Similar a)+        => (Range a -> Gen a)+        -> TestTree+    testFloatingElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testDim dim0+        , testDim dim1+        , testDim dim2+        ]+      where+        testDim+            :: forall sh. (Shape sh, P.Eq sh)+            => Gen sh+            -> TestTree+        testDim sh =+          testGroup ("DIM" P.++ show (rank (undefined::sh)))+            [ -- operators on Num+              testProperty "(+)"          $ test_plus runN sh (full e)+            , testProperty "(-)"          $ test_minus runN sh (full e)+            , testProperty "(*)"          $ test_mult runN sh (full e)++              -- operators on Fractional, Floating, RealFrac & RealFloat+            , testProperty "(/)"          $ test_fdiv runN sh (full e)+            , testProperty "(**)"         $ test_pow runN sh (full e)+            , testProperty "atan2"        $ test_atan2 runN sh (full e)+            , testProperty "logBase"      $ test_logBase runN sh (e (Range.linearFrac 0 flt_max) `except` zero)++              -- relational and equality operators+            , testProperty "(<)"          $ test_lt runN sh (full e)+            , testProperty "(>)"          $ test_gt runN sh (full e)+            , testProperty "(<=)"         $ test_lte runN sh (full e)+            , testProperty "(>=)"         $ test_gte runN sh (full e)+            , testProperty "(==)"         $ test_eq runN sh (full e)+            , testProperty "(/=)"         $ test_neq runN sh (full e)+            , testProperty "min"          $ test_min runN sh (full e)+            , testProperty "max"          $ test_max runN sh (full e)+            ]++        full :: P.RealFloat e => (Range e -> Gen e) -> Gen e+        full gen = gen (Range.linearFracFrom 0 (-flt_max) flt_max)+++zero :: (P.Num a, P.Eq a) => a -> Bool+zero x = x P.== 0++test_plus+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_plus runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (+)) in go xs ys ~~~ zipWithRef (+) xs ys++test_minus+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_minus runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (-)) in go xs ys ~~~ zipWithRef (-) xs ys++test_mult+    :: (Shape sh, Similar e, P.Eq sh, P.Num e, A.Num e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_mult runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (*)) in go xs ys ~~~ zipWithRef (*) xs ys++test_quot+    :: (Shape sh, Similar e, P.Eq sh, P.Integral e, A.Integral e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_quot runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (e `except` zero))+    let !go = runN (A.zipWith quot) in go xs ys ~~~ zipWithRef quot xs ys++test_rem+    :: (Shape sh, Similar e, P.Eq sh, P.Integral e, A.Integral e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_rem runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (e `except` zero))+    let !go = runN (A.zipWith rem) in go xs ys ~~~ zipWithRef rem xs ys++test_quotRem+    :: (Shape sh, Similar e, P.Eq sh, P.Integral e, A.Integral e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_quotRem runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (e `except` zero))+    let !go = runN (A.zipWith (lift $$ quotRem)) in go xs ys ~~~ zipWithRef quotRem xs ys++test_idiv+    :: (Shape sh, Similar e, P.Eq sh, P.Integral e, A.Integral e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_idiv runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (e `except` zero))+    let !go = runN (A.zipWith div) in go xs ys ~~~ zipWithRef div xs ys++test_fdiv+    :: (Shape sh, Similar e, P.Eq sh, P.Eq e, P.Fractional e, A.Fractional e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_fdiv runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (e `except` zero))+    let !go = runN (A.zipWith (/)) in go xs ys ~~~ zipWithRef (/) xs ys++test_pow+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_pow runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (**)) in go xs ys ~~~ zipWithRef (**) xs ys++test_logBase+    :: (Shape sh, Similar e, P.Eq sh, P.Floating e, A.Floating e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_logBase runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith logBase) in go xs ys ~~~ zipWithRef logBase xs ys++test_atan2+    :: (Shape sh, Similar e, P.Eq sh, P.RealFloat e, A.RealFloat e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_atan2 runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith A.atan2) in go xs ys ~~~ zipWithRef P.atan2 xs ys++test_mod+    :: (Shape sh, Similar e, P.Eq sh, P.Integral e, A.Integral e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_mod runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (e `except` zero))+    let !go = runN (A.zipWith mod) in go xs ys ~~~ zipWithRef mod xs ys++test_divMod+    :: (Shape sh, Similar e, P.Eq sh, P.Integral e, A.Integral e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_divMod runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (e `except` zero))+    let !go = runN (A.zipWith (lift $$ divMod)) in go xs ys ~~~ zipWithRef divMod xs ys++test_band+    :: (Shape sh, Similar e, P.Eq sh, P.Bits e, A.Bits e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_band runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A..&.)) in go xs ys ~~~ zipWithRef (P..&.) xs ys++test_bor+    :: (Shape sh, Similar e, P.Eq sh, P.Bits e, A.Bits e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_bor runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A..|.)) in go xs ys ~~~ zipWithRef (P..|.) xs ys++test_xor+    :: (Shape sh, Similar e, P.Eq sh, P.Bits e, A.Bits e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_xor runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith A.xor) in go xs ys ~~~ zipWithRef P.xor xs ys++test_shift+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.FiniteBits e, A.FiniteBits e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_shift runN dim e =+  property $ do+    let s = P.finiteBitSize (undefined::e)+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (Gen.int (Range.linearFrom 0 (-s) s)))+    let !go = runN (A.zipWith A.shift) in go xs ys ~~~ zipWithRef P.shift xs ys++test_shiftL+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.FiniteBits e, A.FiniteBits e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_shiftL runN dim e =+  property $ do+    let s = P.finiteBitSize (undefined::e)+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (Gen.int (Range.linear 0 s)))+    let !go = runN (A.zipWith A.shiftL) in go xs ys ~~~ zipWithRef P.shiftL xs ys++test_shiftR+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.FiniteBits e, A.FiniteBits e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_shiftR runN dim e =+  property $ do+    let s = P.finiteBitSize (undefined::e)+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (Gen.int (Range.linear 0 s)))+    let !go = runN (A.zipWith A.shiftR) in go xs ys ~~~ zipWithRef P.shiftR xs ys++test_rotate+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.FiniteBits e, A.FiniteBits e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_rotate runN dim e =+  property $ do+    let s = P.finiteBitSize (undefined::e)+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (Gen.int (Range.linearFrom 0 (-s) s)))+    let !go = runN (A.zipWith A.rotate) in go xs ys ~~~ zipWithRef P.rotate xs ys++test_rotateL+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.FiniteBits e, A.FiniteBits e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_rotateL runN dim e =+  property $ do+    let s = P.finiteBitSize (undefined::e)+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (Gen.int (Range.linear 0 s)))+    let !go = runN (A.zipWith A.rotateL) in go xs ys ~~~ zipWithRef P.rotateL xs ys++test_rotateR+    :: forall sh e. (Shape sh, Similar e, P.Eq sh, P.FiniteBits e, A.FiniteBits e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_rotateR runN dim e =+  property $ do+    let s = P.finiteBitSize (undefined::e)+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 (Gen.int (Range.linear 0 s)))+    let !go = runN (A.zipWith A.rotateR) in go xs ys ~~~ zipWithRef P.rotateR xs ys++test_lt+    :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_lt runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A.<)) in go xs ys ~~~ zipWithRef (P.<) xs ys++test_gt+    :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_gt runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A.>)) in go xs ys ~~~ zipWithRef (P.>) xs ys++test_lte+    :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_lte runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A.<=)) in go xs ys ~~~ zipWithRef (P.<=) xs ys++test_gte+    :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_gte runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A.>=)) in go xs ys ~~~ zipWithRef (P.>=) xs ys++test_eq+    :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_eq runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A.==)) in go xs ys ~~~ zipWithRef (P.==) xs ys++test_neq+    :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_neq runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A./=)) in go xs ys ~~~ zipWithRef (P./=) xs ys++test_min+    :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_min runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A.min)) in go xs ys ~~~ zipWithRef (P.min) xs ys++test_max+    :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e)+    => RunN+    -> Gen sh+    -> Gen e+    -> Property+test_max runN dim e =+  property $ do+    sh1 <- forAll dim+    sh2 <- forAll dim+    xs  <- forAll (array sh1 e)+    ys  <- forAll (array sh2 e)+    let !go = runN (A.zipWith (A.max)) in go xs ys ~~~ zipWithRef (P.max) xs ys+++-- Reference Implementation+-- ------------------------++zipWithRef+    :: (Shape sh, Elt c)+    => (a -> b -> c)+    -> Array sh a+    -> Array sh b+    -> Array sh c+zipWithRef f xs ys =+  fromFunction+    (S.shape xs `S.intersect` S.shape ys)+    (\ix -> f (xs S.! ix) (ys S.! ix))+
+ src/Data/Array/Accelerate/Test/NoFib/Sharing.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Sharing+-- Copyright   : [2009..2017] 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.Test.NoFib.Sharing (++  test_sharing++) where++import Data.Array.Accelerate                                        as A hiding ( exp )+import Data.Array.Accelerate.Trafo.Sharing+import Data.Array.Accelerate.Data.Bits                              as A++import Control.DeepSeq+import Control.Exception+import Test.Tasty+import Test.Tasty.ExpectedFailure+import Test.Tasty.HUnit+import Prelude                                                      as P hiding ( exp )+++test_sharing :: TestTree+test_sharing =+  testGroup "sharing"+    [ testCase  "simple"                $ sharingAcc test_simple+    , testCase  "ordering"              $ sharingAcc test_ordering+    , testCase  "sort"                  $ sharingAcc test_sort+    , testCase  "blowup"                $ sharingAcc (test_blowup 20)+    , testCase  "bfs"                   $ sharingAcc test_bfs+    , testGroup "same level"+      [ testCase "1"                    $ sharingAcc test_two_lets_same_level_1+      , testCase "2"                    $ sharingAcc test_two_lets_same_level_2+      ]+    , testGroup "empty top"+      [ testCase "1"                    $ sharingAcc test_no_let_at_top_1+      , testCase "2"                    $ sharingAcc test_no_let_at_top_2+      ]+    , testCase  "pipe"                  $ sharingAcc test_pipe+    , testCase  "bound variables"       $ sharingAcc test_bound_variables+    , testCase  "big tuple"             $ sharingExp test_big_tuple+    , testGroup "iteration"+      [ testCase "simple"               $ sharingAcc test_iteration_simple+      , testCase "outside"              $ sharingAcc test_iteration_outside+      , testCase "body and condition"   $ sharingAcc test_iteration_body_condition+      , testCase "awhile"               $ sharingAcc test_awhile+      , testCase "iterate"              $ sharingAcc test_iterate+      , testCase "nested"               $ sharingExp test_nested_iteration+      , testCase "unused"               $ sharingExp test_unused_iteration+      ]+    , testGroup "nested data-parallelism"+      [ expectFail $ testCase "mvm"     $ sharingAcc test_nested_data_praallelism+      ]+    ]+  where+    sharingAcc :: Arrays a => Acc a -> Assertion+    sharingAcc acc =+      catch (rnf (convertAcc True True True True acc) `seq` return ())+            (\(e :: SomeException) -> assertFailure (show e))++    sharingExp :: Elt e => Exp e -> Assertion+    sharingExp exp =+      catch (rnf (convertExp True exp) `seq` return ())+            (\(e :: SomeException) -> assertFailure (show e))+++--------------------------------------------------------------------------------+--+-- Some tests to make sure that sharing recovery is working.+--++mkArray :: Int -> Acc (Array DIM1 Int)+mkArray n = use $ fromList (Z:.1) [n]++test_blowup :: Int -> Acc (Array DIM1 Int)+test_blowup 0 = (mkArray 0)+test_blowup n = A.map (\_ -> newArr ! (lift (Z:.(0::Int))) ++                             newArr ! (lift (Z:.(1::Int)))) (mkArray n)+  where+    newArr = test_blowup (n-1)++idx :: Int -> Exp DIM1+idx i = lift (Z:.i)++test_bfs :: Acc (Array DIM1 Int)+test_bfs = A.map (\x -> (map2 ! (idx 1)) +  (map1 ! (idx 2)) + x) arr+  where+    map1 :: Acc (Array DIM1 Int)+    map1 =  A.map (\y -> (map2 ! (idx 3)) + y) arr++    map2 :: Acc (Array DIM1 Int)+    map2 =  A.map (\z -> z + 1) arr++    arr :: Acc (Array DIM1 Int)+    arr =  mkArray 666++test_two_lets_same_level_1 :: Acc (Array DIM1 Int)+test_two_lets_same_level_1 =+  let arr1 = mkArray 1+  in let arr2 = mkArray 2+     in  A.map (\_ -> arr1!(idx 1) + arr1!(idx 2) + arr2!(idx 3) + arr2!(idx 4)) (mkArray 3)++test_two_lets_same_level_2 :: Acc (Array DIM1 Int)+test_two_lets_same_level_2 =+ let arr2 = mkArray 2+ in let arr1 = mkArray 1+    in  A.map (\_ -> arr1!(idx 1) + arr1!(idx 2) + arr2!(idx 3) + arr2!(idx 4)) (mkArray 3)+++-- These two programs test that lets can be introduced not just at the top of a AST+-- but in intermediate nodes.+--+test_no_let_at_top_1 :: Acc (Array DIM1 Int)+test_no_let_at_top_1 = A.map (\x -> x + 1) test_bfs++test_no_let_at_top_2 :: Acc (Array DIM1 Int)+test_no_let_at_top_2+  = A.map (\x -> x + 2)+  $ A.map (\x -> x + 1) test_bfs++--+--+--+test_simple :: Acc (Array DIM1 (Int,Int))+test_simple = A.map (\_ -> a ! (idx 1))  d+  where+    c = use $ A.fromList (Z :. 3) [1..]+    d = A.map (+1) c+    a = A.zip d c+++-- sortKey is a real program that Ben Lever wrote. It has some pretty interesting+-- sharing going on.+--+sortKey :: (Elt e)+        => (Exp e -> Exp Int)         -- ^mapping function to produce key array from input array+        -> Acc (Vector e)+        -> Acc (Vector e)+sortKey keyFun arr =  foldl sortOneBit arr (P.map lift ([0..31] :: [Int]))+  where+    sortOneBit inArr bitNum = outArr+      where+        keys    = A.map keyFun inArr++        bits    = A.map (\a -> (A.testBit a bitNum) ? (1, 0)) keys+        bitsInv = A.map (\b -> (b A.== 0) ? (1, 0)) bits++        (falses, numZeroes) = unlift (A.scanl' (+) 0 bitsInv)+        trues               = A.map (\x -> (A.the numZeroes) + (A.fst x) - (A.snd x))+                            $ A.zip ixs falses++        dstIxs = A.map (\x -> let (b, t, f) = unlift x  in (b A.== (constant (0::Int))) ? (f, t))+               $ A.zip3 bits trues falses+        outArr = scatter dstIxs inArr inArr -- just use input as default array+                                            --(we're writing over everything anyway)+    --+    ixs   = enumeratedArray (shape arr)++-- Create an array where each element is the value of its corresponding+-- row-major index.+--+enumeratedArray :: Exp DIM1 -> Acc (Array DIM1 Int)+enumeratedArray sh = A.generate sh unindex1++test_sort :: Acc (Vector Int)+test_sort = sortKey id $ use $ fromList (Z:.10) [9,8,7,6,5,4,3,2,1,0]++-- map1 has children map3 and map2.+-- map2 has child map3.+-- Back when we still used a list for the NodeCounts data structure this mean that+-- you would be merging [1,3,2] with [2,3] which violated precondition of (+++).+-- This tests that the new algorithm works just fine on this.+--+test_ordering :: Acc (Array DIM1 Int)+test_ordering = A.map (\_ -> map1 ! (idx 1) + map2 ! (idx 1)) arr+  where+    map1 = A.map (\_ -> map3 ! (idx 1) + map2 ! (idx 2)) arr+    map2 = A.map (\_ -> map3 ! (idx 3)) arr+    map3 = A.map (+1) arr+    arr  = mkArray 42+++-- Tests array-valued lambdas in conjunction with sharing recovery.+--+test_pipe :: Acc (Vector Int)+test_pipe = (acc1 >-> acc2) xs+  where+    z :: Acc (Scalar Int)+    z = unit 0++    xs :: Acc (Vector Int)+    xs = use $ fromList (Z:.10) [0..]++    acc1 :: Acc (Vector Int) -> Acc (Vector Int)+    acc1 = A.map (\_ -> the z)++    acc2 :: Acc (Vector Int) -> Acc (Vector Int)+    acc2 arr = let arr2 = use $ fromList (Z:.10) [10..]+               in  A.map (\_ -> arr2!constant (Z:.(0::Int))) (A.zip arr arr2)+++-- Test for bound variables+--+test_bound_variables :: Acc (Array DIM2 Int, Array DIM2 Float, Array DIM2 Float)+test_bound_variables = lift (first, both, second)+  where+    is :: Array DIM2 Int+    is = fromList (Z:.10:.10) [0..]++    fs :: Array DIM2 Float+    fs = fromList (Z:.10:.10) [0..]++    -- Ignoring the first parameter+    first = stencil2 centre clamp (use fs) clamp (use is)+      where+        centre :: Stencil3x3 Float -> Stencil3x3 Int -> Exp Int+        centre _ (_,(_,y,_),_)  = y++    -- Using both+    both = stencil2 centre clamp (use fs) clamp (use is)+      where+        centre :: Stencil3x3 Float -> Stencil3x3 Int -> Exp Float+        centre (_,(_,x,_),_) (_,(_,y,_),_)  = x + A.fromIntegral y++    -- Not using the second parameter+    second = stencil2 centre clamp (use fs) clamp (use is)+      where+        centre :: Stencil3x3 Float -> Stencil3x3 Int -> Exp Float+        centre (_,(_,x,_),_) _  = x++-- Test for 8 and 9 tuples+--+test_big_tuple :: Exp ((Int,Int,Int,Int,Int,Int,Int,Int), (Int,Int,Int,Int,Int,Int,Int,Int,Int))+test_big_tuple = lift (A.constant (0,0,0,0,0,0,0,0), A.constant (0,0,0,0,0,0,0,0,0))++{--+-- Tests for sharing recovery of iteration+--+iteration :: Test+iteration = testGroup "iteration"+  [+    iter "simple"             test1+  , iter "outside"            test2+  , iter "body and condition" test3+  , iter "awhile"             awhile_test+  , iter "iterate"            iterate_test+  , iter "nested"             nested+  , iter "unused"             unused+  ]+  where+    iter :: Show a => TestName -> a -> Test+    iter name acc = testCase name (P.length (show acc) `seq` return ())+--}++v1 :: Acc (Vector Float)+v1 = use $ fromList (Z:.10) [0..]++test_iteration_simple :: Acc (Vector Float)+test_iteration_simple+  = flip A.map v1+  $ \x -> A.while (A.< x) (+1) 0++test_iteration_outside :: Acc (Vector Float)+test_iteration_outside+  = flip A.map v1+  $ \x -> let y = 2*pi+          in  y + A.while (A.< 10) (+y) x++test_iteration_body_condition :: Acc (Vector Float)+test_iteration_body_condition+  = flip A.map v1+  $ \x -> A.while (A.< x) (+x) 0++test_awhile :: Acc (Vector Float)+test_awhile = A.awhile (\a -> A.unit (the (A.sum a) A.< 200)) (A.map (+1)) v1++test_iterate :: Acc (Vector Float)+test_iterate+  = flip A.map v1+  $ \x -> let y = 2*x+          in  y + A.iterate (constant 10) (\x' -> y + x' + 10) x++test_for :: Elt a => Exp Int -> (Exp Int -> Exp a -> Exp a) -> Exp a -> Exp a+test_for n f seed+  = A.snd+  $ A.iterate n (\v -> let (i, x) = unlift v+                       in  lift (i+1, f i x))+                (lift (constant 0, seed))++test_nested_iteration :: Exp Int+test_nested_iteration =+  test_for 64 (\i _ ->+    test_for 64 (\j acc' -> i + j + acc') 0) 0++test_unused_iteration :: Exp Int+test_unused_iteration =+  A.while (A.== 10) (const 10) 5++----------------------------------------------------------------------++-- This program contains nested data-parallelism and thus sharing recovery+-- will fail.+--+test_nested_data_praallelism :: Acc (Vector Float)+test_nested_data_praallelism =+  mvm (use $ fromList (Z:.10:.10) [0..]) (use $ fromList (Z:.10) [0..])+  where+    dotp :: A.Num e => Acc (Vector e) -> Acc (Vector e) -> Acc (Scalar e)+    dotp xs ys = A.fold (+) 0 $ A.zipWith (*) xs ys++    takeRow :: Elt e => Exp Int -> Acc (Array DIM2 e) -> Acc (Vector e)+    takeRow n mat =+      let Z :. _ :. cols = unlift (shape mat) :: Z:. Exp Int :. Exp Int+      in backpermute (index1 cols)+                     (\ix -> index2 n (unindex1 ix))+                     mat++    mvm :: A.Num e => Acc (Array DIM2 e) -> Acc (Vector e) -> Acc (Vector e)+    mvm mat vec =+      let Z :. rows :. _ = unlift (shape mat) :: Z :. Exp Int :. Exp Int+      in generate (index1 rows)+                  (\ix -> the (vec `dotp` takeRow (unindex1 ix) mat))+
+ src/Data/Array/Accelerate/Test/NoFib/Spectral.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Spectral+-- Copyright   : [2009..2017] 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.Test.NoFib.Spectral (++  test_spectral,++  module Data.Array.Accelerate.Test.NoFib.Spectral.SMVM,+  module Data.Array.Accelerate.Test.NoFib.Spectral.RadixSort,+  module Data.Array.Accelerate.Test.NoFib.Spectral.BlackScholes,++) where++import Test.Tasty++import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Spectral.SMVM+import Data.Array.Accelerate.Test.NoFib.Spectral.RadixSort+import Data.Array.Accelerate.Test.NoFib.Spectral.BlackScholes+++test_spectral :: RunN -> TestTree+test_spectral runN =+  testGroup "spectral"+    [ test_blackscholes runN+    , test_smvm runN+    , test_radixsort runN+    ]+
+ src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Spectral.BlackScholes+-- Copyright   : [2009..2017] 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.Test.NoFib.Spectral.BlackScholes (++  test_blackscholes,++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Array.Sugar                            as S+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_blackscholes :: RunN -> TestTree+test_blackscholes runN =+  testGroup "blackscholes"+    [ at (Proxy::Proxy TestHalf)   $ testElt (Gen.realFloat :: Range Half -> Gen Half)+    , at (Proxy::Proxy TestFloat)  $ testElt Gen.float+    , at (Proxy::Proxy TestDouble) $ testElt Gen.double+    ]+  where+    testElt+        :: forall a. (P.Floating a, P.Ord a, A.Floating a, A.Ord a , Similar a)+        => (Range a -> Gen a)+        -> TestTree+    testElt e =+      testProperty (show (typeOf (undefined :: a))) $ test_blackscholes' runN e+++test_blackscholes'+    :: (P.Floating a, P.Ord a, A.Floating a, A.Ord a, Similar a)+    => RunN+    -> (Range a -> Gen a)+    -> Property+test_blackscholes' runN e =+  property $ do+    sh  <- forAll ((Z :.) <$> Gen.int (Range.linear 0 16384))+    psy <- forAll (array sh ((,,) <$> e (Range.linearFrac 5 30)+                                  <*> e (Range.linearFrac 1 100)+                                  <*> e (Range.linearFrac 0.25 10)))+    --+    let !go = runN blackscholes in go psy ~~~ blackscholesRef psy+++riskfree, volatility :: P.Floating a => a+riskfree   = 0.02+volatility = 0.30++horner :: P.Num a => [a] -> a -> a+horner coeff x = x * foldr1 madd coeff+  where+    madd a b = a + x*b++cnd' :: P.Floating a => a -> a+cnd' d =+  let poly     = horner coeff+      coeff    = [0.31938153,-0.356563782,1.781477937,-1.821255978,1.330274429]+      rsqrt2pi = 0.39894228040143267793994605993438+      k        = 1.0 / (1.0 + 0.2316419 * abs d)+  in+  rsqrt2pi * exp (-0.5*d*d) * poly k+++blackscholes :: (P.Floating a, A.Floating a, A.Ord a) => Acc (Vector (a, a, a)) -> Acc (Vector (a, a))+blackscholes = A.map go+  where+  go (A.unlift -> (price,strike,years)) =+    let+        r       = A.constant riskfree+        v       = A.constant volatility+        v_sqrtT = v * sqrt years+        d1      = (log (price / strike) + (r + 0.5 * v * v) * years) / v_sqrtT+        d2      = d1 - v_sqrtT+        cnd d   = let c = cnd' d in d A.> 0 ? (1.0 - c, c)+        cndD1   = cnd d1+        cndD2   = cnd d2+        x_expRT = strike * exp (-r * years)+    in+    A.lift ( price * cndD1 - x_expRT * cndD2+           , x_expRT * (1.0 - cndD2) - price * (1.0 - cndD1))+++blackscholesRef :: (P.Floating a, P.Ord a, Elt a) => Vector (a, a, a) -> Vector (a, a)+blackscholesRef psy = fromFunction (S.shape psy) (go . indexArray psy)+  where+    go (price, strike, years) =+      let+          r       = riskfree+          v       = volatility+          v_sqrtT = v * sqrt years+          d1      = (log (price / strike) + (r + 0.5 * v * v) * years) / v_sqrtT+          d2      = d1 - v_sqrtT+          cnd d   = let c = cnd' d in if d P.> 0+                                        then 1.0 - c+                                        else c+          cndD1   = cnd d1+          cndD2   = cnd d2+          x_expRT = strike * exp (-r * years)+      in+      ( price * cndD1 - x_expRT * cndD2+      , x_expRT * (1.0 - cndD2) - price * (1.0 - cndD1)+      )+
+ src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE MonoLocalBinds      #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Spectral.RadixSort+-- Copyright   : [2009..2017] 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.Test.NoFib.Spectral.RadixSort (++  test_radixsort,++) where++import Data.Proxy+import Data.Typeable+import Data.Function+import Data.List+import Prelude                                                      as P+import qualified Data.Bits                                          as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Data.Bits                              as A+import Data.Array.Accelerate.Array.Sugar                            as S ( shape )+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_radixsort :: RunN -> TestTree+test_radixsort runN =+  testGroup "radixsort"+    [ at (Proxy::Proxy TestInt8)   $ testElt i8+    , at (Proxy::Proxy TestInt16)  $ testElt i16+    , at (Proxy::Proxy TestInt32)  $ testElt i32+    , at (Proxy::Proxy TestInt64)  $ testElt i64+    , at (Proxy::Proxy TestWord8)  $ testElt w8+    , at (Proxy::Proxy TestWord16) $ testElt w16+    , at (Proxy::Proxy TestWord32) $ testElt w32+    , at (Proxy::Proxy TestWord64) $ testElt w64+    -- , at (Proxy::Proxy TestFloat)  $ testElt f32+    -- , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (Similar a, P.Ord a, Radix a)+        => Gen a+        -> TestTree+    testElt e =+      testGroup (show (typeOf (undefined :: a)))+        [ testProperty "ascending"    $ test_sort_ascending runN e+        , testProperty "descending"   $ test_sort_descending runN e+        , testProperty "key-value"    $ test_sort_keyval runN e f32+        ]++test_sort_ascending+    :: (P.Ord e, Radix e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_sort_ascending runN e =+  property $ do+    sh <- forAll ((Z :.) <$> Gen.int (Range.linear 0 128))  -- just pick a small array; the algorithm is terrible+    xs <- forAll (array sh e)+    let !go = runN radixsort in go xs ~~~ sortRef P.compare xs++test_sort_descending+    :: (P.Ord e, Radix e, Similar e)+    => RunN+    -> Gen e+    -> Property+test_sort_descending runN e =+  property $ do+    sh <- forAll ((Z :.) <$> Gen.int (Range.linear 0 128))+    xs <- forAll (array sh e)+    let !go = runN (radixsortBy complement) in go xs ~~~ sortRef (flip P.compare) xs++test_sort_keyval+    :: (P.Ord k, Radix k, Similar k, Elt v, Similar v)+    => RunN+    -> Gen k+    -> Gen v+    -> Property+test_sort_keyval runN key val =+  property $ do+    sh <- forAll ((Z :.) <$> Gen.int (Range.linear 0 128))+    xs <- forAll (array sh ((,) <$> key <*> val))+    let !go = runN (radixsortBy A.fst) in go xs ~~~ sortRef (P.compare `on` P.fst) xs+++class A.Bits e => Radix e where+  passes :: e {- dummy -} -> Int+  radix  :: Exp Int -> Exp e -> Exp Int++instance Radix Int8 where+  passes = P.finiteBitSize+  radix  = radixOfSigned++instance Radix Int16 where+  passes = P.finiteBitSize+  radix  = radixOfSigned++instance Radix Int32 where+  passes = P.finiteBitSize+  radix  = radixOfSigned++instance Radix Int64 where+  passes = P.finiteBitSize+  radix  = radixOfSigned++instance Radix Word8 where+  passes = P.finiteBitSize+  radix  = radixOfUnsigned++instance Radix Word16 where+  passes = P.finiteBitSize+  radix  = radixOfUnsigned++instance Radix Word32 where+  passes = P.finiteBitSize+  radix  = radixOfUnsigned++instance Radix Word64 where+  passes = P.finiteBitSize+  radix  = radixOfUnsigned++radixOfSigned+    :: forall e. (Radix e, A.Bounded e, A.Integral e, A.FromIntegral e Int)+    => Exp Int+    -> Exp e+    -> Exp Int+radixOfSigned i e = i A.== (passes' - 1) ? (radix' (e `xor` minBound), radix' e)+   where+     radix' x = A.fromIntegral $ (x `A.shiftR` i) .&. 1+     passes'  = constant (passes (undefined :: e))++radixOfUnsigned+    :: (Radix e, A.Integral e, A.FromIntegral e Int)+    => Exp Int+    -> Exp e+    -> Exp Int+radixOfUnsigned i e = A.fromIntegral $ (e `A.shiftR` i) .&. 1+++-- A simple (parallel) radix sort implementation [1].+--+-- [1] G. E. Blelloch. "Prefix sums and their applications." Technical Report+--     CMU-CS-90-190. Carnegie Mellon University. 1990.+--+radixsort :: Radix a => Acc (Vector a) -> Acc (Vector a)+radixsort = radixsortBy id++radixsortBy :: forall a r. (Elt a, Radix r) => (Exp a -> Exp r) -> Acc (Vector a) -> Acc (Vector a)+radixsortBy rdx arr = foldr1 (>->) (P.map radixPass [0..p-1]) arr+  where+    p = passes (undefined :: r)+    --+    deal f x      = let (a,b)   = unlift x in (f A.== 0) ? (a,b)+    radixPass k v = let k'      = unit (constant k)+                        flags   = A.map (radix (the k') . rdx) v+                        idown   = prescanl (+) 0 . A.map (xor 1)        $ flags+                        iup     = A.map (size v - 1 -) . prescanr (+) 0 $ flags+                        index   = A.zipWith deal flags (A.zip idown iup)+                    in+                    permute const v (\ix -> index1 (index!ix)) v+++-- This is rather slow. Speeding up the reference implementation by using, say,+-- vector-algorithms, does not significantly change the runtime.+--+sortRef :: Elt a => (a -> a -> Ordering) -> Vector a -> Vector a+sortRef cmp xs = fromList (S.shape xs) (sortBy cmp (toList xs))+
+ src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+-- |+-- Module      : Data.Array.Accelerate.Test.NoFib.Spectral.SMVM+-- Copyright   : [2009..2017] 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.Test.NoFib.Spectral.SMVM (++  test_smvm,++) where++import Data.Proxy+import Data.Typeable+import Prelude                                                      as P++import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Array.Sugar                            as S+import Data.Array.Accelerate.Test.NoFib.Base+import Data.Array.Accelerate.Test.NoFib.Config+import Data.Array.Accelerate.Test.Similar++import Hedgehog+import qualified Hedgehog.Gen                                       as Gen+import qualified Hedgehog.Range                                     as Range++import Test.Tasty+import Test.Tasty.Hedgehog+++test_smvm :: RunN -> TestTree+test_smvm runN =+  testGroup "smvm"+    [ at (Proxy::Proxy TestHalf)   $ testElt f16+    , at (Proxy::Proxy TestFloat)  $ testElt f32+    , at (Proxy::Proxy TestDouble) $ testElt f64+    ]+  where+    testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a)+        => Gen a+        -> TestTree+    testElt e =+      testProperty (show (typeOf (undefined :: a))) $ test_smvm' runN e+++test_smvm' :: (A.Num e, P.Num e, Similar e) => RunN -> Gen e -> Property+test_smvm' runN e =+  property $ do+    (smat, cols) <- forAll (sparseMatrix e)+    vec          <- forAll (array (Z:.cols) e)+    --+    let !go = runN smvm in go smat vec ~~~ smvmRef smat vec+++sparseMatrix :: Elt e => Gen e -> Gen (SparseMatrix e, Int)+sparseMatrix e = do+  rows  <- Gen.int (Range.linear 1 256)+  cols  <- Gen.int (Range.linear 1 256)+  seg   <- array (Z:.rows) (Gen.int (Range.linear 0 cols))+  let nnz = P.sum (S.toList seg)+  smat  <- array (Z:.nnz) ((,) <$> Gen.int (Range.linear 0 (cols-1)) <*> e)+  return ((seg,smat), cols)+++type SparseVector e = Vector (Int, e)+type SparseMatrix e = (Segments Int, SparseVector e)++smvm :: A.Num a => Acc (SparseMatrix a) -> Acc (Vector a) -> Acc (Vector a)+smvm smat vec+  = let (segd, svec)    = unlift smat+        (inds, vals)    = A.unzip svec++        vecVals         = A.gather inds vec+        products        = A.zipWith (*) vecVals vals+    in+    foldSeg (+) 0 products segd++smvmRef :: (Elt a, P.Num a) => SparseMatrix a -> Vector a -> Vector a+smvmRef (segd, smat) vec =+  fromList (S.shape segd)+           [ P.sum [ val * indexArray vec (Z :. i) | (i,val) <- row ]+                   | row <- splitPlaces (toList segd) (toList smat) ]+
+ src/Data/Array/Accelerate/Test/Similar.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators     #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Test.Similar+-- Copyright   : [2017] 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.Test.Similar+  where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Data.Complex+import Data.Array.Accelerate.Type++import Hedgehog+import Hedgehog.Internal.Source                           ( HasCallStack, withFrozenCallStack )++import Prelude                                            hiding ( (!!) )+++-- | Fails the test if the two arguments are not equal, allowing for a small+-- amount of floating point inaccuracy.+--+infix 4 ~~~+(~~~) :: (MonadTest m, Similar a, Show a, HasCallStack) => a -> a -> m ()+a ~~~ b = withFrozenCallStack $ Sim a === Sim b++data Sim a = Sim a++instance Similar a => Eq (Sim a) where+  Sim a == Sim b = a ~= b++instance Show a => Show (Sim a) where+  show (Sim a) = show a+++-- | A class of things that support almost-equality, so that we can disregard+-- small amounts of floating-point round-off error.+--+class Similar a where+  {-# INLINE (~=) #-}+  (~=) :: a -> a -> Bool+  default (~=) :: Eq a => a -> a -> Bool+  (~=) = (==)++infix 4 ~=++instance Similar ()+instance Similar Z+instance Similar All+instance Similar Int+instance Similar Int8+instance Similar Int16+instance Similar Int32+instance Similar Int64+instance Similar Word8+instance Similar Word16+instance Similar Word32+instance Similar Word64+instance Similar Char+instance Similar Bool+instance Similar CShort+instance Similar CUShort+instance Similar CInt+instance Similar CUInt+instance Similar CLong+instance Similar CULong+instance Similar CLLong+instance Similar CULLong+instance Similar CChar+instance Similar CSChar+instance Similar CUChar++instance                   Similar (Any Z)+instance (Eq sh, Eq sz) => Similar (sh:.sz)+instance (Eq sh)        => Similar (Any (sh:.Int))++instance Similar Half    where (~=) = absRelTol 0.05    0.5+instance Similar Float   where (~=) = absRelTol 0.00005 0.005+instance Similar Double  where (~=) = absRelTol 0.00005 0.005+instance Similar CFloat  where (~=) = absRelTol 0.00005 0.005+instance Similar CDouble where (~=) = absRelTol 0.00005 0.005++instance (Similar a, Similar b) => Similar (a, b) where+  (x1, x2) ~= (y1, y2) = x1 ~= y1 && x2 ~= y2++instance (Similar a, Similar b, Similar c) => Similar (a, b, c) where+  (x1, x2, x3) ~= (y1, y2, y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3++instance (Similar a, Similar b, Similar c, Similar d) => Similar (a, b, c, d) where+  (x1, x2, x3, x4) ~= (y1, y2, y3, y4) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4++instance (Similar a, Similar b, Similar c, Similar d, Similar e)+    => Similar (a, b, c, d, e) where+  (x1, x2, x3, x4, x5) ~= (y1, y2, y3, y4, y5) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f)+    => Similar (a, b, c, d, e, f) where+  (x1, x2, x3, x4, x5, x6) ~= (y1, y2, y3, y4, y5, y6) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g)+    => Similar (a, b, c, d, e, f, g) where+  (x1, x2, x3, x4, x5, x6, x7) ~= (y1, y2, y3, y4, y5, y6, y7) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h)+    => Similar (a, b, c, d, e, f, g, h) where+  (x1, x2, x3, x4, x5, x6, x7, x8) ~= (y1, y2, y3, y4, y5, y6, y7, y8) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i)+    => Similar (a, b, c, d, e, f, g, h, i) where+  (x1, x2, x3, x4, x5, x6, x7, x8, x9) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i, Similar j)+    => Similar (a, b, c, d, e, f, g, h, i, j) where+  (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9 && x10 ~= y10++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i, Similar j, Similar k)+    => Similar (a, b, c, d, e, f, g, h, i, j, k) where+  (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9 && x10 ~= y10 && x11 ~= y11++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i, Similar j, Similar k, Similar l)+    => Similar (a, b, c, d, e, f, g, h, i, j, k, l) where+  (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9 && x10 ~= y10 && x11 ~= y11 && x12 ~= y12++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i, Similar j, Similar k, Similar l, Similar m)+    => Similar (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9 && x10 ~= y10 && x11 ~= y11 && x12 ~= y12 && x13 ~= y13++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i, Similar j, Similar k, Similar l, Similar m, Similar n)+    => Similar (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13, y14) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9 && x10 ~= y10 && x11 ~= y11 && x12 ~= y12 && x13 ~= y13 && x14 ~= y14++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i, Similar j, Similar k, Similar l, Similar m, Similar n, Similar o)+    => Similar (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13, y14, y15) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9 && x10 ~= y10 && x11 ~= y11 && x12 ~= y12 && x13 ~= y13 && x14 ~= y14 && x15 ~= y15++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i, Similar j, Similar k, Similar l, Similar m, Similar n, Similar o, Similar p)+    => Similar (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where+  (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13, y14, y15, y16) =+    x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9 && x10 ~= y10 && x11 ~= y11 && x12 ~= y12 && x13 ~= y13 && x14 ~= y14 && x15 ~= y15 && x16 ~= y16++instance Similar e => Similar (Complex e) where+  (r1 :+ i1) ~= (r2 :+ i2) = r1 ~= r2 && i1 ~= i2++instance Similar a => Similar [a] where+  []     ~= []     = True+  (x:xs) ~= (y:ys) = x ~= y && xs ~= ys+  _      ~= _      = False++instance (Similar e, Eq sh, Shape sh) => Similar (Array sh e) where+  a1 ~= a2 = shape a1 == shape a2 && go 0+    where+      n     = size (shape a1)+      go !i+        | i >= n              = True+        | a1 !! i ~= a2 !! i  = go (i+1)+        | otherwise           = False++{-# INLINEABLE absRelTol #-}+absRelTol :: RealFloat a => a -> a -> a -> a -> Bool+absRelTol epsilonAbs epsilonRel u v+  |  isInfinite u+  && isInfinite v          = True+  |  isNaN u+  && isNaN v               = True+  | abs (u-v) < epsilonAbs = True+  | abs u > abs v          = abs ((u-v) / u) < epsilonRel+  | otherwise              = abs ((v-u) / v) < epsilonRel+
+ src/Data/Array/Accelerate/Trafo.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE MonoLocalBinds       #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Trafo+-- 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.Trafo (++  -- * HOAS -> de Bruijn conversion+  Phase(..), phases,++  -- ** Array computations+  convertAcc, convertAccWith,++  -- ** Array functions+  Afunction, AfunctionR,+  convertAfun, convertAfunWith,++  -- ** Sequence computations+  -- convertSeq, convertSeqWith,++  -- * Fusion+  module Data.Array.Accelerate.Trafo.Fusion,++  -- * Substitution+  module Data.Array.Accelerate.Trafo.Substitution,++  -- * Term equality+  Match(..), (:~:)(..),++  -- ** Auxiliary+  matchDelayedOpenAcc, encodeDelayedOpenAcc, hashDelayedOpenAcc,++) where++import Control.DeepSeq+import Data.Typeable++import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Pretty                     ( ) -- show instances+import Data.Array.Accelerate.Array.Sugar                ( Arrays, Elt )+import Data.Array.Accelerate.Trafo.Base+import Data.Array.Accelerate.Trafo.Fusion               hiding ( convertAcc, convertAfun ) -- to export types+import Data.Array.Accelerate.Trafo.Sharing              ( Function, FunctionR, Afunction, AfunctionR )+import Data.Array.Accelerate.Trafo.Substitution+import qualified Data.Array.Accelerate.AST              as AST+import qualified Data.Array.Accelerate.Trafo.Fusion     as Fusion+import qualified Data.Array.Accelerate.Trafo.Rewrite    as Rewrite+import qualified Data.Array.Accelerate.Trafo.Simplify   as Rewrite+import qualified Data.Array.Accelerate.Trafo.Sharing    as Sharing+-- import qualified Data.Array.Accelerate.Trafo.Vectorise  as Vectorise++#ifdef ACCELERATE_DEBUG+import Text.Printf+import System.IO.Unsafe+import Data.Array.Accelerate.Debug                      hiding ( when )+import qualified Data.Array.Accelerate.Debug            as Debug+#endif+++-- Configuration+-- -------------++data Phase = Phase+  {+    -- | Recover sharing of array computations?+    recoverAccSharing           :: Bool++    -- | Recover sharing of scalar expressions?+  , recoverExpSharing           :: Bool++    -- | Recover sharing of sequence computations?+  , recoverSeqSharing           :: Bool++    -- | Are array computations floated out of expressions irrespective of+    --   whether they are shared or not? Requires 'recoverAccSharing'.+  , floatOutAccFromExp          :: Bool++    -- | Fuse array computations? This also implies simplifying scalar+    --   expressions. NOTE: currently always enabled.+  , enableAccFusion             :: Bool++    -- | Convert segment length arrays into segment offset arrays?+  , convertOffsetOfSegment      :: Bool++    --   Vectorise maps and zipwiths in sequence computations to+    --   enable chunked execution?+  -- , vectoriseSequences          :: Bool+  }+++-- | The default method of converting from HOAS to de Bruijn; incorporating+--   sharing recovery and fusion optimisation.+--+phases :: Phase+phases =  Phase+  { recoverAccSharing      = True+  , recoverExpSharing      = True+  , recoverSeqSharing      = True+  , floatOutAccFromExp     = True+  , enableAccFusion        = True+  , convertOffsetOfSegment = False+  -- , vectoriseSequences     = True+  }++when :: (a -> a) -> Bool -> a -> a+when f True  = f+when _ False = id+++-- HOAS -> de Bruijn conversion+-- ----------------------------++-- | Convert a closed array expression to de Bruijn form while also+--   incorporating sharing observation and array fusion.+--+convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc arrs+convertAcc = convertAccWith phases++convertAccWith :: Arrays arrs => Phase -> Acc arrs -> DelayedAcc arrs+convertAccWith Phase{..} acc+  = phase "array-fusion"           (Fusion.convertAcc enableAccFusion)+  -- phase "vectorise-sequences"    Vectorise.vectoriseSeqAcc `when` vectoriseSequences+  $ phase "rewrite-segment-offset" Rewrite.convertSegments   `when` convertOffsetOfSegment+  $ phase "sharing-recovery"       (Sharing.convertAcc recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp)+  $ acc+++-- | Convert a unary function over array computations, incorporating sharing+--   observation and array fusion+--+convertAfun :: Afunction f => f -> DelayedAfun (AfunctionR f)+convertAfun = convertAfunWith phases++convertAfunWith :: Afunction f => Phase -> f -> DelayedAfun (AfunctionR f)+convertAfunWith Phase{..} acc+  = phase "array-fusion"           (Fusion.convertAfun enableAccFusion)+  -- phase "vectorise-sequences"    Vectorise.vectoriseSeqAfun  `when` vectoriseSequences+  $ phase "rewrite-segment-offset" Rewrite.convertSegmentsAfun `when` convertOffsetOfSegment+  $ phase "sharing-recovery"       (Sharing.convertAfun recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp)+  $ acc+++-- | Convert a closed scalar expression, incorporating sharing observation and+--   optimisation.+--+convertExp :: Elt e => Exp e -> AST.Exp () e+convertExp+  = phase "exp-simplify"      Rewrite.simplify+  . phase "sharing-recovery" (Sharing.convertExp (recoverExpSharing phases))+++-- | Convert closed scalar functions, incorporating sharing observation and+--   optimisation.+--+convertFun :: Function f => f -> AST.Fun () (FunctionR f)+convertFun+  = phase "exp-simplify"      Rewrite.simplify+  . phase "sharing-recovery" (Sharing.convertFun (recoverExpSharing phases))++{--+-- | Convert a closed sequence computation, incorporating sharing observation and+--   optimisation.+--+convertSeq :: Typeable s => Seq s -> DelayedSeq s+convertSeq = convertSeqWith phases++convertSeqWith :: Typeable s => Phase -> Seq s -> DelayedSeq s+convertSeqWith Phase{..} s+  = phase "array-fusion"           (Fusion.convertSeq enableAccFusion)+  -- $ phase "vectorise-sequences"    Vectorise.vectoriseSeq     `when` vectoriseSequences+  $ phase "rewrite-segment-offset" Rewrite.convertSegmentsSeq `when` convertOffsetOfSegment+  $ phase "sharing-recovery"       (Sharing.convertSeq recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp)+  $ s+--}++-- Pretty printing+-- ---------------++instance Arrays arrs => Show (Acc arrs) where+  show = withSimplStats . show . convertAcc++instance Afunction (Acc a -> f) => Show (Acc a -> f) where+  show = withSimplStats . show . convertAfun++instance Elt e => Show (Exp e) where+  show = withSimplStats . show . convertExp++instance Function (Exp a -> f) => Show (Exp a -> f) where+  show = withSimplStats . show . convertFun++-- instance Typeable a => Show (Seq a) where+--   show = withSimplStats . show . convertSeq+++-- Debugging+-- ---------++-- Attach simplifier statistics to the tail of the given string. Since the+-- statistics rely on fully evaluating the expression this is difficult to do+-- generally (without an additional deepseq), but easy enough for our show+-- instances.+--+-- For now, we just reset the statistics at the beginning of a conversion, and+-- leave it to a backend to choose an appropriate moment to dump the summary.+--+withSimplStats :: String -> String+#ifdef ACCELERATE_DEBUG+withSimplStats x = unsafePerformIO $ do+  Debug.when dump_simpl_stats $ x `deepseq` dumpSimplStats+  return x+#else+withSimplStats x = x+#endif++-- Execute a phase of the compiler and (possibly) print some timing/gc+-- statistics.+--+phase :: NFData b => String -> (a -> b) -> a -> b+#ifdef ACCELERATE_DEBUG+phase n f x = unsafePerformIO $ do+  enabled <- getFlag dump_phases+  if enabled+    then timed dump_phases (\wall cpu -> printf "phase %s: %s" n (elapsed wall cpu)) (return $!! f x)+    else return (f x)+#else+phase _ f x = f x+#endif+
+ src/Data/Array/Accelerate/Trafo/Algebra.hs view
@@ -0,0 +1,793 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.Trafo.Algebra+-- 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)+--+-- Algebraic simplifications of scalar expressions, including constant folding+-- and using algebraic properties of particular operator-operand combinations.+--++module Data.Array.Accelerate.Trafo.Algebra (++  evalPrimApp,++) where++import Data.Bits+import Data.Char+import Data.Monoid+import GHC.Float                                        ( float2Double, double2Float )+import Text.PrettyPrint.ANSI.Leijen+import Prelude                                          hiding ( exp )+import qualified Prelude                                as P++-- friends+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Sugar                hiding ( Any )+import Data.Array.Accelerate.Pretty.Print               ( prettyPrim )+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Trafo.Base+import Data.Array.Accelerate.Type++import qualified Data.Array.Accelerate.Debug            as Stats+++-- Propagate constant expressions, which are either constant valued expressions+-- or constant let bindings. Be careful not to follow self-cycles.+--+propagate+    :: forall acc env aenv exp. Kit acc+    => Gamma acc env env aenv+    -> PreOpenExp acc env aenv exp+    -> Maybe exp+propagate env = cvtE+  where+    cvtE :: PreOpenExp acc env aenv e -> Maybe e+    cvtE exp = case exp of+      Const c                                   -> Just (toElt c)+      PrimConst c                               -> Just (evalPrimConst c)+      Prj ix (Var v) | Tuple t <- prjExp v env  -> cvtT ix t+      Prj ix e       | Just c  <- cvtE e        -> cvtP ix (fromTuple c)+      Var ix+        | e             <- prjExp ix env+        , Nothing       <- match exp e          -> cvtE e+      --+      IndexHead (cvtE -> Just (_  :. z))        -> Just z+      IndexTail (cvtE -> Just (sh :. _))        -> Just sh+      _                                         -> Nothing++    cvtP :: TupleIdx t e -> t -> Maybe e+    cvtP ZeroTupIdx       (_, v)   = Just v+    cvtP (SuccTupIdx idx) (tup, _) = cvtP idx tup++    cvtT :: TupleIdx t e -> Tuple (PreOpenExp acc env aenv) t -> Maybe e+    cvtT ZeroTupIdx       (SnocTup _   e) = cvtE e+    cvtT (SuccTupIdx idx) (SnocTup tup _) = cvtT idx tup+#if __GLASGOW_HASKELL__ < 800+    cvtT _                _               = error "hey what's the head angle on that thing?"+#endif+++-- Attempt to evaluate primitive function applications+--+evalPrimApp+    :: forall acc env aenv a r. (Kit acc, Elt a, Elt r)+    => Gamma acc env env aenv+    -> PrimFun (a -> r)+    -> PreOpenExp acc env aenv a+    -> (Any, PreOpenExp acc env aenv r)+evalPrimApp env f x+  -- First attempt to move constant values towards the left+  | Just r      <- commutes f x env     = evalPrimApp env f r+--  | Just r      <- associates f x       = r++  -- Now attempt to evaluate any expressions+  | otherwise+  = maybe (Any False, PrimApp f x) (Any True,)+  $ case f of+      PrimAdd ty                -> evalAdd ty x env+      PrimSub ty                -> evalSub ty x env+      PrimMul ty                -> evalMul ty x env+      PrimNeg ty                -> evalNeg ty x env+      PrimAbs ty                -> evalAbs ty x env+      PrimSig ty                -> evalSig ty x env+      PrimQuot ty               -> evalQuot ty x env+      PrimRem ty                -> evalRem ty x env+      PrimQuotRem ty            -> evalQuotRem ty x env+      PrimIDiv ty               -> evalIDiv ty x env+      PrimMod ty                -> evalMod ty x env+      PrimDivMod ty             -> evalDivMod ty x env+      PrimBAnd ty               -> evalBAnd ty x env+      PrimBOr ty                -> evalBOr ty x env+      PrimBXor ty               -> evalBXor ty x env+      PrimBNot ty               -> evalBNot ty x env+      PrimBShiftL ty            -> evalBShiftL ty x env+      PrimBShiftR ty            -> evalBShiftR ty x env+      PrimBRotateL ty           -> evalBRotateL ty x env+      PrimBRotateR ty           -> evalBRotateR ty x env+      PrimPopCount ty           -> evalPopCount ty x env+      PrimCountLeadingZeros ty  -> evalCountLeadingZeros ty x env+      PrimCountTrailingZeros ty -> evalCountTrailingZeros ty x env+      PrimFDiv ty               -> evalFDiv ty x env+      PrimRecip ty              -> evalRecip ty x env+      PrimSin ty                -> evalSin ty x env+      PrimCos ty                -> evalCos ty x env+      PrimTan ty                -> evalTan ty x env+      PrimAsin ty               -> evalAsin ty x env+      PrimAcos ty               -> evalAcos ty x env+      PrimAtan ty               -> evalAtan ty x env+      PrimSinh ty               -> evalSinh ty x env+      PrimCosh ty               -> evalCosh ty x env+      PrimTanh ty               -> evalTanh ty x env+      PrimAsinh ty              -> evalAsinh ty x env+      PrimAcosh ty              -> evalAcosh ty x env+      PrimAtanh ty              -> evalAtanh ty x env+      PrimExpFloating ty        -> evalExpFloating ty x env+      PrimSqrt ty               -> evalSqrt ty x env+      PrimLog ty                -> evalLog ty x env+      PrimFPow ty               -> evalFPow ty x env+      PrimLogBase ty            -> evalLogBase ty x env+      PrimAtan2 ty              -> evalAtan2 ty x env+      PrimTruncate ta tb        -> evalTruncate ta tb x env+      PrimRound ta tb           -> evalRound ta tb x env+      PrimFloor ta tb           -> evalFloor ta tb x env+      PrimCeiling ta tb         -> evalCeiling ta tb x env+      PrimIsNaN ty              -> evalIsNaN ty x env+      PrimIsInfinite ty         -> evalIsInfinite ty x env+      PrimLt ty                 -> evalLt ty x env+      PrimGt ty                 -> evalGt ty x env+      PrimLtEq ty               -> evalLtEq ty x env+      PrimGtEq ty               -> evalGtEq ty x env+      PrimEq ty                 -> evalEq ty x env+      PrimNEq ty                -> evalNEq ty x env+      PrimMax ty                -> evalMax ty x env+      PrimMin ty                -> evalMin ty x env+      PrimLAnd                  -> evalLAnd x env+      PrimLOr                   -> evalLOr x env+      PrimLNot                  -> evalLNot x env+      PrimOrd                   -> evalOrd x env+      PrimChr                   -> evalChr x env+      PrimBoolToInt             -> evalBoolToInt x env+      PrimFromIntegral ta tb    -> evalFromIntegral ta tb x env+      PrimToFloating ta tb      -> evalToFloating ta tb x env+++-- Discriminate binary functions that commute, and if so return the operands in+-- a stable ordering. If only one of the arguments is a constant, this is placed+-- to the left of the operator. Returning Nothing indicates no change is made.+--+commutes+    :: forall acc env aenv a r. Kit acc+    => PrimFun (a -> r)+    -> PreOpenExp acc env aenv a+    -> Gamma acc env env aenv+    -> Maybe (PreOpenExp acc env aenv a)+commutes f x env = case f of+  PrimAdd _     -> swizzle x+  PrimMul _     -> swizzle x+  PrimBAnd _    -> swizzle x+  PrimBOr _     -> swizzle x+  PrimBXor _    -> swizzle x+  PrimEq _      -> swizzle x+  PrimNEq _     -> swizzle x+  PrimMax _     -> swizzle x+  PrimMin _     -> swizzle x+  _             -> Nothing+  where+    swizzle :: PreOpenExp acc env aenv (b,b) -> Maybe (PreOpenExp acc env aenv (b,b))+    swizzle (Tuple (NilTup `SnocTup` a `SnocTup` b))+      | Nothing         <- propagate env a+      , Just _          <- propagate env b+      = Stats.ruleFired (pprFun "commutes" f)+      $ Just $ Tuple (NilTup `SnocTup` b `SnocTup` a)++--    TLM: changing the ordering here when neither term can be reduced can be+--         disadvantageous: for example in (x &&* y), the user might have put a+--         simpler condition first that is designed to fail fast.+--+--      | Nothing         <- propagate env a+--      , Nothing         <- propagate env b+--      , hashOpenExp a > hashOpenExp b+--      = Just $ Tuple (NilTup `SnocTup` b `SnocTup` a)++    swizzle _+      = Nothing+++{--+-- Determine if successive applications of a binary operator will associate, and+-- if so move them to the left. That is:+--+--   a + (b + c)  -->  (a + b) + c+--+-- Returning Nothing indicates no change is made.+--+-- TLM: we might get into trouble here, as we've lost track of where the user+--      has explicitly put parenthesis.+--+-- TLM: BROKEN!! does not correctly change the sign of expressions when flipping+--      (-x+y) or (-y+x).+--+associates+    :: (Elt a, Elt r)+    => PrimFun (a -> r)+    -> PreOpenExp acc env aenv a+    -> Maybe (PreOpenExp acc env aenv r)+associates fun exp = case fun of+  PrimAdd _     -> swizzle fun exp [PrimAdd ty, PrimSub ty]+  PrimSub _     -> swizzle fun exp [PrimAdd ty, PrimSub ty]+  PrimLAnd      -> swizzle fun exp [fun]+  PrimLOr       -> swizzle fun exp [fun]+  _             -> swizzle fun exp [fun]+  where+    -- TODO: check the list of ops is complete (and correct)+    ty  = undefined+    ops = [ PrimMul ty, PrimFDiv ty, PrimAdd ty, PrimSub ty, PrimBAnd ty, PrimBOr ty, PrimBXor ty ]++    swizzle :: (Elt a, Elt r) => PrimFun (a -> r) -> PreOpenExp acc env aenv a -> [PrimFun (a -> r)] -> Maybe (PreOpenExp acc env aenv r)+    swizzle f x lvl+      | Just Refl       <- matches f ops+      , Just (a,bc)     <- untup2 x+      , PrimApp g y     <- bc+      , Just Refl       <- matches g lvl+      , Just (b,c)      <- untup2 y+      = Stats.ruleFired (pprFun "associates" f)+      $ Just $ PrimApp g (tup2 (PrimApp f (tup2 (a,b)), c))++    swizzle _ _ _+      = Nothing++    matches :: (Elt s, Elt t) => PrimFun (s -> a) -> [PrimFun (t -> a)] -> Maybe (s :=: t)+    matches _ []        = Nothing+    matches f (x:xs)+      | Just Refl       <- matchPrimFun' f x+      = Just Refl++      | otherwise+      = matches f xs+--}+++-- Helper functions+-- ----------------++type a :-> b = forall acc env aenv. Kit acc => PreOpenExp acc env aenv a -> Gamma acc env env aenv -> Maybe (PreOpenExp acc env aenv b)++eval1 :: Elt b => (a -> b) -> a :-> b+eval1 f x env+  | Just a <- propagate env x   = Stats.substitution "constant fold" . Just $ Const (fromElt (f a))+  | otherwise                   = Nothing++eval2 :: Elt c => (a -> b -> c) -> (a,b) :-> c+eval2 f (untup2 -> Just (x,y)) env+  | Just a <- propagate env x+  , Just b <- propagate env y+  = Stats.substitution "constant fold"+  $ Just $ Const (fromElt (f a b))++eval2 _ _ _+  = Nothing++tup2 :: (Elt a, Elt b) => (PreOpenExp acc env aenv a, PreOpenExp acc env aenv b) -> PreOpenExp acc env aenv (a, b)+tup2 (a,b) = Tuple (NilTup `SnocTup` a `SnocTup` b)++untup2 :: PreOpenExp acc env aenv (a, b) -> Maybe (PreOpenExp acc env aenv a, PreOpenExp acc env aenv b)+untup2 exp+  | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp = Just (a, b)+  | otherwise                                     = Nothing+++pprFun :: String -> PrimFun f -> String+pprFun rule f = show $ text rule <+> snd (prettyPrim f)+++-- Methods of Num+-- --------------++evalAdd :: Elt a => NumType a -> (a,a) :-> a+evalAdd (IntegralNumType ty) | IntegralDict <- integralDict ty = evalAdd'+evalAdd (FloatingNumType ty) | FloatingDict <- floatingDict ty = evalAdd'++evalAdd' :: (Elt a, Eq a, Num a) => (a,a) :-> a+evalAdd' (untup2 -> Just (x,y)) env+  | Just a      <- propagate env x+  , a == 0+  = Stats.ruleFired "x+0" $ Just y++evalAdd' arg env+  = eval2 (+) arg env+++evalSub :: Elt a => NumType a -> (a,a) :-> a+evalSub ty@(IntegralNumType ty') | IntegralDict <- integralDict ty' = evalSub' ty+evalSub ty@(FloatingNumType ty') | FloatingDict <- floatingDict ty' = evalSub' ty++evalSub' :: forall a. (Elt a, Eq a, Num a) => NumType a -> (a,a) :-> a+evalSub' ty (untup2 -> Just (x,y)) env+  | Just b      <- propagate env y+  , b == 0+  = Stats.ruleFired "x-0" $ Just x++  | Nothing     <- propagate env x+  , Just b      <- propagate env y+  = Stats.ruleFired "-y+x"+  $ Just . snd $ evalPrimApp env (PrimAdd ty) (Tuple $ NilTup `SnocTup` Const (fromElt (-b)) `SnocTup` x)++  | Just Refl   <- match x y+  = Stats.ruleFired "x-x"+  $ Just $ Const (fromElt (0::a))++evalSub' _ arg env+  = eval2 (-) arg env+++evalMul :: Elt a => NumType a -> (a,a) :-> a+evalMul (IntegralNumType ty) | IntegralDict <- integralDict ty = evalMul'+evalMul (FloatingNumType ty) | FloatingDict <- floatingDict ty = evalMul'++evalMul' :: (Elt a, Eq a, Num a) => (a,a) :-> a+evalMul' (untup2 -> Just (x,y)) env+  | Just a      <- propagate env x+  , Nothing     <- propagate env y+  = case a of+      0         -> Stats.ruleFired "x*0" $ Just x+      1         -> Stats.ruleFired "x*1" $ Just y+      _         -> Nothing++evalMul' arg env+  = eval2 (*) arg env++evalNeg :: Elt a => NumType a -> a :-> a+evalNeg _                    x _   | PrimApp PrimNeg{} x' <- x       = Stats.ruleFired "negate/negate" $ Just x'+evalNeg (IntegralNumType ty) x env | IntegralDict <- integralDict ty = eval1 negate x env+evalNeg (FloatingNumType ty) x env | FloatingDict <- floatingDict ty = eval1 negate x env++evalAbs :: Elt a => NumType a -> a :-> a+evalAbs (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 abs+evalAbs (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 abs++evalSig :: Elt a => NumType a -> a :-> a+evalSig (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 signum+evalSig (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 signum+++-- Methods of Integral & Bits+-- --------------------------++evalQuot :: IntegralType a -> (a,a) :-> a+evalQuot ty exp env+  | Just qr    <- evalQuotRem ty exp env+  , Just (q,_) <- untup2 qr+  = Just q+evalQuot _ _ _+  = Nothing++evalRem :: IntegralType a -> (a,a) :-> a+evalRem ty exp env+  | Just qr    <- evalQuotRem ty exp env+  , Just (_,r) <- untup2 qr+  = Just r+evalRem _ _ _+  = Nothing++evalQuotRem :: forall a. IntegralType a -> (a,a) :-> (a,a)+evalQuotRem ty exp env+  | IntegralDict                           <- integralDict ty+  , Tuple (NilTup `SnocTup` x `SnocTup` y) <- exp       -- TLM: untup2, but inlined to expose the Elt dictionary+  , Just b                                 <- propagate env y+  = case b of+      0 -> Nothing+      1 -> Stats.ruleFired "quotRem x 1" $ Just (tup2 (x, Const (fromElt (0::a))))+      _ -> case propagate env x of+             Nothing -> Nothing+             Just a  -> Stats.substitution "constant fold"+                      $ Just $ let (u,v) = quotRem a b+                               in  tup2 (Const (fromElt u), Const (fromElt v))+evalQuotRem _ _ _+  = Nothing+++evalIDiv :: IntegralType a -> (a,a) :-> a+evalIDiv ty exp env+  | Just dm    <- evalDivMod ty exp env+  , Just (d,_) <- untup2 dm+  = Just d+evalIDiv _ _ _+  = Nothing++evalMod :: IntegralType a -> (a,a) :-> a+evalMod ty exp env+  | Just dm    <- evalDivMod ty exp env+  , Just (_,m) <- untup2 dm+  = Just m+evalMod _ _ _+  = Nothing++evalDivMod :: forall a. IntegralType a -> (a,a) :-> (a,a)+evalDivMod ty exp env+  | IntegralDict                           <- integralDict ty+  , Tuple (NilTup `SnocTup` x `SnocTup` y) <- exp       -- TLM: untup2, but inlined to expose the Elt dictionary+  , Just b                                 <- propagate env y+  = case b of+      0 -> Nothing+      1 -> Stats.ruleFired "divMod x 1" $ Just (tup2 (x, Const (fromElt (0::a))))+      _ -> case propagate env x of+             Nothing -> Nothing+             Just a  -> Stats.substitution "constant fold"+                      $ Just $ let (u,v) = divMod a b+                               in  tup2 (Const (fromElt u), Const (fromElt v))+evalDivMod _ _ _+  = Nothing++evalBAnd :: Elt a => IntegralType a -> (a,a) :-> a+evalBAnd ty | IntegralDict <- integralDict ty = eval2 (.&.)++evalBOr :: Elt a => IntegralType a -> (a,a) :-> a+evalBOr ty | IntegralDict <- integralDict ty = eval2 (.|.)++evalBXor :: Elt a => IntegralType a -> (a,a) :-> a+evalBXor ty | IntegralDict <- integralDict ty = eval2 xor++evalBNot :: Elt a => IntegralType a -> a :-> a+evalBNot ty | IntegralDict <- integralDict ty = eval1 complement++evalBShiftL :: Elt a => IntegralType a -> (a,Int) :-> a+evalBShiftL _ (untup2 -> Just (x,i)) env+  | Just 0 <- propagate env i+  = Stats.ruleFired "x `shiftL` 0" $ Just x++evalBShiftL ty arg env+  | IntegralDict <- integralDict ty = eval2 shiftL arg env++evalBShiftR :: Elt a => IntegralType a -> (a,Int) :-> a+evalBShiftR _ (untup2 -> Just (x,i)) env+  | Just 0 <- propagate env i+  = Stats.ruleFired "x `shiftR` 0" $ Just x++evalBShiftR ty arg env+  | IntegralDict <- integralDict ty = eval2 shiftR arg env++evalBRotateL :: Elt a => IntegralType a -> (a,Int) :-> a+evalBRotateL _ (untup2 -> Just (x,i)) env+  | Just 0 <- propagate env i+  = Stats.ruleFired "x `rotateL` 0" $ Just x+evalBRotateL ty arg env+  | IntegralDict <- integralDict ty = eval2 rotateL arg env++evalBRotateR :: Elt a => IntegralType a -> (a,Int) :-> a+evalBRotateR _ (untup2 -> Just (x,i)) env+  | Just 0 <- propagate env i+  = Stats.ruleFired "x `rotateR` 0" $ Just x+evalBRotateR ty arg env+  | IntegralDict <- integralDict ty = eval2 rotateR arg env++evalPopCount :: IntegralType a -> a :-> Int+evalPopCount ty | IntegralDict <- integralDict ty = eval1 popCount++evalCountLeadingZeros :: IntegralType a -> a :-> Int+#if __GLASGOW_HASKELL__ >= 710+evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 countLeadingZeros+#else+evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 clz+  where+    clz x = (w-1) - go (w-1)+      where+        go i | i < 0       = i  -- no bit set+             | testBit x i = i+             | otherwise   = go (i-1)+        w = finiteBitSize x+#endif++evalCountTrailingZeros :: IntegralType a -> a :-> Int+#if __GLASGOW_HASKELL__ >= 710+evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 countTrailingZeros+#else+evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 ctz+  where+    ctz x = go 0+      where+        go i | i >= w      = i+             | testBit x i = i+             | otherwise   = go (i+1)+        w = finiteBitSize x+#endif+++-- Methods of Fractional & Floating+-- --------------------------------++evalFDiv :: Elt a => FloatingType a -> (a,a) :-> a+evalFDiv ty | FloatingDict <- floatingDict ty = evalFDiv'++evalFDiv' :: (Elt a, Fractional a, Eq a) => (a,a) :-> a+evalFDiv' (untup2 -> Just (x,y)) env+  | Just 1      <- propagate env y+  = Stats.ruleFired "x/1" $ Just x++evalFDiv' arg env+  = eval2 (/) arg env+++evalRecip :: Elt a => FloatingType a -> a :-> a+evalRecip ty | FloatingDict <- floatingDict ty = eval1 recip++evalSin :: Elt a => FloatingType a -> a :-> a+evalSin ty | FloatingDict <- floatingDict ty = eval1 sin++evalCos :: Elt a => FloatingType a -> a :-> a+evalCos ty | FloatingDict <- floatingDict ty = eval1 cos++evalTan :: Elt a => FloatingType a -> a :-> a+evalTan ty | FloatingDict <- floatingDict ty = eval1 tan++evalAsin :: Elt a => FloatingType a -> a :-> a+evalAsin ty | FloatingDict <- floatingDict ty = eval1 asin++evalAcos :: Elt a => FloatingType a -> a :-> a+evalAcos ty | FloatingDict <- floatingDict ty = eval1 acos++evalAtan :: Elt a => FloatingType a -> a :-> a+evalAtan ty | FloatingDict <- floatingDict ty = eval1 atan++evalSinh :: Elt a => FloatingType a -> a :-> a+evalSinh ty | FloatingDict <- floatingDict ty = eval1 sinh++evalCosh :: Elt a => FloatingType a -> a :-> a+evalCosh ty | FloatingDict <- floatingDict ty = eval1 cosh++evalTanh :: Elt a => FloatingType a -> a :-> a+evalTanh ty | FloatingDict <- floatingDict ty = eval1 tanh++evalAsinh :: Elt a => FloatingType a -> a :-> a+evalAsinh ty | FloatingDict <- floatingDict ty = eval1 asinh++evalAcosh :: Elt a => FloatingType a -> a :-> a+evalAcosh ty | FloatingDict <- floatingDict ty = eval1 acosh++evalAtanh :: Elt a => FloatingType a -> a :-> a+evalAtanh ty | FloatingDict <- floatingDict ty = eval1 atanh++evalExpFloating :: Elt a => FloatingType a -> a :-> a+evalExpFloating ty | FloatingDict <- floatingDict ty = eval1 P.exp++evalSqrt :: Elt a => FloatingType a -> a :-> a+evalSqrt ty | FloatingDict <- floatingDict ty = eval1 sqrt++evalLog :: Elt a => FloatingType a -> a :-> a+evalLog ty | FloatingDict <- floatingDict ty = eval1 log++evalFPow :: Elt a => FloatingType a -> (a,a) :-> a+evalFPow ty | FloatingDict <- floatingDict ty = eval2 (**)++evalLogBase :: Elt a => FloatingType a -> (a,a) :-> a+evalLogBase ty | FloatingDict <- floatingDict ty = eval2 logBase++evalAtan2 :: Elt a => FloatingType a -> (a,a) :-> a+evalAtan2 ty | FloatingDict <- floatingDict ty = eval2 atan2++evalTruncate :: Elt b => FloatingType a -> IntegralType b -> a :-> b+evalTruncate ta tb+  | FloatingDict <- floatingDict ta+  , IntegralDict <- integralDict tb = eval1 truncate++evalRound :: Elt b => FloatingType a -> IntegralType b -> a :-> b+evalRound ta tb+  | FloatingDict <- floatingDict ta+  , IntegralDict <- integralDict tb = eval1 round++evalFloor :: Elt b => FloatingType a -> IntegralType b -> a :-> b+evalFloor ta tb+  | FloatingDict <- floatingDict ta+  , IntegralDict <- integralDict tb = eval1 floor++evalCeiling :: Elt b => FloatingType a -> IntegralType b -> a :-> b+evalCeiling ta tb+  | FloatingDict <- floatingDict ta+  , IntegralDict <- integralDict tb = eval1 ceiling++evalIsNaN :: FloatingType a -> a :-> Bool+evalIsNaN ty | FloatingDict <- floatingDict ty = eval1 isNaN++evalIsInfinite :: FloatingType a -> a :-> Bool+evalIsInfinite ty | FloatingDict <- floatingDict ty = eval1 isInfinite+++-- Relational & Equality+-- ---------------------++evalLt :: SingleType a -> (a,a) :-> Bool+evalLt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (<)+evalLt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (<)+evalLt (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (<)++-- evalLt (SingleScalarType s) =+--   case s of+--     NumSingleType (IntegralNumType t) | IntegralDict <- integralDict t -> eval2 (<)+--     NumSingleType (FloatingNumType t) | FloatingDict <- floatingDict t -> eval2 (<)+--     NonNumSingleType t                | NonNumDict   <- nonNumDict t   -> eval2 (<)+-- evalLt (VectorScalarType (Vector2Type s)) =+--   case s of+--     NumSingleType (IntegralNumType t) | IntegralDict <- t -> eval2 (<)+--     NumSingleType (FloatingNumType t) | FloatingDict <- t -> eval2 (<)+--     NonNumSingleType t                | NonNumDict   <- t -> eval2 (<)++evalGt :: SingleType a -> (a,a) :-> Bool+evalGt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (>)+evalGt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (>)+evalGt (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (>)++-- evalGt (SingleScalarType s) =+--   case s of+--     NumSingleType (IntegralNumType t) | IntegralDict <- integralDict t -> eval2 (>)+--     NumSingleType (FloatingNumType t) | FloatingDict <- floatingDict t -> eval2 (>)+--     NonNumSingleType t                | NonNumDict   <- nonNumDict t   -> eval2 (>)++evalLtEq :: SingleType a -> (a,a) :-> Bool+evalLtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (<=)+evalLtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (<=)+evalLtEq (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (<=)++-- evalLtEq (SingleScalarType s) =+--   case s of+--     NumSingleType (IntegralNumType t) | IntegralDict <- integralDict t -> eval2 (<=)+--     NumSingleType (FloatingNumType t) | FloatingDict <- floatingDict t -> eval2 (<=)+--     NonNumSingleType t                | NonNumDict   <- nonNumDict t   -> eval2 (<=)++evalGtEq :: SingleType a -> (a,a) :-> Bool+evalGtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (>=)+evalGtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (>=)+evalGtEq (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (>=)++-- evalGtEq (SingleScalarType s) =+--   case s of+--     NumSingleType (IntegralNumType t) | IntegralDict <- integralDict t -> eval2 (>=)+--     NumSingleType (FloatingNumType t) | FloatingDict <- floatingDict t -> eval2 (>=)+--     NonNumSingleType t                | NonNumDict   <- nonNumDict t   -> eval2 (>=)++evalEq :: SingleType a -> (a,a) :-> Bool+evalEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (==)+evalEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (==)+evalEq (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (==)++-- evalEq (SingleScalarType s) =+--   case s of+--     NumSingleType (IntegralNumType t) | IntegralDict <- integralDict t -> eval2 (==)+--     NumSingleType (FloatingNumType t) | FloatingDict <- floatingDict t -> eval2 (==)+--     NonNumSingleType t                | NonNumDict   <- nonNumDict t   -> eval2 (==)++evalNEq :: SingleType a -> (a,a) :-> Bool+evalNEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (/=)+evalNEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (/=)+evalNEq (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = eval2 (/=)++-- evalNEq (SingleScalarType s) =+--   case s of+--     NumSingleType (IntegralNumType t) | IntegralDict <- integralDict t -> eval2 (/=)+--     NumSingleType (FloatingNumType t) | FloatingDict <- floatingDict t -> eval2 (/=)+--     NonNumSingleType t                | NonNumDict   <- nonNumDict t   -> eval2 (/=)++evalMax :: Elt a => SingleType a -> (a,a) :-> a+evalMax (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 max+evalMax (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 max+evalMax (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = eval2 max++-- evalMax (SingleScalarType s) =+--   case s of+--     NumSingleType (IntegralNumType t) | IntegralDict <- integralDict t -> eval2 max+--     NumSingleType (FloatingNumType t) | FloatingDict <- floatingDict t -> eval2 max+--     NonNumSingleType t                | NonNumDict   <- nonNumDict t   -> eval2 max++evalMin :: Elt a => SingleType a -> (a,a) :-> a+evalMin (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 min+evalMin (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 min+evalMin (NonNumSingleType ty)                | NonNumDict   <- nonNumDict ty   = eval2 min++-- evalMin (SingleScalarType s) =+--   case s of+--     NumSingleType (IntegralNumType t) | IntegralDict <- integralDict t -> eval2 min+--     NumSingleType (FloatingNumType t) | FloatingDict <- floatingDict t -> eval2 min+--     NonNumSingleType t                | NonNumDict   <- nonNumDict t   -> eval2 min+++-- Logical operators+-- -----------------++evalLAnd :: (Bool,Bool) :-> Bool+evalLAnd (untup2 -> Just (x,y)) env+  | Just a      <- propagate env x+  = Just $ if a then Stats.ruleFired "True &&" y+                else Stats.ruleFired "False &&" $ Const (fromElt False)++evalLAnd _ _+  = Nothing++evalLOr  :: (Bool,Bool) :-> Bool+evalLOr (untup2 -> Just (x,y)) env+  | Just a      <- propagate env x+  = Just $ if a then Stats.ruleFired "True ||" $ Const (fromElt True)+                else Stats.ruleFired "False ||" y++evalLOr _ _+  = Nothing++evalLNot :: Bool :-> Bool+evalLNot x _   | PrimApp PrimLNot x' <- x = Stats.ruleFired "not/not" $ Just x'+evalLNot x env                            = eval1 not x env++evalOrd :: Char :-> Int+evalOrd = eval1 ord++evalChr :: Int :-> Char+evalChr = eval1 chr++evalBoolToInt :: Bool :-> Int+evalBoolToInt = eval1 fromEnum++evalFromIntegral :: Elt b => IntegralType a -> NumType b -> a :-> b+evalFromIntegral ta (IntegralNumType tb)+  | IntegralDict <- integralDict ta+  , IntegralDict <- integralDict tb = eval1 fromIntegral++evalFromIntegral ta (FloatingNumType tb)+  | IntegralDict <- integralDict ta+  , FloatingDict <- floatingDict tb = eval1 fromIntegral++evalToFloating :: Elt b => NumType a -> FloatingType b -> a :-> b+evalToFloating (IntegralNumType ta) tb x env+  | IntegralDict <- integralDict ta+  , FloatingDict <- floatingDict tb = eval1 realToFrac x env++evalToFloating (FloatingNumType ta) tb x env+  | TypeHalf   FloatingDict <- ta+  , TypeHalf   FloatingDict <- tb = Just x++  | TypeFloat  FloatingDict <- ta+  , TypeFloat  FloatingDict <- tb = Just x++  | TypeDouble FloatingDict <- ta+  , TypeDouble FloatingDict <- tb = Just x++  | TypeFloat  FloatingDict <- ta+  , TypeDouble FloatingDict <- tb = eval1 float2Double x env++  | TypeDouble FloatingDict <- ta+  , TypeFloat  FloatingDict <- tb = eval1 double2Float x env++  | FloatingDict <- floatingDict ta+  , FloatingDict <- floatingDict tb = eval1 realToFrac x env+++-- Scalar primitives+-- -----------------++evalPrimConst :: PrimConst a -> a+evalPrimConst (PrimMinBound ty) = evalMinBound ty+evalPrimConst (PrimMaxBound ty) = evalMaxBound ty+evalPrimConst (PrimPi       ty) = evalPi ty++evalMinBound :: BoundedType a -> a+evalMinBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = minBound+evalMinBound (NonNumBoundedType   ty) | NonNumDict   <- nonNumDict ty   = minBound++evalMaxBound :: BoundedType a -> a+evalMaxBound (IntegralBoundedType ty) | IntegralDict <- integralDict ty = maxBound+evalMaxBound (NonNumBoundedType   ty) | NonNumDict   <- nonNumDict ty   = maxBound++evalPi :: FloatingType a -> a+evalPi ty | FloatingDict <- floatingDict ty = pi+
+ src/Data/Array/Accelerate/Trafo/Base.hs view
@@ -0,0 +1,442 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE PatternGuards        #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+#if __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE IncoherentInstances  #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+-- |+-- Module      : Data.Array.Accelerate.Trafo.Base+-- 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.Trafo.Base (++  -- Toolkit+  Kit(..), Match(..), (:~:)(..),+  avarIn, kmap, fromOpenAfun,++  -- Delayed Arrays+  DelayedAcc,  DelayedOpenAcc(..),+  DelayedAfun, DelayedOpenAfun,+  DelayedExp,  DelayedOpenExp,+  DelayedFun,  DelayedOpenFun,+  matchDelayedOpenAcc, encodeDelayedOpenAcc, hashDelayedOpenAcc,++  -- Environments+  Gamma(..), incExp, prjExp, pushExp,+  Extend(..), append, bind,+  Sink(..), sink, sink1,+  Supplement(..), bindExps,++) where++-- standard library+import Control.Applicative+import Control.DeepSeq+import Crypto.Hash+import Data.ByteString.Builder+import Data.ByteString.Builder.Extra+import Data.Monoid+import Data.Type.Equality+import Text.PrettyPrint.ANSI.Leijen                     hiding ( (<$>), (<>) )+import Prelude                                          hiding ( until )++-- friends+import Data.Array.Accelerate.AST                        hiding ( Val(..) )+import Data.Array.Accelerate.Analysis.Hash+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Sugar                ( Array, Arrays, Shape, Elt )+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Pretty.Print+import Data.Array.Accelerate.Trafo.Substitution++import Data.Array.Accelerate.Debug.Stats                as Stats+++-- Toolkit+-- =======++-- The bat utility belt of operations required to manipulate terms parameterised+-- by the recursive closure.+--+class (RebuildableAcc acc, Sink acc) => Kit acc where+  inject        :: PreOpenAcc acc aenv a -> acc aenv a+  extract       :: acc aenv a -> PreOpenAcc acc aenv a+  fromOpenAcc   :: OpenAcc aenv a -> acc aenv a+  --+  matchAcc      :: MatchAcc acc+  encodeAcc     :: EncodeAcc acc+  prettyAcc     :: PrettyAcc acc++instance Kit OpenAcc where+  inject                 = OpenAcc+  extract (OpenAcc pacc) = pacc+  fromOpenAcc            = id+  --+  {-# INLINEABLE encodeAcc #-}+  {-# INLINEABLE matchAcc  #-}+  {-# INLINEABLE prettyAcc #-}+  encodeAcc (OpenAcc pacc)                  = encodePreOpenAcc encodeAcc pacc+  matchAcc  (OpenAcc pacc1) (OpenAcc pacc2) = matchPreOpenAcc matchAcc encodeAcc pacc1 pacc2+  prettyAcc                                 = prettyOpenAcc++avarIn :: (Kit acc, Arrays arrs) => Idx aenv arrs -> acc aenv arrs+avarIn = inject  . Avar++kmap :: Kit acc => (PreOpenAcc acc aenv a -> PreOpenAcc acc aenv b) -> acc aenv a -> acc aenv b+kmap f = inject . f . extract++fromOpenAfun :: Kit acc => OpenAfun aenv f -> PreOpenAfun acc aenv f+fromOpenAfun (Abody a) = Abody $ fromOpenAcc a+fromOpenAfun (Alam f)  = Alam  $ fromOpenAfun f++-- A class for testing the equality of terms homogeneously, returning a witness+-- to the existentially quantified terms in the positive case.+--+class Match f where+  match :: f s -> f t -> Maybe (s :~: t)++instance Match (Idx env) where+  {-# INLINEABLE match #-}+  match = matchIdx++instance Kit acc => Match (PreOpenExp acc env aenv) where+  {-# INLINEABLE match #-}+  match = matchPreOpenExp matchAcc encodeAcc++instance Kit acc => Match (PreOpenFun acc env aenv) where+  {-# INLINEABLE match #-}+  match = matchPreOpenFun matchAcc encodeAcc++instance Kit acc => Match (PreOpenAcc acc aenv) where+  {-# INLINEABLE match #-}+  match = matchPreOpenAcc matchAcc encodeAcc++instance {-# INCOHERENT #-} Kit acc => Match (acc aenv) where+  {-# INLINEABLE match #-}+  match = matchAcc+++-- Delayed Arrays+-- ==============++-- The type of delayed arrays. This representation is used to annotate the AST+-- in the recursive knot to distinguish standard AST terms from operand arrays+-- that should be embedded into their consumers.+--+type DelayedAcc         = DelayedOpenAcc ()+type DelayedAfun        = PreOpenAfun DelayedOpenAcc ()++type DelayedExp         = DelayedOpenExp ()+type DelayedFun         = DelayedOpenFun ()++-- data DelayedSeq t where+--   DelayedSeq :: Extend DelayedOpenAcc () aenv+--              -> DelayedOpenSeq aenv () t+--              -> DelayedSeq t++type DelayedOpenAfun    = PreOpenAfun DelayedOpenAcc+type DelayedOpenExp     = PreOpenExp DelayedOpenAcc+type DelayedOpenFun     = PreOpenFun DelayedOpenAcc+-- type DelayedOpenSeq     = PreOpenSeq DelayedOpenAcc++data DelayedOpenAcc aenv a where+  Manifest              :: PreOpenAcc DelayedOpenAcc aenv a -> DelayedOpenAcc aenv a++  Delayed               :: (Shape sh, Elt e) =>+    { extentD           :: PreExp DelayedOpenAcc aenv sh+    , indexD            :: PreFun DelayedOpenAcc aenv (sh  -> e)+    , linearIndexD      :: PreFun DelayedOpenAcc aenv (Int -> e)+    }                   -> DelayedOpenAcc aenv (Array sh e)++instance Rebuildable DelayedOpenAcc where+  type AccClo DelayedOpenAcc = DelayedOpenAcc+  {-# INLINEABLE rebuildPartial #-}+  rebuildPartial v acc = case acc of+    Manifest pacc -> Manifest <$> rebuildPartial v pacc+    Delayed{..}   -> Delayed  <$> rebuildPartial v extentD+                              <*> rebuildPartial v indexD+                              <*> rebuildPartial v linearIndexD++instance Sink DelayedOpenAcc where+  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)++instance Kit DelayedOpenAcc where+  inject                  = Manifest+  extract (Manifest pacc) = pacc+  extract Delayed{}       = error "DelayedAcc.extract"+  fromOpenAcc             = error "DelayedAcc.fromOpenAcc"+  --+  {-# INLINEABLE encodeAcc #-}+  {-# INLINEABLE matchAcc  #-}+  {-# INLINEABLE prettyAcc #-}+  encodeAcc               = encodeDelayedOpenAcc+  matchAcc                = matchDelayedOpenAcc+  prettyAcc               = prettyDelayedOpenAcc++instance NFData (DelayedOpenAfun aenv t) where+  rnf = rnfPreOpenAfun rnfDelayedOpenAcc++instance NFData (DelayedOpenAcc aenv t) where+  rnf = rnfDelayedOpenAcc++-- instance NFData (DelayedSeq t) where+--   rnf = rnfDelayedSeq+++hashDelayedOpenAcc :: DelayedOpenAcc aenv a -> Hash+hashDelayedOpenAcc = hashlazy . toLazyByteString . encodeDelayedOpenAcc++{-# INLINEABLE encodeDelayedOpenAcc #-}+encodeDelayedOpenAcc :: EncodeAcc DelayedOpenAcc+encodeDelayedOpenAcc (Manifest pacc) = intHost $(hashQ "Manifest") <> encodePreOpenAcc encodeDelayedOpenAcc pacc+encodeDelayedOpenAcc Delayed{..}     = intHost $(hashQ "Delayed")  <> travE extentD <> travF indexD <> travF linearIndexD+  where+    {-# INLINE travE #-}+    travE :: DelayedExp aenv sh -> Builder+    travE = encodePreOpenExp encodeDelayedOpenAcc++    {-# INLINE travF #-}+    travF :: DelayedFun aenv f -> Builder+    travF = encodePreOpenFun encodeDelayedOpenAcc++{-# INLINEABLE matchDelayedOpenAcc #-}+matchDelayedOpenAcc :: MatchAcc DelayedOpenAcc+matchDelayedOpenAcc (Manifest pacc1) (Manifest pacc2)+  = matchPreOpenAcc matchDelayedOpenAcc encodeDelayedOpenAcc pacc1 pacc2++matchDelayedOpenAcc (Delayed sh1 ix1 lx1) (Delayed sh2 ix2 lx2)+  | Just Refl <- matchPreOpenExp matchDelayedOpenAcc encodeDelayedOpenAcc sh1 sh2+  , Just Refl <- matchPreOpenFun matchDelayedOpenAcc encodeDelayedOpenAcc ix1 ix2+  , Just Refl <- matchPreOpenFun matchDelayedOpenAcc encodeDelayedOpenAcc lx1 lx2+  = Just Refl++matchDelayedOpenAcc _ _+  = Nothing++rnfDelayedOpenAcc :: DelayedOpenAcc aenv t -> ()+rnfDelayedOpenAcc (Manifest pacc)    = rnfPreOpenAcc rnfDelayedOpenAcc pacc+rnfDelayedOpenAcc (Delayed sh ix lx) = rnfPreOpenExp rnfDelayedOpenAcc sh+                                 `seq` rnfPreOpenFun rnfDelayedOpenAcc ix+                                 `seq` rnfPreOpenFun rnfDelayedOpenAcc lx++{--+rnfDelayedSeq :: DelayedSeq t -> ()+rnfDelayedSeq (DelayedSeq env s) = rnfExtend rnfDelayedOpenAcc env+                             `seq` rnfPreOpenSeq rnfDelayedOpenAcc s++rnfExtend :: NFDataAcc acc -> Extend acc aenv aenv' -> ()+rnfExtend _    BaseEnv         = ()+rnfExtend rnfA (PushEnv env a) = rnfExtend rnfA env `seq` rnfA a+--}+++-- Note: If we detect that the delayed array is simply accessing an array+-- variable, then just print the variable name. That is:+--+-- > let a0 = <...> in map f (Delayed (shape a0) (\x0 -> a0!x0))+--+-- becomes+--+-- > let a0 = <...> in map f a0+--+prettyDelayedOpenAcc :: PrettyAcc DelayedOpenAcc+prettyDelayedOpenAcc wrap aenv acc = case acc of+  Manifest pacc         -> prettyPreOpenAcc prettyDelayedOpenAcc wrap aenv pacc+  Delayed sh f _+    | Shape a           <- sh+    , Just Refl         <- match f (Lam (Body (Index a (Var ZeroIdx))))+    -> prettyDelayedOpenAcc wrap aenv a++    | otherwise+    -> wrap $ hang 2 (sep [ green (text "delayed")+                          , parens (align (prettyPreExp prettyDelayedOpenAcc (parens . align) aenv sh))+                          , parens (align (prettyPreFun prettyDelayedOpenAcc aenv f))+                          ])++{--+-- Pretty print delayed sequences+--+-- TLM: What is going on with this sequence thing, why is it closed?+--+prettyDelayedSeq+    :: (Doc -> Doc)                             -- apply to compound expressions+    -> DelayedSeq arrs+    -> Doc+prettyDelayedSeq wrap (DelayedSeq aenv s)+  | (d, lvl) <- pp env 0+  =  wrap $   (hang (text "let") 2 $ sep $ punctuate semi d)+          <+> (hang (text "in")  2 $ sep $ punctuate semi+                                         $ prettyPreSeq wrap prettyAcc lvl 0 s)+  where+    pp :: Extend DelayedOpenAcc aenv aenv' -> Int -> ([Doc], Int)+    pp BaseEnv          lvl = ([],lvl)+    pp (PushEnv env' a) lvl | (d', _) <- pp env' (lvl + 1)+                            = (prettyAcc lvl wrap a : d', lvl)+--}+++-- Environments+-- ============++-- An environment that holds let-bound scalar expressions. The second+-- environment variable env' is used to project out the corresponding+-- index when looking up in the environment congruent expressions.+--+data Gamma acc env env' aenv where+  EmptyExp :: Gamma acc env env' aenv++  PushExp  :: Elt t+           => Gamma acc env env' aenv+           -> WeakPreOpenExp acc env aenv t+           -> Gamma acc env (env', t) aenv++data WeakPreOpenExp acc env aenv t where+  Subst    :: env :> env'+           -> PreOpenExp     acc env  aenv t+           -> PreOpenExp     acc env' aenv t {- LAZY -}+           -> WeakPreOpenExp acc env' aenv t++-- XXX: The simplifier calls this function every time it moves under a let+-- binding. This means we have a number of calls to 'weakenE' exponential in the+-- depth of nested let bindings, which quickly causes problems.+--+-- We can improve the situation slightly by observing that weakening by a single+-- variable does no less work than weaking by multiple variables at once; both+-- require a deep copy of the AST. By exploiting laziness (or, an IORef) we can+-- queue up multiple weakenings to happen in a single step.+--+-- <https://github.com/AccelerateHS/accelerate-llvm/issues/20>+--+incExp+    :: Kit acc+    => Gamma acc env     env' aenv+    -> Gamma acc (env,s) env' aenv+incExp EmptyExp        = EmptyExp+incExp (PushExp env w) = incExp env `PushExp` subs w+  where+    subs :: forall acc env aenv s t. Kit acc => WeakPreOpenExp acc env aenv t -> WeakPreOpenExp acc (env,s) aenv t+    subs (Subst k (e :: PreOpenExp acc env_ aenv t) _) = Subst k' e (weakenE k' e)+      where+        k' :: env_ :> (env,s)+        k' = SuccIdx . k++prjExp :: Idx env' t -> Gamma acc env env' aenv -> PreOpenExp acc env aenv t+prjExp ZeroIdx      (PushExp _   (Subst _ _ e)) = e+prjExp (SuccIdx ix) (PushExp env _)             = prjExp ix env+prjExp _            _                           = $internalError "prjExp" "inconsistent valuation"++pushExp :: Elt t => Gamma acc env env' aenv -> PreOpenExp acc env aenv t -> Gamma acc env (env',t) aenv+pushExp env e = env `PushExp` Subst id e e++{--+lookupExp+    :: Kit acc+    => Gamma      acc env env' aenv+    -> PreOpenExp acc env      aenv t+    -> Maybe (Idx env' t)+lookupExp EmptyExp        _ = Nothing+lookupExp (PushExp env e) x+  | Just Refl <- match e x  = Just ZeroIdx+  | otherwise               = SuccIdx `fmap` lookupExp env x++weakenGamma1+    :: Kit acc+    => Gamma acc env env' aenv+    -> Gamma acc env env' (aenv,t)+weakenGamma1 EmptyExp        = EmptyExp+weakenGamma1 (PushExp env e) = PushExp (weakenGamma1 env) (weaken SuccIdx e)++sinkGamma+    :: Kit acc+    => Extend acc aenv aenv'+    -> Gamma acc env env' aenv+    -> Gamma acc env env' aenv'+sinkGamma _   EmptyExp        = EmptyExp+sinkGamma ext (PushExp env e) = PushExp (sinkGamma ext env) (sink ext e)+--}++-- As part of various transformations we often need to lift out array valued+-- inputs to be let-bound at a higher point.+--+-- The Extend type is a heterogeneous snoc-list of array terms that witnesses+-- how the array environment is extended by binding these additional terms.+--+data Extend acc aenv aenv' where+  BaseEnv :: Extend acc aenv aenv++  PushEnv :: Arrays a+          => Extend acc aenv aenv' -> acc aenv' a -> Extend acc aenv (aenv', a)++-- Append two environment witnesses+--+append :: Extend acc env env' -> Extend acc env' env'' -> Extend acc env env''+append x BaseEnv        = x+append x (PushEnv as a) = x `append` as `PushEnv` a++-- Bring into scope all of the array terms in the Extend environment list. This+-- converts a term in the inner environment (aenv') into the outer (aenv).+--+bind :: (Kit acc, Arrays a)+     => Extend     acc aenv aenv'+     -> PreOpenAcc acc      aenv' a+     -> PreOpenAcc acc aenv       a+bind BaseEnv         = id+bind (PushEnv env a) = bind env . Alet a . inject++-- Sink a term from one array environment into another, where additional+-- bindings have come into scope according to the witness and no old things have+-- vanished.+--+sink :: Sink f => Extend acc env env' -> f env t -> f env' t+sink env = weaken (k env)+  where+    k :: Extend acc env env' -> Idx env t -> Idx env' t+    k BaseEnv       = Stats.substitution "sink" id+    k (PushEnv e _) = SuccIdx . k e++sink1 :: Sink f => Extend acc env env' -> f (env,s) t -> f (env',s) t+sink1 env = weaken (k env)+  where+    k :: Extend acc env env' -> Idx (env,s) t -> Idx (env',s) t+    k BaseEnv       = Stats.substitution "sink1" id+    k (PushEnv e _) = split . k e+    --+    split :: Idx (env,s) t -> Idx ((env,u),s) t+    split ZeroIdx      = ZeroIdx+    split (SuccIdx ix) = SuccIdx (SuccIdx ix)+++-- This is the same as Extend, but for the scalar environment.+--+data Supplement acc env env' aenv where+  BaseSup :: Supplement acc env env aenv++  PushSup :: Elt e+          => Supplement acc env env'      aenv+          -> PreOpenExp acc     env'      aenv e+          -> Supplement acc env (env', e) aenv++bindExps :: (Kit acc, Elt e)+         => Supplement acc env env' aenv+         -> PreOpenExp acc env' aenv e+         -> PreOpenExp acc env  aenv e+bindExps BaseSup       = id+bindExps (PushSup g b) = bindExps g . Let b+
+ src/Data/Array/Accelerate/Trafo/Fusion.hs view
@@ -0,0 +1,1572 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE IncoherentInstances  #-}+{-# LANGUAGE InstanceSigs         #-}+{-# LANGUAGE PatternGuards        #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns         #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing      #-}+-- |+-- Module      : Data.Array.Accelerate.Trafo.Fusion+-- Copyright   : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell+--               [2014..2014] Frederik M. Madsen+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module implements producer/producer and consumer/producer fusion as a+-- term rewriting of the Accelerate AST.+--+-- The function 'quench' perform the source-to-source fusion transformation,+-- while 'anneal' additionally makes the representation of embedded producers+-- explicit by representing the AST as a 'DelayedAcc' of manifest and delayed+-- nodes.+--++module Data.Array.Accelerate.Trafo.Fusion (++  -- ** Types+  DelayedAcc, DelayedOpenAcc(..),+  DelayedAfun, DelayedOpenAfun,+  DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun,++  -- ** Conversion+  convertAcc, convertAfun,++) where++-- standard library+import Prelude                                          hiding ( exp, until )++-- friends+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Trafo.Base+import Data.Array.Accelerate.Trafo.Shrink+import Data.Array.Accelerate.Trafo.Simplify+import Data.Array.Accelerate.Trafo.Substitution+import Data.Array.Accelerate.Array.Representation       ( SliceIndex(..) )+import Data.Array.Accelerate.Array.Sugar                ( Array, Arrays(..), ArraysR(..), ArrRepr+                                                        , Elt, EltRepr, Shape, Tuple(..), Atuple(..)+                                                        , IsAtuple, TupleRepr, eltType )+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Type++import qualified Data.Array.Accelerate.Debug            as Stats+#ifdef ACCELERATE_DEBUG+import System.IO.Unsafe -- for debugging+#endif+++-- Delayed Array Fusion+-- ====================++-- | Apply the fusion transformation to a closed de Bruijn AST+--+convertAcc :: Arrays arrs => Bool -> Acc arrs -> DelayedAcc arrs+convertAcc fuseAcc = withSimplStats . convertOpenAcc fuseAcc++-- | Apply the fusion transformation to a function of array arguments+--+convertAfun :: Bool -> Afun f -> DelayedAfun f+convertAfun fuseAcc = withSimplStats . convertOpenAfun fuseAcc++-- -- | Apply the fusion transformation to the array computations embedded+-- --   in a sequence computation.+-- convertSeq :: Bool -> Seq a -> DelayedSeq a+-- convertSeq fuseAcc (embedSeq (embedOpenAcc fuseAcc) -> ExtendSeq aenv s)+--   = withSimplStats (DelayedSeq (cvtE aenv) (convertOpenSeq fuseAcc s))+--   where+--     cvtE :: Extend OpenAcc aenv aenv' -> Extend DelayedOpenAcc aenv aenv'+--     cvtE BaseEnv                                          = BaseEnv+--     cvtE (PushEnv env a) | a' <- convertOpenAcc fuseAcc a = PushEnv (cvtE env) a'++withSimplStats :: a -> a+#ifdef ACCELERATE_DEBUG+withSimplStats x = unsafePerformIO Stats.resetSimplCount `seq` x+#else+withSimplStats x = x+#endif+++-- | Apply the fusion transformation to an AST. This consists of two phases:+--+--    1. A bottom-up traversal that converts nodes into the internal delayed+--       representation, merging adjacent producer/producer pairs.+--+--    2. A top-down traversal that makes the representation of fused+--       consumer/producer pairs explicit as a 'DelayedAcc' of manifest and+--       delayed nodes.+--+-- TLM: Note that there really is no ambiguity as to which state an array will+--      be in following this process: an array will be either delayed or+--      manifest, and the two helper functions are even named as such! We should+--      encode this property in the type somehow...+--+convertOpenAcc :: Arrays arrs => Bool -> OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs+convertOpenAcc fuseAcc = manifest fuseAcc . computeAcc . embedOpenAcc fuseAcc++-- Convert array computations into an embeddable delayed representation.+-- Reapply the embedding function from the first pass and unpack the+-- representation. It is safe to match on BaseEnv because the first pass+-- will put producers adjacent to the term consuming it.+--+delayed :: (Shape sh, Elt e) => Bool -> OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e)+delayed fuseAcc (embedOpenAcc fuseAcc -> Embed BaseEnv cc) =+  case cc of+    Done v                                -> Delayed (arrayShape v) (indexArray v) (linearIndex v)+    Yield (cvtE -> sh) (cvtF -> f)        -> Delayed sh f (f `compose` fromIndex sh)+    Step  (cvtE -> sh) (cvtF -> p) (cvtF -> f) v+      | Just Refl <- match sh (arrayShape v)+      , Just Refl <- isIdentity p+      -> Delayed sh (f `compose` indexArray v) (f `compose` linearIndex v)++      | f'        <- f `compose` indexArray v `compose` p+      -> Delayed sh f' (f' `compose` fromIndex sh)+  where+    cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t+    cvtE = convertOpenExp fuseAcc++    cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f+    cvtF (Lam f)  = Lam (cvtF f)+    cvtF (Body b) = Body (cvtE b)++-- Convert array programs as manifest terms.+--+manifest :: Bool -> OpenAcc aenv a -> DelayedOpenAcc aenv a+manifest fuseAcc (OpenAcc pacc) =+  let fusionError = $internalError "manifest" "unexpected fusible materials"+  in+  Manifest $ case pacc of+    -- Non-fusible terms+    -- -----------------+    Avar ix                 -> Avar ix+    Use arr                 -> Use arr+    Unit e                  -> Unit (cvtE e)+    Alet bnd body           -> alet (manifest fuseAcc bnd) (manifest fuseAcc body)+    Acond p t e             -> Acond (cvtE p) (manifest fuseAcc t) (manifest fuseAcc e)+    Awhile p f a            -> Awhile (cvtAF p) (cvtAF f) (manifest fuseAcc a)+    Atuple tup              -> Atuple (cvtAT tup)+    Aprj ix tup             -> Aprj ix (manifest fuseAcc tup)+    Apply f a               -> Apply (cvtAF f) (manifest fuseAcc a)+    Aforeign ff f a         -> Aforeign ff (cvtAF f) (manifest fuseAcc a)++    -- Producers+    -- ---------+    --+    -- Some producers might still exist as a manifest array. Typically+    -- this is because they are the last stage of the computation, or the+    -- result of a let-binding to be used multiple times. The input array+    -- here should be an array variable, else something went wrong.+    --+    Map f a                 -> Map (cvtF f) (delayed fuseAcc a)+    Generate sh f           -> Generate (cvtE sh) (cvtF f)+    Transform sh p f a      -> Transform (cvtE sh) (cvtF p) (cvtF f) (delayed fuseAcc a)+    Backpermute sh p a      -> Backpermute (cvtE sh) (cvtF p) (delayed fuseAcc a)+    Reshape sl a            -> Reshape (cvtE sl) (manifest fuseAcc a)++    Replicate{}             -> fusionError+    Slice{}                 -> fusionError+    ZipWith{}               -> fusionError++    -- Consumers+    -- ---------+    --+    -- Embed producers directly into the representation. For stencils we+    -- make an exception. Since these consumers access elements of the+    -- argument array multiple times, we are careful not to duplicate work+    -- and instead force the argument to be a manifest array.+    --+    Fold f z a              -> Fold     (cvtF f) (cvtE z) (delayed fuseAcc a)+    Fold1 f a               -> Fold1    (cvtF f) (delayed fuseAcc a)+    FoldSeg f z a s         -> FoldSeg  (cvtF f) (cvtE z) (delayed fuseAcc a) (delayed fuseAcc s)+    Fold1Seg f a s          -> Fold1Seg (cvtF f) (delayed fuseAcc a) (delayed fuseAcc s)+    Scanl f z a             -> Scanl    (cvtF f) (cvtE z) (delayed fuseAcc a)+    Scanl1 f a              -> Scanl1   (cvtF f) (delayed fuseAcc a)+    Scanl' f z a            -> Scanl'   (cvtF f) (cvtE z) (delayed fuseAcc a)+    Scanr f z a             -> Scanr    (cvtF f) (cvtE z) (delayed fuseAcc a)+    Scanr1 f a              -> Scanr1   (cvtF f) (delayed fuseAcc a)+    Scanr' f z a            -> Scanr'   (cvtF f) (cvtE z) (delayed fuseAcc a)+    Permute f d p a         -> Permute  (cvtF f) (manifest fuseAcc d) (cvtF p) (delayed fuseAcc a)+    Stencil f x a           -> Stencil  (cvtF f) (cvtB x) (delayed fuseAcc a)+    Stencil2 f x a y b      -> Stencil2 (cvtF f) (cvtB x) (delayed fuseAcc a) (cvtB y) (delayed fuseAcc b)+    -- Collect s               -> Collect  (cvtS s)++    where+      -- Flatten needless let-binds, which can be introduced by the conversion to+      -- the internal embeddable representation.+      --+      alet bnd body+        | Manifest (Avar ZeroIdx) <- body+        , Manifest x              <- bnd+        = x++        | otherwise+        = Alet bnd body++      cvtAT :: Atuple (OpenAcc aenv) a -> Atuple (DelayedOpenAcc aenv) a+      cvtAT NilAtup        = NilAtup+      cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` manifest fuseAcc a++      cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f+      cvtAF (Alam f)  = Alam  (cvtAF f)+      cvtAF (Abody b) = Abody (manifest fuseAcc b)++      -- cvtS :: PreOpenSeq OpenAcc aenv senv s -> PreOpenSeq DelayedOpenAcc aenv senv s+      -- cvtS = convertOpenSeq fuseAcc++      -- Conversions for closed scalar functions and expressions+      --+      cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f+      cvtF (Lam f)  = Lam (cvtF f)+      cvtF (Body b) = Body (cvtE b)++      cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t+      cvtE = convertOpenExp fuseAcc++      cvtB :: Boundary aenv t -> PreBoundary DelayedOpenAcc aenv t+      cvtB Clamp        = Clamp+      cvtB Mirror       = Mirror+      cvtB Wrap         = Wrap+      cvtB (Constant v) = Constant v+      cvtB (Function f) = Function (cvtF f)++convertOpenExp :: Bool -> OpenExp env aenv t -> DelayedOpenExp env aenv t+convertOpenExp fuseAcc exp =+  case exp of+    Let bnd body            -> Let (cvtE bnd) (cvtE body)+    Var ix                  -> Var ix+    Const c                 -> Const c+    Undef                   -> Undef+    Tuple tup               -> Tuple (cvtT tup)+    Prj ix t                -> Prj ix (cvtE t)+    IndexNil                -> IndexNil+    IndexCons sh sz         -> IndexCons (cvtE sh) (cvtE sz)+    IndexHead sh            -> IndexHead (cvtE sh)+    IndexTail sh            -> IndexTail (cvtE sh)+    IndexAny                -> IndexAny+    IndexSlice x ix sh      -> IndexSlice x (cvtE ix) (cvtE sh)+    IndexFull x ix sl       -> IndexFull x (cvtE ix) (cvtE sl)+    ToIndex sh ix           -> ToIndex (cvtE sh) (cvtE ix)+    FromIndex sh ix         -> FromIndex (cvtE sh) (cvtE ix)+    Cond p t e              -> Cond (cvtE p) (cvtE t) (cvtE e)+    While p f x             -> While (cvtF p) (cvtF f) (cvtE x)+    PrimConst c             -> PrimConst c+    PrimApp f x             -> PrimApp f (cvtE x)+    Index a sh              -> Index (manifest fuseAcc a) (cvtE sh)+    LinearIndex a i         -> LinearIndex (manifest fuseAcc a) (cvtE i)+    Shape a                 -> Shape (manifest fuseAcc a)+    ShapeSize sh            -> ShapeSize (cvtE sh)+    Intersect s t           -> Intersect (cvtE s) (cvtE t)+    Union s t               -> Union (cvtE s) (cvtE t)+    Foreign ff f e          -> Foreign ff (cvtF f) (cvtE e)+    Coerce e                -> Coerce (cvtE e)+  where+    cvtT :: Tuple (OpenExp env aenv) t -> Tuple (DelayedOpenExp env aenv) t+    cvtT NilTup        = NilTup+    cvtT (SnocTup t e) = cvtT t `SnocTup` cvtE e++    -- Conversions for closed scalar functions and expressions+    --+    cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f+    cvtF (Lam f)  = Lam (cvtF f)+    cvtF (Body b) = Body (cvtE b)++    cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t+    cvtE = convertOpenExp fuseAcc+++convertOpenAfun :: Bool -> OpenAfun aenv f -> DelayedOpenAfun aenv f+convertOpenAfun c (Alam  f) = Alam  (convertOpenAfun c f)+convertOpenAfun c (Abody b) = Abody (convertOpenAcc  c b)++{--+convertOpenSeq :: Bool -> PreOpenSeq OpenAcc aenv senv a -> PreOpenSeq DelayedOpenAcc aenv senv a+convertOpenSeq fuseAcc s =+  case s of+    Consumer c          -> Consumer (cvtC c)+    Reify ix            -> Reify ix+    Producer p s'       -> Producer p' (convertOpenSeq fuseAcc s')+      where+        p' = case p of+               StreamIn arrs     -> StreamIn arrs+               ToSeq slix sh a   -> ToSeq slix sh (delayed fuseAcc a)+               MapSeq f x        -> MapSeq (cvtAF f) x+               ChunkedMapSeq f x -> ChunkedMapSeq (cvtAF f) x+               ZipWithSeq f x y  -> ZipWithSeq (cvtAF f) x y+               ScanSeq f e x     -> ScanSeq (cvtF f) (cvtE e) x+  where+    cvtC :: Consumer OpenAcc aenv senv a -> Consumer DelayedOpenAcc aenv senv a+    cvtC c =+      case c of+        FoldSeq f e x        -> FoldSeq (cvtF f) (cvtE e) x+        FoldSeqFlatten f a x -> FoldSeqFlatten (cvtAF f) (manifest fuseAcc a) x+        Stuple t             -> Stuple (cvtCT t)++    cvtCT :: Atuple (Consumer OpenAcc aenv senv) t -> Atuple (Consumer DelayedOpenAcc aenv senv) t+    cvtCT NilAtup        = NilAtup+    cvtCT (SnocAtup t c) = SnocAtup (cvtCT t) (cvtC c)++    cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f+    cvtAF (Alam f)  = Alam  (cvtAF f)+    cvtAF (Abody b) = Abody (manifest fuseAcc b)++    cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t+    cvtE = convertOpenExp fuseAcc++    cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f+    cvtF (Lam f)  = Lam (cvtF f)+    cvtF (Body b) = Body (cvtE b)+--}+++-- | Apply the fusion transformation to the AST to combine and simplify terms.+-- This converts terms into the internal delayed array representation and merges+-- adjacent producer/producer terms. Using the reduced internal form limits the+-- number of combinations that need to be considered.+--+type EmbedAcc acc = forall aenv arrs. Arrays arrs => acc aenv arrs -> Embed acc aenv arrs+type ElimAcc  acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Bool++embedOpenAcc :: Arrays arrs => Bool -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs+embedOpenAcc fuseAcc (OpenAcc pacc) =+  embedPreAcc fuseAcc (embedOpenAcc fuseAcc) elimOpenAcc pacc+  where+    -- When does the cost of re-computation outweigh that of memory access? For+    -- the moment only do the substitution on a single use of the bound array+    -- into the use site, but it is likely advantageous to be far more+    -- aggressive here.+    --+    -- SEE: [Sharing vs. Fusion]+    --+    elimOpenAcc :: ElimAcc OpenAcc+    elimOpenAcc _bnd body+      | count False ZeroIdx body <= lIMIT = True+      | otherwise                         = False+      where+        lIMIT = 1++        count :: UsesOfAcc OpenAcc+        count no ix (OpenAcc pacc) = usesOfPreAcc no count ix pacc+++embedPreAcc+    :: forall acc aenv arrs. (Kit acc, Arrays arrs)+    => Bool+    -> EmbedAcc   acc+    -> ElimAcc    acc+    -> PreOpenAcc acc aenv arrs+    -> Embed      acc aenv arrs+embedPreAcc fuseAcc embedAcc elimAcc pacc+  = unembed+  $ case pacc of++    -- Non-fusible terms+    -- -----------------+    --+    -- Solid and semi-solid terms that we generally do not wish to fuse, such+    -- as control flow (|?), array introduction (use, unit), array tupling and+    -- projection, and foreign function operations. Generally we also do not+    -- want to fuse past array let bindings, as this would imply work+    -- duplication. SEE: [Sharing vs. Fusion]+    --+    Apply f a           -> applyD (cvtAF f) (cvtA a)+    Alet bnd body       -> aletD embedAcc elimAcc bnd body+    Aprj ix tup         -> aprjD embedAcc ix tup+    Acond p at ae       -> acondD embedAcc (cvtE p) at ae+    Awhile p f a        -> done $ Awhile (cvtAF p) (cvtAF f) (cvtA a)+    Atuple tup          -> done $ Atuple (cvtAT tup)+    Aforeign ff f a     -> done $ Aforeign ff (cvtAF f) (cvtA a)+    -- Collect s           -> collectD s++    -- Array injection+    Avar v              -> done $ Avar v+    Use arrs            -> done $ Use arrs+    Unit e              -> done $ Unit (cvtE e)++    -- Producers+    -- ---------+    --+    -- The class of operations that given a set of zero or more input arrays,+    -- produce a _single_ element for the output array by manipulating a+    -- _single_ element from each input array. These can be further classified+    -- as value (map, zipWith) or index space (backpermute, slice, replicate)+    -- transformations.+    --+    -- The critical feature is that each element of the output is produced+    -- independently of all others, and so we can aggressively fuse arbitrary+    -- sequences of these operations.+    --+    Generate sh f       -> generateD (cvtE sh) (cvtF f)++    Map f a             -> mapD (cvtF f) (embedAcc a)+    ZipWith f a b       -> fuse2 (into zipWithD (cvtF f)) a b+    Transform sh p f a  -> transformD (cvtE sh) (cvtF p) (cvtF f) (embedAcc a)++    Backpermute sl p a  -> fuse (into2 backpermuteD      (cvtE sl) (cvtF p)) a+    Slice slix a sl     -> fuse (into  (sliceD slix)     (cvtE sl)) a+    Replicate slix sh a -> fuse (into  (replicateD slix) (cvtE sh)) a+    Reshape sl a        -> reshapeD (embedAcc a) (cvtE sl)++    -- Consumers+    -- ---------+    --+    -- Operations where each element of the output array depends on multiple+    -- elements of the input array. To implement these operations efficiently in+    -- parallel, we need to know how elements of the array depend on each other:+    -- a parallel scan is implemented very differently from a parallel fold, for+    -- example.+    --+    -- In order to avoid obfuscating this crucial information required for+    -- parallel implementation, fusion is separated into to phases:+    -- producer/producer, implemented above, and consumer/producer, which is+    -- implemented below. This will place producers adjacent to the consumer+    -- node, so that the producer can be directly embedded into the consumer+    -- during the code generation phase.+    --+    Fold f z a          -> embed  (into2 Fold          (cvtF f) (cvtE z)) a+    Fold1 f a           -> embed  (into  Fold1         (cvtF f)) a+    FoldSeg f z a s     -> embed2 (into2 FoldSeg       (cvtF f) (cvtE z)) a s+    Fold1Seg f a s      -> embed2 (into  Fold1Seg      (cvtF f)) a s+    Scanl f z a         -> embed  (into2 Scanl         (cvtF f) (cvtE z)) a+    Scanl1 f a          -> embed  (into  Scanl1        (cvtF f)) a+    Scanl' f z a        -> embed  (into2 Scanl'        (cvtF f) (cvtE z)) a+    Scanr f z a         -> embed  (into2 Scanr         (cvtF f) (cvtE z)) a+    Scanr1 f a          -> embed  (into  Scanr1        (cvtF f)) a+    Scanr' f z a        -> embed  (into2 Scanr'        (cvtF f) (cvtE z)) a+    Permute f d p a     -> embed2 (into2 permute       (cvtF f) (cvtF p)) d a+    Stencil f x a       -> stencil  (cvtF f) (cvtB x) a+    Stencil2 f x a y b  -> stencil2 (cvtF f) (cvtB x) (cvtB y) a b++  where+    -- If fusion is not enabled, force terms to the manifest representation+    --+    unembed :: Embed acc aenv arrs -> Embed acc aenv arrs+    unembed x+      | fuseAcc         = x+      | otherwise       = done (compute x)++    cvtA :: Arrays a => acc aenv' a -> acc aenv' a+    cvtA = computeAcc . embedAcc++    cvtAT :: Atuple (acc aenv') a -> Atuple (acc aenv') a+    cvtAT NilAtup          = NilAtup+    cvtAT (SnocAtup tup a) = cvtAT tup `SnocAtup` cvtA a++    cvtAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f+    cvtAF (Alam  f) = Alam  (cvtAF f)+    cvtAF (Abody a) = Abody (cvtA a)++    -- Helpers to shuffle the order of arguments to a constructor+    --+    permute f p d a     = Permute f d p a++    -- Stencils can delay their argument arrays+    --+    stencil+        :: Stencil sh a stencil+        => PreFun      acc aenv (stencil -> b)+        -> PreBoundary acc aenv (Array sh a)+        ->             acc aenv (Array sh a)+        -> Embed       acc aenv (Array sh b)+    stencil f@(Lam (Body e)) x =+      trav1 (if ua <= lIMIT then id else force) (into2 Stencil f x)+      where+        ua    = usesOfExp ZeroIdx e+        lIMIT = 1++    stencil2+        :: (Stencil sh a stencil1, Stencil sh b stencil2)+        => PreFun      acc aenv (stencil1 -> stencil2 -> c)+        -> PreBoundary acc aenv (Array sh a)+        -> PreBoundary acc aenv (Array sh b)+        ->             acc aenv (Array sh a)+        ->             acc aenv (Array sh b)+        -> Embed       acc aenv (Array sh c)+    stencil2 f@(Lam (Lam (Body e))) x y =+      trav2 (if ua <= lIMIT then id else force)+            (if ub <= lIMIT then id else force)+            (into3 op f x y)+      where+        op f x y a b  = Stencil2 f x a y b+        ua            = usesOfExp (SuccIdx ZeroIdx) e+        ub            = usesOfExp ZeroIdx           e+        lIMIT         = 1++    -- Conversions for closed scalar functions and expressions. This just+    -- applies scalar simplifications.+    --+    cvtF :: PreFun acc aenv' t -> PreFun acc aenv' t+    cvtF = simplify++    cvtE :: Elt t => PreExp acc aenv' t -> PreExp acc aenv' t+    cvtE = simplify++    cvtB :: PreBoundary acc aenv' t -> PreBoundary acc aenv' t+    cvtB Clamp        = Clamp+    cvtB Mirror       = Mirror+    cvtB Wrap         = Wrap+    cvtB (Constant c) = Constant c+    cvtB (Function f) = Function (cvtF f)++    -- Helpers to embed and fuse delayed terms+    --+    into :: Sink f => (f env' a -> b) -> f env a -> Extend acc env env' -> b+    into op a env = op (sink env a)++    into2 :: (Sink f1, Sink f2)+          => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b -> Extend acc env env' -> c+    into2 op a b env = op (sink env a) (sink env b)++    into3 :: (Sink f1, Sink f2, Sink f3)+          => (f1 env' a -> f2 env' b -> f3 env' c -> d) -> f1 env a -> f2 env b -> f3 env c -> Extend acc env env' -> d+    into3 op a b c env = op (sink env a) (sink env b) (sink env c)++    fuse :: Arrays as+         => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs)+         ->       acc aenv as+         -> Embed acc aenv bs+    fuse op (embedAcc -> Embed env cc) = Embed env (op env cc)++    fuse2 :: (Arrays as, Arrays bs)+          => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs -> Cunctation acc aenv' cs)+          ->       acc aenv as+          ->       acc aenv bs+          -> Embed acc aenv cs+    fuse2 op a1 a0+      | Embed env1 cc1  <- embedAcc a1+      , Embed env0 cc0  <- embedAcc (sink env1 a0)+      , env             <- env1 `append` env0+      = Embed env (op env (sink env0 cc1) cc0)++    embed :: (Arrays as, Arrays bs)+          => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs)+          ->       acc aenv as+          -> Embed acc aenv bs+    embed = trav1 id++    embed2 :: forall aenv as bs cs. (Arrays as, Arrays bs, Arrays cs)+           => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs)+           ->       acc aenv as+           ->       acc aenv bs+           -> Embed acc aenv cs+    embed2 = trav2 id id++    trav1 :: (Arrays as, Arrays bs)+          => (forall aenv'. Embed acc aenv' as -> Embed acc aenv' as)+          -> (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs)+          ->       acc aenv as+          -> Embed acc aenv bs+    trav1 f op (f . embedAcc -> Embed env cc)+      = Embed (env `PushEnv` inject (op env (inject (compute' cc)))) (Done ZeroIdx)++    trav2 :: forall aenv as bs cs. (Arrays as, Arrays bs, Arrays cs)+          => (forall aenv'. Embed acc aenv' as -> Embed acc aenv' as)+          -> (forall aenv'. Embed acc aenv' bs -> Embed acc aenv' bs)+          -> (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs)+          ->       acc aenv as+          ->       acc aenv bs+          -> Embed acc aenv cs+    trav2 f1 f0 op (f1 . embedAcc -> Embed env1 cc1) (f0 . embedAcc . sink env1 -> Embed env0 cc0)+      | env     <- env1 `append` env0+      , acc1    <- inject . compute' $ sink env0 cc1+      , acc0    <- inject . compute' $ cc0+      = Embed (env `PushEnv` inject (op env acc1 acc0)) (Done ZeroIdx)++    force :: Arrays as => Embed acc aenv' as -> Embed acc aenv' as+    force (Embed env cc)+      | Done{} <- cc = Embed env                                  cc+      | otherwise    = Embed (env `PushEnv` inject (compute' cc)) (Done ZeroIdx)++    -- -- Move additional bindings for producers outside of the sequence, so that+    -- -- producers may fuse with their arguments resulting in actual sequencing+    -- collectD :: PreOpenSeq acc aenv () arrs+    --          -> Embed acc aenv arrs+    -- collectD (embedSeq embedAcc -> ExtendSeq env s')+    --   = Embed (env `PushEnv` inject (Collect s')) (Done ZeroIdx)+++{--+-- Move additional bindings for producer outside of sequence, so+-- that producers may fuse with their arguments, resulting in+-- actual sequencing.+embedSeq :: forall acc aenv arrs. Kit acc+         => EmbedAcc acc+         -> PreOpenSeq acc aenv () arrs+         -> ExtendSeq       acc aenv () arrs+embedSeq embedAcc s+  = travS s BaseEnv+  where+    travS :: forall senv aenv' arrs'.+             PreOpenSeq acc aenv senv arrs'+          -> Extend acc aenv aenv'+          -> ExtendSeq acc aenv senv arrs'+    travS s env =+      case s of+        Producer p s+          | ExtendSeq env' s' <- travS s env+          , ExtendProducer env'' p' <- travP p env'+          -> ExtendSeq (env' `append` env'') (Producer p' (sinkSeq env'' s'))+        Consumer c+          | c' <- travC c env+          -> ExtendSeq env (Consumer c')+        Reify ix+          -> ExtendSeq env (Reify ix)++    travP :: forall arrs' aenv' senv.+             Producer acc aenv senv arrs'+          -> Extend acc aenv aenv'+          -> ExtendProducer acc aenv' senv arrs'+    travP (ToSeq slix sh a) env+      | Embed env' cc <- embedAcc (sink env a)+      = ExtendProducer env' (ToSeq slix sh (inject (compute' cc)))+    travP (StreamIn arrs) _          = ExtendProducer BaseEnv (StreamIn arrs)+    travP (MapSeq f x) env           = ExtendProducer BaseEnv (MapSeq (cvtAF (sink env f)) x)+    travP (ChunkedMapSeq f x) env    = ExtendProducer BaseEnv (ChunkedMapSeq (cvtAF (sink env f)) x)+    travP (ZipWithSeq f x y) env     = ExtendProducer BaseEnv (ZipWithSeq (cvtAF (sink env f)) x y)+    travP (ScanSeq f e x) env        = ExtendProducer BaseEnv (ScanSeq (cvtF (sink env f)) (cvtE (sink env e)) x)++    travC :: forall arrs' aenv' senv.+             Consumer acc aenv senv arrs'+          -> Extend acc aenv aenv'+          -> Consumer acc aenv' senv arrs'+    travC (FoldSeq f e x) env = FoldSeq (cvtF (sink env f)) (cvtE (sink env e)) x+    travC (FoldSeqFlatten f a x) env = FoldSeqFlatten (cvtAF (sink env f)) (cvtA (sink env a)) x+    travC (Stuple t) env = Stuple (cvtCT t)+      where+        cvtCT :: Atuple (Consumer acc aenv senv) t -> Atuple (Consumer acc aenv' senv) t+        cvtCT NilAtup        = NilAtup+        cvtCT (SnocAtup t c) = SnocAtup (cvtCT t) (travC c env)++    cvtE :: Elt t => PreExp acc aenv' t -> PreExp acc aenv' t+    cvtE = simplify++    cvtF :: PreFun acc aenv' t -> PreFun acc aenv' t+    cvtF = simplify++    cvtA :: Arrays a => acc aenv' a -> acc aenv' a+    cvtA = computeAcc . embedAcc++    cvtAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f+    cvtAF (Alam  f) = Alam  (cvtAF f)+    cvtAF (Abody a) = Abody (cvtA a)+++-- A sequence with additional bindings+data ExtendSeq acc aenv senv arrs where+  ExtendSeq :: forall acc aenv aenv' senv arrs.+                Extend acc aenv aenv'+             -> PreOpenSeq acc aenv' senv arrs+             -> ExtendSeq acc aenv senv arrs++-- A producer with additional bindings+data ExtendProducer acc aenv senv arrs where+  ExtendProducer :: forall acc aenv aenv' senv arrs.+                    Extend acc aenv aenv'+                 -> Producer acc aenv' senv arrs+                 -> ExtendProducer acc aenv senv arrs+--}+++-- Internal representation+-- =======================++-- Note: [Representing delayed array]+--+-- During the fusion transformation we represent terms as a pair consisting of+-- a collection of supplementary environment bindings and a description of how+-- to construct the array.+--+-- It is critical to separate these two. To create a real AST node we need both+-- the environment and array term, but analysis of how to fuse terms requires+-- only the array description. If the additional bindings are bundled as part of+-- the representation, the existentially quantified extended environment type+-- will be untouchable. This is problematic because the terms of the two arrays+-- are defined with respect to this existentially quantified type, and there is+-- no way to directly combine these two environments:+--+--   append :: Extend env env1 -> Extend env env2 -> Extend env ???+--+-- And hence, no way to combine the terms of the delayed representation.+--+-- The only way to bring terms into the same scope is to operate via the+-- manifest terms. This entails a great deal of conversion between delayed and+-- AST terms, but is certainly possible.+--+-- However, because of the limited scope into which this existential type is+-- available, we ultimately perform this process many times. In fact, complexity+-- of the fusion algorithm for an AST of N terms becomes O(r^n), where r is the+-- number of different rules we have for combining terms.+--+data Embed acc aenv a where+  Embed :: Extend     acc aenv aenv'+        -> Cunctation acc      aenv' a+        -> Embed      acc aenv       a+++-- Cunctation (n): the action or an instance of delaying; a tardy action.+--+-- This describes the ways in which the fusion transformation represents+-- intermediate arrays. The fusion process operates by recasting producer array+-- computations in terms of a set of scalar functions used to construct an+-- element at each index, and fusing successive producers by combining these+-- scalar functions.+--+data Cunctation acc aenv a where++  -- The base case is just a real (manifest) array term. No fusion happens here.+  -- Note that the array is referenced by an index into the extended+  -- environment, ensuring that the array is manifest and making the term+  -- non-recursive in 'acc'. Also note that the return type is a general+  -- instance of Arrays and not restricted to a single Array.+  --+  Done  :: Arrays a+        => Idx            aenv a+        -> Cunctation acc aenv a++  -- We can represent an array by its shape and a function to compute an element+  -- at each index.+  --+  Yield :: (Shape sh, Elt e)+        => PreExp     acc aenv sh+        -> PreFun     acc aenv (sh -> e)+        -> Cunctation acc aenv (Array sh e)++  -- A more restrictive form than 'Yield' may afford greater opportunities for+  -- optimisation by a backend. This more structured form applies an index and+  -- value transform to an input array. Note that the transform is applied to an+  -- array stored as an environment index, so that the term is non-recursive and+  -- it is always possible to embed into a collective operation.+  --+  Step  :: (Shape sh, Shape sh', Elt a, Elt b)+        => PreExp     acc aenv sh'+        -> PreFun     acc aenv (sh' -> sh)+        -> PreFun     acc aenv (a   -> b)+        -> Idx            aenv (Array sh  a)+        -> Cunctation acc aenv (Array sh' b)+++instance Kit acc => Simplify (Cunctation acc aenv a) where+  simplify (Done v)        = Done v+  simplify (Yield sh f)    = Yield (simplify sh) (simplify f)+  simplify (Step sh p f v) = Step (simplify sh) (simplify p) (simplify f) v+++-- Convert a real AST node into the internal representation+--+done :: (Arrays a, Kit acc) => PreOpenAcc acc aenv a -> Embed acc aenv a+done pacc+  | Avar v <- pacc      = Embed BaseEnv                         (Done v)+  | otherwise           = Embed (BaseEnv `PushEnv` inject pacc) (Done ZeroIdx)+++-- Recast a cunctation into a mapping from indices to elements.+--+yield :: Kit acc+      => Cunctation acc aenv (Array sh e)+      -> Cunctation acc aenv (Array sh e)+yield cc =+  case cc of+    Yield{}                             -> cc+    Step sh p f v                       -> Yield sh (f `compose` indexArray v `compose` p)+    Done v+      | ArraysRarray <- accType cc      -> Yield (arrayShape v) (indexArray v)+      | otherwise                       -> error "yield: impossible case"+++-- Recast a cunctation into transformation step form. Not possible if the source+-- was in the Yield formulation.+--+step :: Kit acc+     => Cunctation acc aenv (Array sh e)+     -> Maybe (Cunctation acc aenv (Array sh e))+step cc =+  case cc of+    Yield{}                             -> Nothing+    Step{}                              -> Just cc+    Done v+      | ArraysRarray <- accType cc      -> Just $ Step (arrayShape v) identity identity v+      | otherwise                       -> error "step: impossible case"+++-- Get the shape of a delayed array+--+shape :: Kit acc => Cunctation acc aenv (Array sh e) -> PreExp acc aenv sh+shape cc+  | Just (Step sh _ _ _) <- step cc     = sh+  | Yield sh _           <- yield cc    = sh+++-- Reified type of a delayed array representation.+--+accType :: forall acc aenv a. Arrays a => Cunctation acc aenv a -> ArraysR (ArrRepr a)+accType _ = arrays (undefined :: a)+++-- Environment manipulation+-- ========================++instance Kit acc => Sink (Cunctation acc) where+  weaken k cc = case cc of+    Done v              -> Done (weaken k v)+    Step sh p f v       -> Step (weaken k sh) (weaken k p) (weaken k f) (weaken k v)+    Yield sh f          -> Yield (weaken k sh) (weaken k f)++-- prjExtend :: Kit acc => Extend acc env env' -> Idx env' t -> PreOpenAcc acc env' t+-- prjExtend (PushEnv _   v) ZeroIdx       = weakenA rebuildAcc SuccIdx v+-- prjExtend (PushEnv env _) (SuccIdx idx) = weakenA rebuildAcc SuccIdx $ prjExtend env idx+-- prjExtend _               _             = $internalError "prjExtend" "inconsistent valuation"++{--+-- Rearrange type arguments to fit with Sink type class.+newtype SinkSeq acc senv aenv a = SinkSeq { unSinkSeq :: PreOpenSeq acc aenv senv a }++-- sink for sequences.+sinkSeq :: Kit acc => Extend acc aenv aenv' -> PreOpenSeq acc aenv senv a -> PreOpenSeq acc aenv' senv a+sinkSeq env s = unSinkSeq $ sink env (SinkSeq s)++instance Kit acc => Sink (SinkSeq acc senv) where+  weaken :: forall aenv aenv' arrs. aenv :> aenv' -> SinkSeq acc senv aenv arrs -> SinkSeq acc senv aenv' arrs+  weaken k (SinkSeq s) = SinkSeq $+    case s of+      Producer p s' -> Producer   (weakenP p) (weakenL s')+      Consumer c    -> Consumer   (weakenC c)+      Reify ix      -> Reify      ix++    where+      weakenL :: forall senv' arrs'. PreOpenSeq acc aenv senv' arrs' -> PreOpenSeq acc aenv' senv' arrs'+      weakenL s' = unSinkSeq (weaken k (SinkSeq s'))++      weakenP :: forall a. Producer acc aenv senv a -> Producer acc aenv' senv a+      weakenP p =+        case p of+          StreamIn arrs        -> StreamIn arrs+          ToSeq slix sh a      -> ToSeq slix sh (weaken k a)+          MapSeq f x           -> MapSeq (weaken k f) x+          ChunkedMapSeq f x    -> ChunkedMapSeq (weaken k f) x+          ZipWithSeq f x y     -> ZipWithSeq (weaken k f) x y+          ScanSeq f a x        -> ScanSeq (weaken k f) (weaken k a) x++      weakenC :: forall a. Consumer acc aenv senv a -> Consumer acc aenv' senv a+      weakenC c =+        case c of+          FoldSeq f a x        -> FoldSeq (weaken k f) (weaken k a) x+          FoldSeqFlatten f a x -> FoldSeqFlatten (weaken k f) (weaken k a) x+          Stuple t             ->+            let wk :: Atuple (Consumer acc aenv senv) t -> Atuple (Consumer acc aenv' senv) t+                wk NilAtup        = NilAtup+                wk (SnocAtup t c) = wk t `SnocAtup` weakenC c+            in+            Stuple (wk t)+--}++-- Array fusion of a de Bruijn computation AST+-- ===========================================++-- Array computations+-- ------------------++-- Recast the internal representation of delayed arrays into a real AST node.+-- Use the most specific version of a combinator whenever possible.+--+compute :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> PreOpenAcc acc aenv arrs+compute (Embed env cc) = bind env (compute' cc)++compute' :: (Kit acc, Arrays arrs) => Cunctation acc aenv arrs -> PreOpenAcc acc aenv arrs+compute' cc = case simplify cc of+  Done v                                              -> Avar v+  Yield sh f                                          -> Generate sh f+  Step sh p f v+    | Just Refl <- match sh (simplify (arrayShape v))+    , Just Refl <- isIdentity p+    , Just Refl <- isIdentity f                       -> Avar v+    | Just Refl <- match sh (simplify (arrayShape v))+    , Just Refl <- isIdentity p                       -> Map f (avarIn v)+    | Just Refl <- isIdentity f                       -> Backpermute sh p (avarIn v)+    | otherwise                                       -> Transform sh p f (avarIn v)+++-- Evaluate a delayed computation and tie the recursive knot+--+computeAcc :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> acc aenv arrs+computeAcc = inject . compute+++-- Representation of a generator as a delayed array+--+generateD :: (Shape sh, Elt e)+          => PreExp acc aenv sh+          -> PreFun acc aenv (sh -> e)+          -> Embed  acc aenv (Array sh e)+generateD sh f+  = Stats.ruleFired "generateD"+  $ Embed BaseEnv (Yield sh f)+++-- Fuse a unary function into a delayed array. Also looks for unzips which can+-- be executed in constant time; SEE [unzipD]+--+mapD :: (Kit acc, Shape sh, Elt a, Elt b)+     => PreFun acc aenv (a -> b)+     -> Embed  acc aenv (Array sh a)+     -> Embed  acc aenv (Array sh b)+mapD f (unzipD f -> Just a) = a+mapD f (Embed env cc)+  = Stats.ruleFired "mapD"+  $ Embed env (go cc)+  where+    go (step  -> Just (Step sh ix g v)) = Step sh ix (sink env f `compose` g) v+    go (yield -> Yield sh g)            = Yield sh (sink env f `compose` g)+++-- If we are unzipping a manifest array then force the term to be computed;+-- a backend will be able to execute this in constant time. This operations+-- looks for the right terms recursively, splitting operations such as:+--+-- > map (\x -> fst . fst ... x) arr+--+-- into multiple stages so that they can all be executed in constant time:+--+-- > map fst . map fst ... arr+--+-- Note that this is a speculative operation, since we could dig under several+-- levels of projection before discovering that the operation can not be+-- unzipped. This should be fine though because digging through the terms is+-- cheap; no environment changing operations are required.+--+unzipD+    :: forall acc aenv sh a b. (Kit acc, Shape sh, Elt a, Elt b)+    => PreFun acc aenv (a -> b)+    -> Embed  acc aenv (Array sh a)+    -> Maybe (Embed acc aenv (Array sh b))+unzipD f (Embed env (Done v))+  | TypeRscalar VectorScalarType{} <- eltType (undefined::a)+  = Nothing++  | Lam (Body (Prj tix (Var ZeroIdx))) <- f+  = Stats.ruleFired "unzipD"+  $ let f' = Lam (Body (Prj tix (Var ZeroIdx)))+        a' = avarIn v+    in+    Just $ Embed (env `PushEnv` inject (Map f' a')) (Done ZeroIdx)++  | Lam (Body (Prj tix p@Prj{}))       <- f+  , Just (Embed env' (Done v'))        <- unzipD (Lam (Body p)) (Embed env (Done v))+  = Stats.ruleFired "unzipD"+  $ let f' = Lam (Body (Prj tix (Var ZeroIdx)))+        a' = avarIn v'+    in+    Just $ Embed (env' `PushEnv` inject (Map f' a')) (Done ZeroIdx)++unzipD _ _+  = Nothing+++-- Fuse an index space transformation function that specifies where elements in+-- the destination array read there data from in the source array.+--+backpermuteD+    :: (Kit acc, Shape sh')+    => PreExp     acc aenv sh'+    -> PreFun     acc aenv (sh' -> sh)+    -> Cunctation acc aenv (Array sh  e)+    -> Cunctation acc aenv (Array sh' e)+backpermuteD sh' p = Stats.ruleFired "backpermuteD" . go+  where+    go (step  -> Just (Step _ q f v)) = Step sh' (q `compose` p) f v+    go (yield -> Yield _ g)           = Yield sh' (g `compose` p)+++-- Transform as a combined map and backwards permutation+--+transformD+    :: (Kit acc, Shape sh, Shape sh', Elt a, Elt b)+    => PreExp acc aenv sh'+    -> PreFun acc aenv (sh' -> sh)+    -> PreFun acc aenv (a   -> b)+    -> Embed  acc aenv (Array sh  a)+    -> Embed  acc aenv (Array sh' b)+transformD sh' p f+  = Stats.ruleFired "transformD"+  . fuse (into2 backpermuteD sh' p)+  . mapD f+  where+    fuse :: (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs)+         -> Embed acc aenv as+         -> Embed acc aenv bs+    fuse op (Embed env cc) = Embed env (op env cc)++    into2 :: (Sink f1, Sink f2)+          => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b -> Extend acc env env' -> c+    into2 op a b env = op (sink env a) (sink env b)+++-- Replicate as a backwards permutation+--+-- TODO: If we have a pattern such as `replicate sh (map f xs)` then in some+--       cases it might be beneficial to not fuse these terms, if `f` is+--       expensive and/or `sh` is large.+--+replicateD+    :: (Kit acc, Shape sh, Shape sl, Elt slix)+    => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+    -> PreExp     acc aenv slix+    -> Cunctation acc aenv (Array sl e)+    -> Cunctation acc aenv (Array sh e)+replicateD sliceIndex slix cc+  = Stats.ruleFired "replicateD"+  $ backpermuteD (IndexFull sliceIndex slix (shape cc)) (extend sliceIndex slix) cc+++-- Dimensional slice as a backwards permutation+--+sliceD+    :: (Kit acc, Shape sh, Shape sl, Elt slix)+    => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+    -> PreExp     acc aenv slix+    -> Cunctation acc aenv (Array sh e)+    -> Cunctation acc aenv (Array sl e)+sliceD sliceIndex slix cc+  = Stats.ruleFired "sliceD"+  $ backpermuteD (IndexSlice sliceIndex slix (shape cc)) (restrict sliceIndex slix) cc+++-- Reshape an array+--+-- For delayed arrays this is implemented as an index space transformation. For+-- manifest arrays this can be done with the standard Reshape operation in+-- constant time without executing any array operations. This does not affect+-- the fusion process since the term is already manifest.+--+-- TLM: there was a runtime check to ensure the old and new shapes contained the+--      same number of elements: this has been lost for the delayed cases!+--+reshapeD+    :: (Kit acc, Shape sh, Shape sl, Elt e)+    => Embed  acc aenv (Array sh e)+    -> PreExp acc aenv sl+    -> Embed  acc aenv (Array sl e)+reshapeD (Embed env cc) (sink env -> sl)+  | Done v      <- cc+  = Embed (env `PushEnv` inject (Reshape sl (avarIn v))) (Done ZeroIdx)++  | otherwise+  = Stats.ruleFired "reshapeD"+  $ Embed env (backpermuteD sl (reindex (shape cc) sl) cc)+++-- Combine two arrays element-wise with a binary function to produce a delayed+-- array.+--+zipWithD :: (Kit acc, Shape sh, Elt a, Elt b, Elt c)+         => PreFun     acc aenv (a -> b -> c)+         -> Cunctation acc aenv (Array sh a)+         -> Cunctation acc aenv (Array sh b)+         -> Cunctation acc aenv (Array sh c)+zipWithD f cc1 cc0+  -- Two stepper functions identically accessing the same array can be kept in+  -- stepping form. This might yield a simpler final term.+  --+  | Just (Step sh1 p1 f1 v1)    <- step cc1+  , Just (Step sh0 p0 f0 v0)    <- step cc0+  , Just Refl                   <- match v1 v0+  , Just Refl                   <- match p1 p0+  = Stats.ruleFired "zipWithD/step"+  $ Step (sh1 `Intersect` sh0) p0 (combine f f1 f0) v0++  -- Otherwise transform both delayed terms into (index -> value) mappings and+  -- combine the two indexing functions that way.+  --+  | Yield sh1 f1                <- yield cc1+  , Yield sh0 f0                <- yield cc0+  = Stats.ruleFired "zipWithD"+  $ Yield (sh1 `Intersect` sh0) (combine f f1 f0)++  where+    combine :: forall acc aenv a b c e. (Kit acc, Elt a, Elt b, Elt c)+            => PreFun acc aenv (a -> b -> c)+            -> PreFun acc aenv (e -> a)+            -> PreFun acc aenv (e -> b)+            -> PreFun acc aenv (e -> c)+    combine c ixa ixb+      | Lam (Lam (Body c'))     <- weakenE SuccIdx c   :: PreOpenFun acc ((),e) aenv (a -> b -> c)+      , Lam (Body ixa')         <- ixa                          -- else the skolem 'e' will escape+      , Lam (Body ixb')         <- ixb+      = Lam $ Body $ Let ixa' $ Let (weakenE SuccIdx ixb') c'+++-- NOTE: [Sharing vs. Fusion]+--+-- The approach to array fusion is similar to that the first generation of Repa.+-- It was discovered that the most immediately pressing problem with delayed+-- arrays in Repa-1 was that it did not preserve sharing of collective+-- operations, leading to excessive recomputation and severe repercussions on+-- performance if the user did not explicitly intervene.+--+-- However, as we have explicit sharing information in the term tree, so it is+-- straightforward to respect sharing by not fusing let-bindings, as that+-- introduces work duplication. However, sometimes we can be cleverer.+--+-- let-floating:+-- -------------+--+-- If the binding is of manifest data, we can instead move the let-binding to a+-- different point in the program and then continue to fuse into the body. This+-- is done by adding the bound term to the Extend environment. In essence this+-- is covering a different occurrence of the same problem Extend was introduced+-- to handle: let bindings of manifest data unnecessarily get in the way of the+-- fusion process. For example:+--+--   map f (zipWith g xs (map h xs))+--+-- after sharing recovery results in:+--+--   map f (let a0 = xs in zipWith g a0 (map h a0))+--+-- Without allowing the binding for a0 to float outwards, `map f` will not be+-- fused into the rest of the program.+--+-- let-elimination:+-- ----------------+--+-- Array binding points appear in the program because the array data _or_ shape+-- was accessed multiple times in the source program. In general we want to fuse+-- arbitrary sequences of array _data_, irrespective of how the shape component+-- is used. For example, reverse is defined in the prelude as:+--+--   reverse xs = let len   = unindex1 (shape xs)+--                    pf i  = len - i - 1+--                in+--                backpermute (shape xs) (ilift1 pf) xs+--+-- Sharing recovery introduces a let-binding for the input `xs` since it is used+-- thrice in the definition, which impedes subsequent fusion. However the actual+-- array data is only accessed once, with the remaining two uses querying the+-- array shape. Since the delayed terms contain the shape of the array they+-- represent as a scalar term, if the data component otherwise satisfies the+-- rules for fusing terms, as it does in this example, we can eliminate the+-- let-binding by pushing the scalar shape and value generation terms directly+-- into the body.+--+-- Let-elimination can also be used to _introduce_ work duplication, which may+-- be beneficial if we can estimate that the cost of recomputation is less than+-- the cost of completely evaluating the array and subsequently retrieving the+-- data from memory.+--+-- let-binding:+-- ------------+--+-- Ultimately, we might not want to eliminate the binding. If so, evaluate it+-- and add it to a _clean_ Extend environment for the body. If not, the Extend+-- list effectively _flattens_ all bindings, so any terms required for the bound+-- term get lifted out to the same scope as the body. This increases their+-- lifetime and hence raises the maximum memory used. If we don't do this, we+-- get terms such as:+--+--   let a0  = <terms for binding> in+--   let bnd = <bound term> in+--   <body term>+--+-- rather than the following, where the scope of a0 is clearly only availably+-- when evaluating the bound term, as it should be:+--+--   let bnd =+--     let a0 = <terms for binding>+--     in <bound term>+--   in <body term>+--+aletD :: (Kit acc, Arrays arrs, Arrays brrs)+      => EmbedAcc acc+      -> ElimAcc  acc+      ->          acc aenv        arrs+      ->          acc (aenv,arrs) brrs+      -> Embed    acc aenv        brrs+aletD embedAcc elimAcc (embedAcc -> Embed env1 cc1) acc0++  -- let-floating+  -- ------------+  --+  -- Immediately inline the variable referring to the bound expression into the+  -- body, instead of adding to the environments and creating an indirection+  -- that must be later eliminated by shrinking.+  --+  | Done v1             <- cc1+  , Embed env0 cc0      <- embedAcc $ rebuildA (subAtop (Avar v1) . sink1 env1) acc0+  = Stats.ruleFired "aletD/float"+  $ Embed (env1 `append` env0) cc0++  -- Ensure we only call 'embedAcc' once on the body expression+  --+  | otherwise+  = aletD' embedAcc elimAcc (Embed env1 cc1) (embedAcc acc0)+++aletD' :: forall acc aenv arrs brrs. (Kit acc, Arrays arrs, Arrays brrs)+       => EmbedAcc acc+       -> ElimAcc  acc+       -> Embed    acc aenv         arrs+       -> Embed    acc (aenv, arrs) brrs+       -> Embed    acc aenv         brrs+aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0)++  -- let-binding+  -- -----------+  --+  -- Check whether we can eliminate the let-binding. Note that we must inspect+  -- the entire term, not just the Cunctation that would be produced by+  -- embedAcc. If we don't we can be left with dead terms that don't get+  -- eliminated. This problem occurred in the canny program.+  --+  | acc1                <- compute (Embed env1 cc1)+  , False               <- elimAcc (inject acc1) acc0+  = Stats.ruleFired "aletD/bind"+  $ Embed (BaseEnv `PushEnv` inject acc1 `append` env0) cc0++  -- let-elimination+  -- ---------------+  --+  -- Handle the remaining cases in a separate function. It turns out that this+  -- is important so we aren't excessively sinking/delaying terms.+  --+  | acc0'               <- sink1 env1 acc0+  = Stats.ruleFired "aletD/eliminate"+  $ case cc1 of+      Step{}    -> eliminate env1 cc1 acc0'+      Yield{}   -> eliminate env1 cc1 acc0'++  where+    acc0 :: acc (aenv, arrs) brrs+    acc0 = computeAcc (Embed env0 cc0)++    -- The second part of let-elimination. Splitting into two steps exposes the+    -- extra type variables, and ensures we don't do extra work manipulating the+    -- body when not necessary (which can lead to a complexity blowup).+    --+    eliminate :: forall aenv aenv' sh e brrs. (Shape sh, Elt e, Arrays brrs)+              => Extend     acc aenv aenv'+              -> Cunctation acc      aenv' (Array sh e)+              ->            acc     (aenv', Array sh e) brrs+              -> Embed      acc aenv                    brrs+    eliminate env1 cc1 body+      | Done v1           <- cc1 = elim (arrayShape v1) (indexArray v1)+      | Step sh1 p1 f1 v1 <- cc1 = elim sh1 (f1 `compose` indexArray v1 `compose` p1)+      | Yield sh1 f1      <- cc1 = elim sh1 f1+      where+        bnd :: PreOpenAcc acc aenv' (Array sh e)+        bnd = compute' cc1++        elim :: PreExp acc aenv' sh -> PreFun acc aenv' (sh -> e) -> Embed acc aenv brrs+        elim sh1 f1+          | sh1'                <- weaken SuccIdx sh1+          , f1'                 <- weaken SuccIdx f1+          , Embed env0' cc0'    <- embedAcc $ rebuildA (subAtop bnd) $ kmap (replaceA sh1' f1' ZeroIdx) body+          = Embed (env1 `append` env0') cc0'++    -- As part of let-elimination, we need to replace uses of array variables in+    -- scalar expressions with an equivalent expression that generates the+    -- result directly+    --+    -- TODO: when we inline bindings we ought to let bind at the first+    --       occurrence and use a variable at all subsequent locations. At the+    --       moment we are just hoping CSE in the simplifier phase does good+    --       things, but that is limited in what it looks for.+    --+    replaceE :: forall env aenv sh e t. (Shape sh, Elt e)+             => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> Idx aenv (Array sh e)+             -> PreOpenExp acc env aenv t+             -> PreOpenExp acc env aenv t+    replaceE sh' f' avar exp =+      case exp of+        Let x y                         -> Let (cvtE x) (replaceE (weakenE SuccIdx sh') (weakenE SuccIdx f') avar y)+        Var i                           -> Var i+        Foreign ff f e                  -> Foreign ff f (cvtE e)+        Const c                         -> Const c+        Undef                           -> Undef+        Tuple t                         -> Tuple (cvtT t)+        Prj ix e                        -> Prj ix (cvtE e)+        IndexNil                        -> IndexNil+        IndexCons sl sz                 -> IndexCons (cvtE sl) (cvtE sz)+        IndexHead sh                    -> IndexHead (cvtE sh)+        IndexTail sz                    -> IndexTail (cvtE sz)+        IndexAny                        -> IndexAny+        IndexSlice x ix sh              -> IndexSlice x (cvtE ix) (cvtE sh)+        IndexFull x ix sl               -> IndexFull x (cvtE ix) (cvtE sl)+        ToIndex sh ix                   -> ToIndex (cvtE sh) (cvtE ix)+        FromIndex sh i                  -> FromIndex (cvtE sh) (cvtE i)+        Cond p t e                      -> Cond (cvtE p) (cvtE t) (cvtE e)+        PrimConst c                     -> PrimConst c+        PrimApp g x                     -> PrimApp g (cvtE x)+        ShapeSize sh                    -> ShapeSize (cvtE sh)+        Intersect sh sl                 -> Intersect (cvtE sh) (cvtE sl)+        Union s t                       -> Union (cvtE s) (cvtE t)+        While p f x                     -> While (replaceF sh' f' avar p) (replaceF sh' f' avar f) (cvtE x)+        Coerce e                        -> Coerce (cvtE e)++        Shape a+          | Just Refl <- match a a'     -> Stats.substitution "replaceE/shape" sh'+          | otherwise                   -> exp++        Index a sh+          | Just Refl    <- match a a'+          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!" . cvtE $ Let sh b+          | otherwise                   -> Index a (cvtE sh)++        LinearIndex a i+          | Just Refl    <- match a a'+          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!!" . cvtE $ Let (Let i (FromIndex (weakenE SuccIdx sh') (Var ZeroIdx))) b+          | otherwise                   -> LinearIndex a (cvtE i)++      where+        a' :: acc aenv (Array sh e)+        a' = avarIn avar++        cvtE :: PreOpenExp acc env aenv s -> PreOpenExp acc env aenv s+        cvtE = replaceE sh' f' avar++        cvtT :: Tuple (PreOpenExp acc env aenv) s -> Tuple (PreOpenExp acc env aenv) s+        cvtT NilTup        = NilTup+        cvtT (SnocTup t e) = cvtT t `SnocTup` cvtE e++    replaceF :: forall env aenv sh e t. (Shape sh, Elt e)+             => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> Idx aenv (Array sh e)+             -> PreOpenFun acc env aenv t+             -> PreOpenFun acc env aenv t+    replaceF sh' f' avar fun =+      case fun of+        Body e          -> Body (replaceE sh' f' avar e)+        Lam f           -> Lam  (replaceF (weakenE SuccIdx sh') (weakenE SuccIdx f') avar f)++    replaceA :: forall aenv sh e a. (Shape sh, Elt e)+             => PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> Idx aenv (Array sh e)+             -> PreOpenAcc acc aenv a+             -> PreOpenAcc acc aenv a+    replaceA sh' f' avar pacc =+      case pacc of+        Avar v+          | Just Refl <- match v avar   -> Avar avar+          | otherwise                   -> Avar v++        Alet bnd body                   ->+          let sh'' = weaken SuccIdx sh'+              f''  = weaken SuccIdx f'+          in+          Alet (cvtA bnd) (kmap (replaceA sh'' f'' (SuccIdx avar)) body)++        Use arrs                -> Use arrs+        Unit e                  -> Unit (cvtE e)+        Acond p at ae           -> Acond (cvtE p) (cvtA at) (cvtA ae)+        Aprj ix tup             -> Aprj ix (cvtA tup)+        Atuple tup              -> Atuple (cvtAT tup)+        Awhile p f a            -> Awhile (cvtAF p) (cvtAF f) (cvtA a)+        Apply f a               -> Apply (cvtAF f) (cvtA a)+        Aforeign ff f a         -> Aforeign ff f (cvtA a)       -- no sharing between f and a+        Generate sh f           -> Generate (cvtE sh) (cvtF f)+        Map f a                 -> Map (cvtF f) (cvtA a)+        ZipWith f a b           -> ZipWith (cvtF f) (cvtA a) (cvtA b)+        Backpermute sh p a      -> Backpermute (cvtE sh) (cvtF p) (cvtA a)+        Transform sh p f a      -> Transform (cvtE sh) (cvtF p) (cvtF f) (cvtA a)+        Slice slix a sl         -> Slice slix (cvtA a) (cvtE sl)+        Replicate slix sh a     -> Replicate slix (cvtE sh) (cvtA a)+        Reshape sl a            -> Reshape (cvtE sl) (cvtA a)+        Fold f z a              -> Fold (cvtF f) (cvtE z) (cvtA a)+        Fold1 f a               -> Fold1 (cvtF f) (cvtA a)+        FoldSeg f z a s         -> FoldSeg (cvtF f) (cvtE z) (cvtA a) (cvtA s)+        Fold1Seg f a s          -> Fold1Seg (cvtF f) (cvtA a) (cvtA s)+        Scanl f z a             -> Scanl (cvtF f) (cvtE z) (cvtA a)+        Scanl1 f a              -> Scanl1 (cvtF f) (cvtA a)+        Scanl' f z a            -> Scanl' (cvtF f) (cvtE z) (cvtA a)+        Scanr f z a             -> Scanr (cvtF f) (cvtE z) (cvtA a)+        Scanr1 f a              -> Scanr1 (cvtF f) (cvtA a)+        Scanr' f z a            -> Scanr' (cvtF f) (cvtE z) (cvtA a)+        Permute f d p a         -> Permute (cvtF f) (cvtA d) (cvtF p) (cvtA a)+        Stencil f x a           -> Stencil (cvtF f) (cvtB x) (cvtA a)+        Stencil2 f x a y b      -> Stencil2 (cvtF f) (cvtB x) (cvtA a) (cvtB y) (cvtA b)+        -- Collect seq             -> Collect (cvtSeq seq)++      where+        cvtA :: acc aenv s -> acc aenv s+        cvtA = kmap (replaceA sh' f' avar)++        cvtE :: PreExp acc aenv s -> PreExp acc aenv s+        cvtE = replaceE sh' f' avar++        cvtF :: PreFun acc aenv s -> PreFun acc aenv s+        cvtF = replaceF sh' f' avar++        cvtB :: PreBoundary acc aenv s -> PreBoundary acc aenv s+        cvtB Clamp        = Clamp+        cvtB Mirror       = Mirror+        cvtB Wrap         = Wrap+        cvtB (Constant c) = Constant c+        cvtB (Function f) = Function (cvtF f)++        cvtAT :: Atuple (acc aenv) s -> Atuple (acc aenv) s+        cvtAT NilAtup          = NilAtup+        cvtAT (SnocAtup tup a) = cvtAT tup `SnocAtup` cvtA a++        cvtAF :: PreOpenAfun acc aenv s -> PreOpenAfun acc aenv s+        cvtAF = cvt sh' f' avar+          where+            cvt :: forall aenv a.+                   PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> Idx aenv (Array sh e)+                -> PreOpenAfun acc aenv a+                -> PreOpenAfun acc aenv a+            cvt sh'' f'' avar' (Abody a) = Abody $ kmap (replaceA sh'' f'' avar') a+            cvt sh'' f'' avar' (Alam af) = Alam  $ cvt (weaken SuccIdx sh'')+                                                       (weaken SuccIdx f'')+                                                       (SuccIdx avar')+                                                       af++{--+        cvtSeq :: PreOpenSeq acc aenv senv s -> PreOpenSeq acc aenv senv s+        cvtSeq s =+          case s of+            Producer p s' ->+              Producer+                (case p of+                   StreamIn arrs        -> StreamIn arrs+                   ToSeq slix sh a      -> ToSeq slix sh (cvtA a)+                   MapSeq f x           -> MapSeq (cvtAF f) x+                   ChunkedMapSeq f x    -> ChunkedMapSeq (cvtAF f) x+                   ZipWithSeq f x y     -> ZipWithSeq (cvtAF f) x y+                   ScanSeq f e x        -> ScanSeq (cvtF f) (cvtE e) x)+                (cvtSeq s')+            Consumer c ->+              Consumer (cvtC c)+            Reify ix -> Reify ix++        cvtC :: Consumer acc aenv senv s -> Consumer acc aenv senv s+        cvtC c =+          case c of+            FoldSeq f e x        -> FoldSeq (cvtF f) (cvtE e) x+            FoldSeqFlatten f a x -> FoldSeqFlatten (cvtAF f) (cvtA a) x+            Stuple t             -> Stuple (cvtCT t)++        cvtCT :: Atuple (Consumer acc aenv senv) t -> Atuple (Consumer acc aenv senv) t+        cvtCT NilAtup        = NilAtup+        cvtCT (SnocAtup t c) = cvtCT t `SnocAtup` cvtC c+--}+++-- The apply operator, or (>->) in the surface language. This eliminates+-- redundant application to an identity function, instead lifting the argument+-- to a let-binding. This case arises in the use of pipe to avoid fusion and+-- force its argument to be evaluated, e.g.:+--+-- > compute :: Acc a -> Acc a+-- > compute = id >-> id+--+applyD :: (Kit acc, Arrays as, Arrays bs)+       => PreOpenAfun acc aenv (as -> bs)+       ->             acc aenv as+       -> Embed       acc aenv bs+applyD afun x+  | Alam (Abody body)   <- afun+  , Avar ZeroIdx        <- extract body+  = Stats.ruleFired "applyD/identity"+  $ done $ extract x++  | otherwise+  = done $ Apply afun x+++-- Array conditionals, in particular eliminate branches when the predicate+-- reduces to a known constant.+--+-- Note that we take the raw unprocessed terms as input. If instead we had the+-- terms for each branch in the delayed representation, this would require that+-- each term has been sunk into a common environment, which implies the+-- conditional has been pushed underneath the intersection of bound terms for+-- both branches. This would result in redundant work processing the bindings+-- for the branch not taken.+--+acondD :: (Kit acc, Arrays arrs)+       => EmbedAcc acc+       -> PreExp   acc aenv Bool+       ->          acc aenv arrs+       ->          acc aenv arrs+       -> Embed    acc aenv arrs+acondD embedAcc p t e+  | Const True  <- p        = Stats.knownBranch "True"      $ embedAcc t+  | Const False <- p        = Stats.knownBranch "False"     $ embedAcc e+  | Just Refl <- match t e  = Stats.knownBranch "redundant" $ embedAcc e+  | otherwise               = done $ Acond p (computeAcc (embedAcc t))+                                             (computeAcc (embedAcc e))+++-- Array tuple projection. Whenever possible we want to peek underneath the+-- tuple structure and continue the fusion process.+--+aprjD :: forall acc aenv arrs a. (Kit acc, IsAtuple arrs, Arrays arrs, Arrays a)+      => EmbedAcc acc+      -> TupleIdx (TupleRepr arrs) a+      ->       acc aenv arrs+      -> Embed acc aenv a+aprjD embedAcc ix a+  | Atuple tup <- extract a = Stats.ruleFired "aprj/Atuple" . embedAcc $ aprjAT ix tup+  | otherwise               = done $ Aprj ix (cvtA a)+  where+    cvtA :: acc aenv arrs -> acc aenv arrs+    cvtA = computeAcc . embedAcc++    aprjAT :: TupleIdx atup a -> Atuple (acc aenv) atup -> acc aenv a+    aprjAT ZeroTupIdx      (SnocAtup _ a) = a+    aprjAT (SuccTupIdx ix) (SnocAtup t _) = aprjAT ix t+++-- Scalar expressions+-- ------------------++isIdentity :: PreFun acc aenv (a -> b) -> Maybe (a :~: b)+isIdentity f+  | Lam (Body (Var ZeroIdx)) <- f       = Just Refl+  | otherwise                           = Nothing++identity :: Elt a => PreOpenFun acc env aenv (a -> a)+identity = Lam (Body (Var ZeroIdx))++toIndex :: (Kit acc, Shape sh) => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> Int)+toIndex sh = Lam (Body (ToIndex (weakenE SuccIdx sh) (Var ZeroIdx)))++fromIndex :: (Kit acc, Shape sh) => PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (Int -> sh)+fromIndex sh = Lam (Body (FromIndex (weakenE SuccIdx sh) (Var ZeroIdx)))++reindex :: (Kit acc, Shape sh, Shape sh')+        => PreOpenExp acc env aenv sh'+        -> PreOpenExp acc env aenv sh+        -> PreOpenFun acc env aenv (sh -> sh')+reindex sh' sh+  | Just Refl <- match sh sh'   = identity+  | otherwise                   = fromIndex sh' `compose` toIndex sh++extend :: (Kit acc, Shape sh, Shape sl, Elt slix)+       => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+       -> PreExp acc aenv slix+       -> PreFun acc aenv (sh -> sl)+extend sliceIndex slix = Lam (Body (IndexSlice sliceIndex (weakenE SuccIdx slix) (Var ZeroIdx)))++restrict :: (Kit acc, Shape sh, Shape sl, Elt slix)+         => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+         -> PreExp acc aenv slix+         -> PreFun acc aenv (sl -> sh)+restrict sliceIndex slix = Lam (Body (IndexFull sliceIndex (weakenE SuccIdx slix) (Var ZeroIdx)))++arrayShape :: (Kit acc, Shape sh, Elt e) => Idx aenv (Array sh e) -> PreExp acc aenv sh+arrayShape = Shape . avarIn++indexArray :: (Kit acc, Shape sh, Elt e) => Idx aenv (Array sh e) -> PreFun acc aenv (sh -> e)+indexArray v = Lam (Body (Index (avarIn v) (Var ZeroIdx)))++linearIndex :: (Kit acc, Shape sh, Elt e) => Idx aenv (Array sh e) -> PreFun acc aenv (Int -> e)+linearIndex v = Lam (Body (LinearIndex (avarIn v) (Var ZeroIdx)))+
+ src/Data/Array/Accelerate/Trafo/Rewrite.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Array.Accelerate.Trafo.Rewrite+-- 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.Trafo.Rewrite+  where++import Prelude                                          hiding ( seq )++-- friends+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Trafo.Substitution+import Data.Array.Accelerate.Array.Sugar                ( Arrays, Segments, Elt, fromElt, Tuple(..), Atuple(..) )+++-- Convert segment length arrays passed to segmented operations into offset+-- index style. This is achieved by wrapping the segmented array argument in a+-- left prefix-sum, so you must only ever apply this once.+--+convertSegments :: OpenAcc aenv a -> OpenAcc aenv a+convertSegments = cvtA+  where+    cvtT :: Atuple (OpenAcc aenv) t -> Atuple (OpenAcc aenv) t+    cvtT atup = case atup of+      NilAtup      -> NilAtup+      SnocAtup t a -> cvtT t `SnocAtup` cvtA a++    cvtAfun :: OpenAfun aenv t -> OpenAfun aenv t+    cvtAfun = convertSegmentsAfun++    cvtE :: Exp aenv t -> Exp aenv t+    cvtE = id++    cvtF :: Fun aenv t -> Fun aenv t+    cvtF = id++    a0 :: Arrays a => OpenAcc (aenv, a) a+    a0 = OpenAcc (Avar ZeroIdx)++    segments :: (Elt i, IsIntegral i) => OpenAcc aenv (Segments i) -> OpenAcc aenv (Segments i)+    segments s = OpenAcc $ Scanl plus zero (cvtA s)++    zero :: forall aenv i. (Elt i, IsIntegral i) => PreOpenExp OpenAcc () aenv i+    zero = Const (fromElt (0::i))++    plus :: (Elt i, IsIntegral i) => PreOpenFun OpenAcc () aenv (i -> i -> i)+    plus = Lam (Lam (Body (PrimAdd numType+                          `PrimApp`+                          Tuple (NilTup `SnocTup` Var (SuccIdx ZeroIdx)+                                        `SnocTup` Var ZeroIdx))))++    cvtA :: OpenAcc aenv a -> OpenAcc aenv a+    cvtA (OpenAcc pacc) = OpenAcc $ case pacc of+      Alet bnd body             -> Alet (cvtA bnd) (cvtA body)+      Avar ix                   -> Avar ix+      Atuple tup                -> Atuple (cvtT tup)+      Aprj tup a                -> Aprj tup (cvtA a)+      Apply f a                 -> Apply (cvtAfun f) (cvtA a)+      Aforeign ff afun acc      -> Aforeign ff (cvtAfun afun) (cvtA acc)+      Acond p t e               -> Acond (cvtE p) (cvtA t) (cvtA e)+      Awhile p f a              -> Awhile (cvtAfun p) (cvtAfun f) (cvtA a)+      Use a                     -> Use a+      Unit e                    -> Unit (cvtE e)+      Reshape e a               -> Reshape (cvtE e) (cvtA a)+      Generate e f              -> Generate (cvtE e) (cvtF f)+      Transform sh ix f a       -> Transform (cvtE sh) (cvtF ix) (cvtF f) (cvtA a)+      Replicate sl slix a       -> Replicate sl (cvtE slix) (cvtA a)+      Slice sl a slix           -> Slice sl (cvtA a) (cvtE slix)+      Map f a                   -> Map (cvtF f) (cvtA a)+      ZipWith f a1 a2           -> ZipWith (cvtF f) (cvtA a1) (cvtA a2)+      Fold f z a                -> Fold (cvtF f) (cvtE z) (cvtA a)+      Fold1 f a                 -> Fold1 (cvtF f) (cvtA a)+      Scanl f z a               -> Scanl (cvtF f) (cvtE z) (cvtA a)+      Scanl' f z a              -> Scanl' (cvtF f) (cvtE z) (cvtA a)+      Scanl1 f a                -> Scanl1 (cvtF f) (cvtA a)+      Scanr f z a               -> Scanr (cvtF f) (cvtE z) (cvtA a)+      Scanr' f z a              -> Scanr' (cvtF f) (cvtE z) (cvtA a)+      Scanr1 f a                -> Scanr1 (cvtF f) (cvtA a)+      Permute f1 a1 f2 a2       -> Permute (cvtF f1) (cvtA a1) (cvtF f2) (cvtA a2)+      Backpermute sh f a        -> Backpermute (cvtE sh) (cvtF f) (cvtA a)+      Stencil f b a             -> Stencil (cvtF f) b (cvtA a)+      Stencil2 f b1 a1 b2 a2    -> Stencil2 (cvtF f) b1 (cvtA a1) b2 (cvtA a2)+      -- Collect s                 -> Collect (convertSegmentsSeq s)++      -- Things we are interested in, whoo!+      FoldSeg f z a s           -> Alet (segments s) (OpenAcc (FoldSeg (cvtF f') (cvtE z') (cvtA a') a0))+        where f' = weaken SuccIdx f+              z' = weaken SuccIdx z+              a' = weaken SuccIdx a++      Fold1Seg f a s            -> Alet (segments s) (OpenAcc (Fold1Seg (cvtF f') (cvtA a') a0))+        where f' = weaken SuccIdx f+              a' = weaken SuccIdx a+++convertSegmentsAfun :: OpenAfun aenv t -> OpenAfun aenv t+convertSegmentsAfun afun =+  case afun of+    Abody b     -> Abody (convertSegments b)+    Alam f      -> Alam  (convertSegmentsAfun f)++{--+convertSegmentsSeq :: PreOpenSeq OpenAcc aenv senv a -> PreOpenSeq OpenAcc aenv senv a+convertSegmentsSeq seq =+  case seq of+    Producer p s -> Producer (cvtP p) (convertSegmentsSeq s)+    Consumer c   -> Consumer (cvtC c)+    Reify ix     -> Reify ix+  where+    cvtP :: Producer OpenAcc aenv senv a -> Producer OpenAcc aenv senv a+    cvtP p =+      case p of+        StreamIn arrs        -> StreamIn arrs+        ToSeq sl slix a      -> ToSeq sl slix (cvtA a)+        MapSeq f x           -> MapSeq (cvtAfun f) x+        ChunkedMapSeq f x    -> ChunkedMapSeq (cvtAfun f) x+        ZipWithSeq f x y     -> ZipWithSeq (cvtAfun f) x y+        ScanSeq f e x        -> ScanSeq (cvtF f) (cvtE e) x++    cvtC :: Consumer OpenAcc aenv senv a -> Consumer OpenAcc aenv senv a+    cvtC c =+      case c of+        FoldSeq f e x        -> FoldSeq (cvtF f) (cvtE e) x+        FoldSeqFlatten f a x -> FoldSeqFlatten (cvtAfun f) (cvtA a) x+        Stuple t             -> Stuple (cvtCT t)++    cvtCT :: Atuple (Consumer OpenAcc senv aenv) t -> Atuple (Consumer OpenAcc senv aenv) t+    cvtCT NilAtup        = NilAtup+    cvtCT (SnocAtup t c) = SnocAtup (cvtCT t) (cvtC c)++    cvtE :: Exp aenv t -> Exp aenv t+    cvtE = id++    cvtF :: Fun aenv t -> Fun aenv t+    cvtF = id++    cvtA :: OpenAcc aenv t -> OpenAcc aenv t+    cvtA = convertSegments++    cvtAfun :: OpenAfun aenv t -> OpenAfun aenv t+    cvtAfun = convertSegmentsAfun+--}+
+ src/Data/Array/Accelerate/Trafo/Sharing.hs view
@@ -0,0 +1,2969 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE PatternGuards        #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# OPTIONS_GHC -fno-warn-orphans        #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Trafo.Sharing+-- Copyright   : [2008..2017] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2017] Trevor L. McDonell+--               [2013..2017] Robert Clifton-Everest+-- License     : BSD3+--+-- Maintainer  : Manuel M T Chakravarty <chak@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module implements HOAS to de Bruijn conversion of array expressions+-- while incorporating sharing information.+--++module Data.Array.Accelerate.Trafo.Sharing (++  -- * HOAS -> de Bruijn conversion+  convertAcc, convertAfun, Afunction, AfunctionR,+  convertExp, convertFun,  Function,  FunctionR,+  -- convertSeq++) where++-- standard library+import Control.Applicative                              hiding ( Const )+import Control.Monad.Fix+import Data.List+import Data.Maybe+import Data.Hashable+import Data.Typeable+import System.Mem.StableName+import System.IO.Unsafe                                 ( unsafePerformIO )+import Text.Printf+import qualified Data.HashTable.IO                      as Hash+import qualified Data.IntMap                            as IntMap+import qualified Data.HashMap.Strict                    as Map+import qualified Data.HashSet                           as Set+import Prelude++-- friends+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Smart+import Data.Array.Accelerate.Array.Sugar                as Sugar hiding ( (!!) )+import Data.Array.Accelerate.AST                        hiding ( PreOpenAcc(..), OpenAcc(..), Acc+                                                               , PreOpenExp(..), OpenExp, PreExp, Exp+                                                               , PreBoundary(..), Boundary, Stencil(..)+                                                               , showPreAccOp, showPreExpOp )+import qualified Data.Array.Accelerate.AST              as AST+import qualified Data.Array.Accelerate.Debug            as Debug+++-- Configuration+-- -------------++-- Perhaps the configuration should be passed as a reader monad or some such,+-- but that's a little inconvenient.+--+data Config = Config+  {+    recoverAccSharing   :: Bool         -- ^ Recover sharing of array computations ?+  , recoverExpSharing   :: Bool         -- ^ Recover sharing of scalar expressions ?+  , recoverSeqSharing   :: Bool         -- ^ Recover sharing of sequence computations ?+  , floatOutAcc         :: Bool         -- ^ Always float array computations out of expressions ?+  }++-- Layouts+-- -------++-- A layout of an environment has an entry for each entry of the environment.+-- Each entry in the layout holds the de Bruijn index that refers to the+-- corresponding entry in the environment.+--+data Layout env env' where+  EmptyLayout :: Layout env ()+  PushLayout  :: Typeable t+              => Layout env env' -> Idx env t -> Layout env (env', t)++-- Project the nth index out of an environment layout.+--+-- The first argument provides context information for error messages in the+-- case of failure.+--+prjIdx :: Typeable t+       => String+       -> Int+       -> Layout env env'+       -> Idx env t+prjIdx context = go+  where+    go :: forall env env' t. Typeable t => Int -> Layout env env' -> Idx env t+    go _ EmptyLayout                        = no "environment does not contain index"+    go 0 (PushLayout _ (ix :: Idx env0 s))+      | Just ix' <- gcast ix                = ix'+      | otherwise                           = no $ printf "couldn't match expected type `%s' with actual type `%s'"+                                                          (show (typeOf (undefined::t)))+                                                          (show (typeOf (undefined::s)))+    go n (PushLayout l _)                   = go (n-1) l++    no :: String -> a+    no reason = $internalError "prjIdx" (printf "%s\nin the context: %s" reason context)+++-- Add an entry to a layout, incrementing all indices+--+incLayout :: Layout env env' -> Layout (env, t) env'+incLayout EmptyLayout         = EmptyLayout+incLayout (PushLayout lyt ix) = PushLayout (incLayout lyt) (SuccIdx ix)++sizeLayout :: Layout env env' -> Int+sizeLayout EmptyLayout        = 0+sizeLayout (PushLayout lyt _) = 1 + sizeLayout lyt+++-- Conversion from HOAS to de Bruijn computation AST+-- =================================================++-- Array computations+-- ------------------++-- | Convert a closed array expression to de Bruijn form while also incorporating sharing+-- information.+--+convertAcc+    :: Arrays arrs+    => Bool             -- ^ recover sharing of array computations ?+    -> Bool             -- ^ recover sharing of scalar expressions ?+    -> Bool             -- ^ recover sharing of sequence computations ?+    -> Bool             -- ^ always float array computations out of expressions?+    -> Acc arrs+    -> AST.Acc arrs+convertAcc shareAcc shareExp shareSeq floatAcc acc+  = let config  = Config shareAcc shareExp shareSeq (shareAcc && floatAcc)+    in+    convertOpenAcc config 0 [] EmptyLayout acc+++-- | Convert a closed function over array computations, while incorporating+-- sharing information.+--+convertAfun :: Afunction f => Bool -> Bool -> Bool -> Bool -> f -> AST.Afun (AfunctionR f)+convertAfun shareAcc shareExp shareSeq floatAcc =+  let config = Config shareAcc shareExp shareSeq (shareAcc && floatAcc)+  in  aconvert config EmptyLayout+++-- Convert a HOAS fragment into de Bruijn form, binding variables into the typed+-- environment layout one binder at a time.+--+-- NOTE: Because we convert one binder at a time left-to-right, the bound+--       variables ('vars') will have de Bruijn index _zero_ as the outermost+--       binding, and thus go to the end of the list.+--+class Afunction f where+  type AfunctionR f+  aconvert :: Config -> Layout aenv aenv -> f -> AST.OpenAfun aenv (AfunctionR f)++instance (Arrays a, Afunction r) => Afunction (Acc a -> r) where+  type AfunctionR (Acc a -> r) = a -> AfunctionR r+  --+  aconvert config alyt f+    = let a     = Acc $ Atag (sizeLayout alyt)+          alyt' = incLayout alyt `PushLayout` ZeroIdx+      in+      Alam $ aconvert config alyt' (f a)++instance Arrays b => Afunction (Acc b) where+  type AfunctionR (Acc b) = b+  --+  aconvert config alyt body+    = let lvl    = sizeLayout alyt+          vars   = [lvl-1, lvl-2 .. 0]+      in+      Abody $ convertOpenAcc config lvl vars alyt body+++-- | Convert an open array expression to de Bruijn form while also incorporating sharing+-- information.+--+convertOpenAcc+    :: Arrays arrs+    => Config+    -> Level+    -> [Level]+    -> Layout aenv aenv+    -> Acc arrs+    -> AST.OpenAcc aenv arrs+convertOpenAcc config lvl fvs alyt acc+  = let (sharingAcc, initialEnv) = recoverSharingAcc config lvl fvs acc+    in+    convertSharingAcc config alyt initialEnv sharingAcc++-- | Convert an array expression with given array environment layout and sharing information into+-- de Bruijn form while recovering sharing at the same time (by introducing appropriate let+-- bindings).  The latter implements the third phase of sharing recovery.+--+-- The sharing environment 'env' keeps track of all currently bound sharing variables, keeping them+-- in reverse chronological order (outermost variable is at the end of the list).+--+convertSharingAcc+    :: forall aenv arrs. Arrays arrs+    => Config+    -> Layout aenv aenv+    -> [StableSharingAcc]+    -> ScopedAcc arrs+    -> AST.OpenAcc aenv arrs+convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa))+  | Just i <- findIndex (matchStableAcc sa) aenv'+  = AST.OpenAcc $ AST.Avar (prjIdx (ctxt ++ "; i = " ++ show i) i alyt)+  | null aenv'+  = error $ "Cyclic definition of a value of type 'Acc' (sa = " +++            show (hashStableNameHeight sa) ++ ")"+  | otherwise+  = $internalError "convertSharingAcc" err+  where+    aenv' = lams ++ aenv+    ctxt = "shared 'Acc' tree with stable name " ++ show (hashStableNameHeight sa)+    err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  aenv = " ++ show aenv'++convertSharingAcc config alyt aenv (ScopedAcc lams (AletSharing sa@(StableSharingAcc _ boundAcc) bodyAcc))+  = AST.OpenAcc+  $ let alyt' = incLayout alyt `PushLayout` ZeroIdx+        aenv' = lams ++ aenv+    in+    AST.Alet (convertSharingAcc config alyt aenv' (ScopedAcc [] boundAcc))+             (convertSharingAcc config alyt' (sa:aenv') bodyAcc)++convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc))+  = AST.OpenAcc+  $ let aenv' = lams ++ aenv++        cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a+        cvtA = convertSharingAcc config alyt aenv'++        cvtE :: Elt t => ScopedExp t -> AST.Exp aenv t+        cvtE = convertSharingExp config EmptyLayout alyt [] aenv'++        cvtF1 :: (Elt a, Elt b) => (Exp a -> ScopedExp b) -> AST.Fun aenv (a -> b)+        cvtF1 = convertSharingFun1 config alyt aenv'++        cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c)+        cvtF2 = convertSharingFun2 config alyt aenv'++        cvtAfun1 :: (Arrays a, Arrays b) => (Acc a -> ScopedAcc b) -> AST.OpenAfun aenv (a -> b)+        cvtAfun1 = convertSharingAfun1 config alyt aenv'+    in+    case preAcc of++      Atag i+        -> AST.Avar (prjIdx ("de Bruijn conversion tag " ++ show i) i alyt)++      Pipe afun1 afun2 acc+        -> let noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ())+               alyt'    = incLayout alyt `PushLayout` ZeroIdx+               boundAcc = cvtAfun1 afun1 `AST.Apply` cvtA acc+               bodyAcc  = convertSharingAfun1 config alyt' (noStableSharing : aenv') afun2+                          `AST.Apply`+                          AST.OpenAcc (AST.Avar AST.ZeroIdx)+           in+           AST.Alet (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc)++      Aforeign ff afun acc+        -> let a = recoverAccSharing config+               e = recoverExpSharing config+               s = recoverSeqSharing config+               f = floatOutAcc config+           in+           AST.Aforeign ff (convertAfun a e s f afun) (cvtA acc)++      Acond b acc1 acc2           -> AST.Acond (cvtE b) (cvtA acc1) (cvtA acc2)+      Awhile pred iter init       -> AST.Awhile (cvtAfun1 pred) (cvtAfun1 iter) (cvtA init)+      Atuple arrs                 -> AST.Atuple (convertSharingAtuple config alyt aenv' arrs)+      Aprj ix a                   -> AST.Aprj ix (cvtA a)+      Use array                   -> AST.Use (fromArr array)+      Unit e                      -> AST.Unit (cvtE e)+      Generate sh f               -> AST.Generate (cvtE sh) (cvtF1 f)+      Reshape e acc               -> AST.Reshape (cvtE e) (cvtA acc)+      Replicate ix acc            -> mkReplicate (cvtE ix) (cvtA acc)+      Slice acc ix                -> mkIndex (cvtA acc) (cvtE ix)+      Map f acc                   -> AST.Map (cvtF1 f) (cvtA acc)+      ZipWith f acc1 acc2         -> AST.ZipWith (cvtF2 f) (cvtA acc1) (cvtA acc2)+      Fold f e acc                -> AST.Fold (cvtF2 f) (cvtE e) (cvtA acc)+      Fold1 f acc                 -> AST.Fold1 (cvtF2 f) (cvtA acc)+      FoldSeg f e acc1 acc2       -> AST.FoldSeg (cvtF2 f) (cvtE e) (cvtA acc1) (cvtA acc2)+      Fold1Seg f acc1 acc2        -> AST.Fold1Seg (cvtF2 f) (cvtA acc1) (cvtA acc2)+      Scanl f e acc               -> AST.Scanl (cvtF2 f) (cvtE e) (cvtA acc)+      Scanl' f e acc              -> AST.Scanl' (cvtF2 f) (cvtE e) (cvtA acc)+      Scanl1 f acc                -> AST.Scanl1 (cvtF2 f) (cvtA acc)+      Scanr f e acc               -> AST.Scanr (cvtF2 f) (cvtE e) (cvtA acc)+      Scanr' f e acc              -> AST.Scanr' (cvtF2 f) (cvtE e) (cvtA acc)+      Scanr1 f acc                -> AST.Scanr1 (cvtF2 f) (cvtA acc)+      Permute f dftAcc perm acc   -> AST.Permute (cvtF2 f) (cvtA dftAcc) (cvtF1 perm) (cvtA acc)+      Backpermute newDim perm acc -> AST.Backpermute (cvtE newDim) (cvtF1 perm) (cvtA acc)+      Stencil stencil boundary acc+        -> AST.Stencil (convertSharingStencilFun1 config acc alyt aenv' stencil)+                       (convertSharingBoundary config alyt aenv' boundary)+                       (cvtA acc)+      Stencil2 stencil bndy1 acc1 bndy2 acc2+        -> AST.Stencil2 (convertSharingStencilFun2 config acc1 acc2 alyt aenv' stencil)+                        (convertSharingBoundary config alyt aenv' bndy1)+                        (cvtA acc1)+                        (convertSharingBoundary config alyt aenv' bndy2)+                        (cvtA acc2)+      -- Collect seq -> AST.Collect (convertSharingSeq config alyt EmptyLayout aenv' [] seq)+++{--+-- Sequence expressions+-- ------------------++-- | Convert a closed sequence expression to de Bruijn form while incorporating+-- sharing information.+--+convertSeq+    :: Typeable s+    => Bool             -- ^ recover sharing of array computations ?+    -> Bool             -- ^ recover sharing of scalar expressions ?+    -> Bool             -- ^ recover sharing of sequence computations ?+    -> Bool             -- ^ always float array computations out of expressions?+    -> Seq s            -- ^ computation to be converted+    -> AST.Seq s+convertSeq shareAcc shareExp shareSeq floatAcc seq+  = let config = Config shareAcc shareExp shareSeq floatAcc+        (sharingSeq, initialEnv) = recoverSharingSeq config seq+    in+    convertSharingSeq config EmptyLayout EmptyLayout [] initialEnv sharingSeq++convertSharingSeq+    :: forall aenv senv arrs.+       Config+    -> Layout aenv aenv+    -> Layout senv senv+    -> [StableSharingAcc]+    -> [StableSharingSeq]+    -> ScopedSeq arrs+    -> AST.PreOpenSeq AST.OpenAcc aenv senv arrs+convertSharingSeq _ _ slyt _ senv (ScopedSeq (SvarSharing sn))+  | Just i <- findIndex (matchStableSeq sn) senv+  = AST.Reify $ prjIdx (ctxt ++ "; i = " ++ show i) i slyt+  | null senv+  = error $ "Cyclic definition of a value of type 'Seq' (sa = " +++            show (hashStableNameHeight sn) ++ ")"+  | otherwise+  = $internalError "convertSharingSeq" err+  where+    ctxt = "shared 'Seq' tree with stable name " ++ show (hashStableNameHeight sn)+    err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  senv = " ++ show senv+convertSharingSeq config alyt slyt aenv senv (ScopedSeq (SletSharing sa@(StableSharingSeq _ (SeqSharing _ boundSeq)) bodySeq))+  = convSeq boundSeq bodySeq+  where+    convSeq :: forall bnd body.+               PreSeq ScopedAcc ScopedSeq ScopedExp bnd+            -> ScopedSeq body+            -> AST.PreOpenSeq AST.OpenAcc aenv senv body+    convSeq bnd body =+      case bnd of+        StreamIn arrs               -> producer $ AST.StreamIn arrs+        ToSeq slix acc              -> producer $ mkToSeq slix (cvtA acc)+        MapSeq afun x               -> producer $ AST.MapSeq (cvtAF1 afun) (asIdx x)+        ZipWithSeq afun x y         -> producer $ AST.ZipWithSeq (cvtAF2 afun) (asIdx x) (asIdx y)+        ScanSeq fun e x             -> producer $ AST.ScanSeq (cvtF2 fun) (cvtE e) (asIdx x)+        _                           -> $internalError "convertSharingSeq:convSeq" "Consumer appears to have been let bound"+      where+        producer :: Arrays a+                 => AST.Producer AST.OpenAcc aenv senv a+                 -> AST.PreOpenSeq AST.OpenAcc aenv senv body+        producer p = AST.Producer p $ convertSharingSeq config alyt slyt' aenv (sa:senv) body+          where+            slyt' = incLayout slyt `PushLayout` ZeroIdx++        asIdx :: Arrays a+              => ScopedSeq [a]+              -> Idx senv a+        asIdx (ScopedSeq (SvarSharing sn))+          | Just i <- findIndex (matchStableSeq sn) senv+          = prjIdx (ctxt ++ "; i = " ++ show i) i slyt+          | null senv+          = error $ "Cyclic definition of a value of type 'Seq' (sa = " +++                    show (hashStableNameHeight sn) ++ ")"+          | otherwise+          = $internalError "convertSharingSeq" err+          where+            ctxt = "shared 'Seq' tree with stable name " ++ show (hashStableNameHeight sn)+            err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  senv = " ++ show senv+        asIdx _+          = $internalError "convertSharingSeq:asIdx" "Sequence computation not in A-normal form"++        cvtA :: forall a. Arrays a => ScopedAcc a -> AST.OpenAcc aenv a+        cvtA acc = convertSharingAcc config alyt aenv acc++        cvtE :: forall t. Elt t => ScopedExp t -> AST.Exp aenv t+        cvtE = convertSharingExp config EmptyLayout alyt [] aenv++        cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c)+        cvtF2 = convertSharingFun2 config alyt aenv++        cvtAF1 :: forall a b. (Arrays a, Arrays b) => (Acc a -> ScopedAcc b) -> OpenAfun aenv (a -> b)+        cvtAF1 afun = convertSharingAfun1 config alyt aenv afun++        cvtAF2 :: forall a b c. (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b -> ScopedAcc c) -> OpenAfun aenv (a -> b -> c)+        cvtAF2 afun = convertSharingAfun2 config alyt aenv afun++convertSharingSeq _ _ _ _ _ (ScopedSeq (SletSharing _ _))+ = $internalError "convertSharingSeq" "Sequence computation not in A-normal form"++convertSharingSeq config alyt slyt aenv senv s+  = cvtC s+  where+    cvtC :: ScopedSeq a -> AST.PreOpenSeq AST.OpenAcc aenv senv a+    cvtC (ScopedSeq (SeqSharing _ s)) =+      case s of+        FoldSeq fun e x                    -> AST.Consumer $ AST.FoldSeq (cvtF2 fun) (cvtE e) (asIdx x)+        FoldSeqFlatten afun acc x          -> AST.Consumer $ AST.FoldSeqFlatten (cvtAF3 afun) (cvtA acc) (asIdx x)+        Stuple t                           -> AST.Consumer $ AST.Stuple (cvtST t)+        _                                  -> $internalError "convertSharingSeq" "Producer has not been let bound"+    cvtC _ = $internalError "convertSharingSeq" "Unreachable"++    asIdx :: Arrays a+          => ScopedSeq [a]+          -> Idx senv a+    asIdx (ScopedSeq (SvarSharing sn))+      | Just i <- findIndex (matchStableSeq sn) senv+      = prjIdx (ctxt ++ "; i = " ++ show i) i slyt+      | null senv+      = error $ "Cyclic definition of a value of type 'Seq' (sa = " +++                show (hashStableNameHeight sn) ++ ")"+      | otherwise+      = $internalError "convertSharingSeq" err+      where+        ctxt = "shared 'Seq' tree with stable name " ++ show (hashStableNameHeight sn)+        err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  senv = " ++ show senv+    asIdx _+      = $internalError "convertSharingSeq:asIdx" "Sequence computation not in A-normal form"++    cvtA :: forall a. Arrays a => ScopedAcc a -> AST.OpenAcc aenv a+    cvtA acc = convertSharingAcc config alyt aenv acc++    cvtE :: forall t. Elt t => ScopedExp t -> AST.Exp aenv t+    cvtE = convertSharingExp config EmptyLayout alyt [] aenv++    cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c)+    cvtF2 = convertSharingFun2 config alyt aenv++    cvtAF3 :: forall a b c d. (Arrays a, Arrays b, Arrays c, Arrays d) => (Acc a -> Acc b -> Acc c -> ScopedAcc d) -> OpenAfun aenv (a -> b -> c -> d)+    cvtAF3 afun = convertSharingAfun3 config alyt aenv afun++    cvtST :: Atuple ScopedSeq t -> Atuple (AST.Consumer AST.OpenAcc aenv senv) t+    cvtST NilAtup        = NilAtup+    cvtST (SnocAtup t c) | AST.Consumer c' <- cvtC c+                         = SnocAtup (cvtST t) c'+                         | otherwise+                         = $internalError "convertSharingSeq" "Unreachable"+--}++convertSharingAfun1+    :: forall aenv a b. (Arrays a, Arrays b)+    => Config+    -> Layout aenv aenv+    -> [StableSharingAcc]+    -> (Acc a -> ScopedAcc b)+    -> OpenAfun aenv (a -> b)+convertSharingAfun1 config alyt aenv f+  = Alam (Abody (convertSharingAcc config alyt' aenv body))+      where+        alyt' = incLayout alyt `PushLayout` ZeroIdx+        body  = f undefined++{--+convertSharingAfun2+    :: forall aenv a b c. (Arrays a, Arrays b, Arrays c)+    => Config+    -> Layout aenv aenv+    -> [StableSharingAcc]+    -> (Acc a -> Acc b -> ScopedAcc c)+    -> OpenAfun aenv (a -> b -> c)+convertSharingAfun2 config alyt aenv f+  = Alam (Alam (Abody (convertSharingAcc config alyt' aenv body)))+      where+        alyt' = incLayout (incLayout alyt `PushLayout` ZeroIdx) `PushLayout` ZeroIdx+        body  = f undefined undefined++convertSharingAfun3+    :: forall aenv a b c d. (Arrays a, Arrays b, Arrays c, Arrays d)+    => Config+    -> Layout aenv aenv+    -> [StableSharingAcc]+    -> (Acc a -> Acc b -> Acc c -> ScopedAcc d)+    -> OpenAfun aenv (a -> b -> c -> d)+convertSharingAfun3 config alyt aenv f+  = Alam (Alam (Alam (Abody (convertSharingAcc config alyt' aenv body))))+      where+        alyt' = incLayout (incLayout (incLayout alyt `PushLayout` ZeroIdx) `PushLayout` ZeroIdx) `PushLayout` ZeroIdx+        body  = f undefined undefined undefined+--}++convertSharingAtuple+    :: forall aenv a.+       Config+    -> Layout aenv aenv+    -> [StableSharingAcc]+    -> Atuple ScopedAcc a+    -> Atuple (AST.OpenAcc aenv) a+convertSharingAtuple config alyt aenv = cvt+  where+    cvt :: Atuple ScopedAcc a' -> Atuple (AST.OpenAcc aenv) a'+    cvt NilAtup         = NilAtup+    cvt (SnocAtup t a)  = cvt t `SnocAtup` convertSharingAcc config alyt aenv a+++-- | Convert a boundary condition+--+convertSharingBoundary+    :: forall aenv t.+       Config+    -> Layout aenv aenv+    -> [StableSharingAcc]+    -> PreBoundary ScopedAcc ScopedExp t+    -> AST.PreBoundary AST.OpenAcc aenv t+convertSharingBoundary config alyt aenv = cvt+  where+    cvt :: PreBoundary ScopedAcc ScopedExp t -> AST.Boundary aenv t+    cvt bndy =+      case bndy of+        Clamp       -> AST.Clamp+        Mirror      -> AST.Mirror+        Wrap        -> AST.Wrap+        Constant v  -> AST.Constant $ fromElt v+        Function f  -> AST.Function $ convertSharingFun1 config alyt aenv f+++-- Smart constructors to represent AST forms+--+mkIndex :: forall slix e aenv. (Slice slix, Elt e)+        => AST.OpenAcc                aenv (Array (FullShape  slix) e)+        -> AST.Exp                    aenv slix+        -> AST.PreOpenAcc AST.OpenAcc aenv (Array (SliceShape slix) e)+mkIndex = AST.Slice (sliceIndex slix)+  where+    slix = undefined :: slix++mkReplicate :: forall slix e aenv. (Slice slix, Elt e)+        => AST.Exp                    aenv slix+        -> AST.OpenAcc                aenv (Array (SliceShape slix) e)+        -> AST.PreOpenAcc AST.OpenAcc aenv (Array (FullShape  slix) e)+mkReplicate = AST.Replicate (sliceIndex slix)+  where+    slix = undefined :: slix++-- mkToSeq :: forall slsix slix e aenv senv. (Division slsix, DivisionSlice slsix ~ slix, Elt e, Elt slix, Slice slix)+--         => slsix+--         -> AST.OpenAcc              aenv (Array (FullShape  slix) e)+--         -> AST.Producer AST.OpenAcc aenv senv (Array (SliceShape slix) e)+-- mkToSeq _ = AST.ToSeq (sliceIndex slix) (Proxy :: Proxy slix)+--   where+--     slix = undefined :: slix+++-- Scalar functions+-- ----------------++-- | Convert a closed scalar function to de Bruijn form while incorporating+-- sharing information.+--+-- The current design requires all free variables to be bound at the outermost+-- level --- we have no general apply term, and so lambdas are always outermost.+-- In higher-order abstract syntax, this represents an n-ary, polyvariadic+-- function.+--+convertFun :: Function f => Bool -> f -> AST.Fun () (FunctionR f)+convertFun shareExp =+  let config = Config False shareExp False False+  in  convert config EmptyLayout+++class Function f where+  type FunctionR f+  convert :: Config -> Layout env env -> f -> AST.OpenFun env () (FunctionR f)++instance (Elt a, Function r) => Function (Exp a -> r) where+  type FunctionR (Exp a -> r) = a -> FunctionR r+  --+  convert config lyt f+    = let x     = Exp $ Tag (sizeLayout lyt)+          lyt'  = incLayout lyt `PushLayout` ZeroIdx+      in+      Lam $ convert config lyt' (f x)++instance Elt b => Function (Exp b) where+  type FunctionR (Exp b) = b+  --+  convert config lyt body+    = let lvl    = sizeLayout lyt+          vars   = [lvl-1, lvl-2 .. 0]+      in+      Body $ convertOpenExp config lvl vars lyt body+++-- Scalar expressions+-- ------------------++-- | Convert a closed scalar expression to de Bruijn form while incorporating+-- sharing information.+--+convertExp+    :: Elt e+    => Bool             -- ^ recover sharing of scalar expressions ?+    -> Exp e            -- ^ expression to be converted+    -> AST.Exp () e+convertExp shareExp exp+  = let config = Config False shareExp False False+    in+    convertOpenExp config 0 [] EmptyLayout exp++convertOpenExp+    :: Elt e+    => Config+    -> Level            -- level of currently bound scalar variables+    -> [Level]          -- tags of bound scalar variables+    -> Layout env env+    -> Exp e+    -> AST.OpenExp env () e+convertOpenExp config lvl fvar lyt exp+  = let (sharingExp, initialEnv) = recoverSharingExp config lvl fvar exp+    in+    convertSharingExp config lyt EmptyLayout initialEnv [] sharingExp+++-- | Convert an open expression with given environment layouts and sharing information into+-- de Bruijn form while recovering sharing at the same time (by introducing appropriate let+-- bindings).  The latter implements the third phase of sharing recovery.+--+-- The sharing environments 'env' and 'aenv' keep track of all currently bound sharing variables,+-- keeping them in reverse chronological order (outermost variable is at the end of the list).+--+convertSharingExp+    :: forall t env aenv. Elt t+    => Config+    -> Layout env  env          -- scalar environment+    -> Layout aenv aenv         -- array environment+    -> [StableSharingExp]       -- currently bound sharing variables of expressions+    -> [StableSharingAcc]       -- currently bound sharing variables of array computations+    -> ScopedExp t              -- expression to be converted+    -> AST.OpenExp env aenv t+convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp+  where+    -- scalar environment with any lambda bound variables this expression is rooted in+    env' = lams ++ env++    cvt :: Elt t' => ScopedExp t' -> AST.OpenExp env aenv t'+    cvt (ScopedExp _ (VarSharing se))+      | Just i <- findIndex (matchStableExp se) env' = AST.Var (prjIdx (ctx i) i lyt)+      | otherwise                                    = $internalError "convertSharingExp" msg+      where+        ctx i = printf "shared 'Exp' tree with stable name %d; i=%d" (hashStableNameHeight se) i+        msg   = unlines+          [ if null env'+               then printf "cyclic definition of a value of type 'Exp' (sa=%d)" (hashStableNameHeight se)+               else printf "inconsistent valuation at shared 'Exp' tree (sa=%d; env=%s)" (hashStableNameHeight se) (show env')+          , ""+          , "Note that this error usually arises due to the presence of nested data"+          , "parallelism; when a parallel computation attempts to initiate new parallel"+          , "work _which depends on_ a scalar variable given by the first computation."+          , ""+          , "For example, suppose we wish to sum the columns of a two-dimensional array."+          , "You might think to do this in the following (incorrect) way: by constructing"+          , "a vector using 'generate' where at each index we 'slice' out the"+          , "corresponding column of the matrix and 'sum' it:"+          , ""+          , "> sum_columns_ndp :: Num a => Acc (Matrix a) -> Acc (Vector a)"+          , "> sum_columns_ndp mat ="+          , ">   let Z :. rows :. cols = unlift (shape mat) :: Z :. Exp Int :. Exp Int"+          , ">   in  generate (index1 cols)"+          , ">                (\\col -> the $ sum (slice mat (lift (Z :. All :. unindex1 col))))"+          , ""+          , "However, since both 'generate' and 'slice' are data-parallel operators, and"+          , "moreover that 'slice' _depends on_ the argument 'col' given to it by the"+          , "'generate' function, this operation requires nested parallelism and is thus"+          , "not (at this time) permitted. The clue that this definition is invalid is"+          , "that in order to create a program which will be accepted by the type checker,"+          , "we had to use the function 'the' to retrieve the result of the parallel"+          , "'sum', effectively concealing that this is a collective operation in order to"+          , "match the type expected by 'generate'."+          , ""+          , "To solve this particular example, we can make use of the fact that (most)"+          , "collective operations in Accelerate are _rank polymorphic_. The 'sum'"+          , "operation reduces along the innermost dimension of an array of arbitrary"+          , "rank, reducing the dimensionality of the array by one. To reduce the array"+          , "column-wise then, we first need to simply 'transpose' the array:"+          , ""+          , "> sum_columns :: Num a => Acc (Matrix a) -> Acc (Vector a)"+          , "> sum_columns = sum . transpose"+          , ""+          , "If you feel like this is not the cause of your error, or you would like some"+          , "advice locating the problem and perhaps with a workaround, feel free to"+          , "submit an issue at the above URL."+          ]++    cvt (ScopedExp _ (LetSharing se@(StableSharingExp _ boundExp) bodyExp))+      = let lyt' = incLayout lyt `PushLayout` ZeroIdx+        in+        AST.Let (cvt (ScopedExp [] boundExp)) (convertSharingExp config lyt' alyt (se:env') aenv bodyExp)+    cvt (ScopedExp _ (ExpSharing _ pexp))+      = case pexp of+          Tag i                 -> AST.Var (prjIdx ("de Bruijn conversion tag " ++ show i) i lyt)+          Const v               -> AST.Const (fromElt v)+          Undef                 -> AST.Undef+          Tuple tup             -> AST.Tuple (cvtT tup)+          Prj idx e             -> AST.Prj idx (cvt e)+          IndexNil              -> AST.IndexNil+          IndexCons ix i        -> AST.IndexCons (cvt ix) (cvt i)+          IndexHead i           -> AST.IndexHead (cvt i)+          IndexTail ix          -> AST.IndexTail (cvt ix)+          IndexAny              -> AST.IndexAny+          ToIndex sh ix         -> AST.ToIndex (cvt sh) (cvt ix)+          FromIndex sh e        -> AST.FromIndex (cvt sh) (cvt e)+          Cond e1 e2 e3         -> AST.Cond (cvt e1) (cvt e2) (cvt e3)+          While p it i          -> AST.While (cvtFun1 p) (cvtFun1 it) (cvt i)+          PrimConst c           -> AST.PrimConst c+          PrimApp f e           -> cvtPrimFun f (cvt e)+          Index a e             -> AST.Index (cvtA a) (cvt e)+          LinearIndex a i       -> AST.LinearIndex (cvtA a) (cvt i)+          Shape a               -> AST.Shape (cvtA a)+          ShapeSize e           -> AST.ShapeSize (cvt e)+          Intersect sh1 sh2     -> AST.Intersect (cvt sh1) (cvt sh2)+          Union sh1 sh2         -> AST.Union (cvt sh1) (cvt sh2)+          Foreign ff f e        -> AST.Foreign ff (convertFun (recoverExpSharing config) f) (cvt e)+          Coerce e              -> AST.Coerce (cvt e)++    cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a+    cvtA = convertSharingAcc config alyt aenv++    cvtT :: Tuple ScopedExp tup -> Tuple (AST.OpenExp env aenv) tup+    cvtT = convertSharingTuple config lyt alyt env' aenv++    cvtFun1 :: (Elt a, Elt b) => (Exp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b)+    cvtFun1 f = Lam (Body (convertSharingExp config lyt' alyt env' aenv body))+      where+        lyt' = incLayout lyt `PushLayout` ZeroIdx+        body = f undefined++    -- Push primitive function applications down through let bindings so that+    -- they are adjacent to their arguments. It looks a bit nicer this way.+    --+    cvtPrimFun :: (Elt a, Elt r)+               => AST.PrimFun (a -> r) -> AST.OpenExp env' aenv' a -> AST.OpenExp env' aenv' r+    cvtPrimFun f e = case e of+      AST.Let bnd body    -> AST.Let bnd (cvtPrimFun f body)+      x                   -> AST.PrimApp f x++-- | Convert a tuple expression+--+convertSharingTuple+    :: Config+    -> Layout env env+    -> Layout aenv aenv+    -> [StableSharingExp]                 -- currently bound scalar sharing-variables+    -> [StableSharingAcc]                 -- currently bound array sharing-variables+    -> Tuple ScopedExp t+    -> Tuple (AST.OpenExp env aenv) t+convertSharingTuple config lyt alyt env aenv tup =+  case tup of+    NilTup      -> NilTup+    SnocTup t e -> convertSharingTuple config lyt alyt env aenv t+         `SnocTup` convertSharingExp   config lyt alyt env aenv e++-- | Convert a unary functions+--+convertSharingFun1+    :: forall a b aenv. (Elt a, Elt b)+    => Config+    -> Layout aenv aenv+    -> [StableSharingAcc]       -- currently bound array sharing-variables+    -> (Exp a -> ScopedExp b)+    -> AST.Fun aenv (a -> b)+convertSharingFun1 config alyt aenv f = Lam (Body openF)+  where+    a               = Exp undefined             -- the 'tag' was already embedded in Phase 1+    lyt             = EmptyLayout+                      `PushLayout`+                      (ZeroIdx :: Idx ((), a) a)+    openF           = convertSharingExp config lyt alyt [] aenv (f a)++-- | Convert a binary functions+--+convertSharingFun2+    :: forall a b c aenv. (Elt a, Elt b, Elt c)+    => Config+    -> Layout aenv aenv+    -> [StableSharingAcc]       -- currently bound array sharing-variables+    -> (Exp a -> Exp b -> ScopedExp c)+    -> AST.Fun aenv (a -> b -> c)+convertSharingFun2 config alyt aenv f = Lam (Lam (Body openF))+  where+    a               = Exp undefined+    b               = Exp undefined+    lyt             = EmptyLayout+                      `PushLayout`+                      (SuccIdx ZeroIdx :: Idx (((), a), b) a)+                      `PushLayout`+                      (ZeroIdx         :: Idx (((), a), b) b)+    openF           = convertSharingExp config lyt alyt [] aenv (f a b)++-- | Convert a unary stencil function+--+convertSharingStencilFun1+    :: forall sh a stencil b aenv. (Elt a, Stencil sh a stencil, Elt b)+    => Config+    -> ScopedAcc (Array sh a)          -- just passed to fix the type variables+    -> Layout aenv aenv+    -> [StableSharingAcc]               -- currently bound array sharing-variables+    -> (stencil -> ScopedExp b)+    -> AST.Fun aenv (StencilRepr sh stencil -> b)+convertSharingStencilFun1 config _ alyt aenv stencilFun = Lam (Body openStencilFun)+  where+    stencil = Exp undefined :: Exp (StencilRepr sh stencil)+    lyt     = EmptyLayout+              `PushLayout`+              (ZeroIdx :: Idx ((), StencilRepr sh stencil)+                              (StencilRepr sh stencil))++    body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil)+    openStencilFun  = convertSharingExp config lyt alyt [] aenv body++-- | Convert a binary stencil function+--+convertSharingStencilFun2+    :: forall sh a b stencil1 stencil2 c aenv.+       (Elt a, Stencil sh a stencil1,+        Elt b, Stencil sh b stencil2,+        Elt c)+    => Config+    -> ScopedAcc (Array sh a)          -- just passed to fix the type variables+    -> ScopedAcc (Array sh b)          -- just passed to fix the type variables+    -> Layout aenv aenv+    -> [StableSharingAcc]               -- currently bound array sharing-variables+    -> (stencil1 -> stencil2 -> ScopedExp c)+    -> AST.Fun aenv (StencilRepr sh stencil1 -> StencilRepr sh stencil2 -> c)+convertSharingStencilFun2 config _ _ alyt aenv stencilFun = Lam (Lam (Body openStencilFun))+  where+    stencil1 = Exp undefined :: Exp (StencilRepr sh stencil1)+    stencil2 = Exp undefined :: Exp (StencilRepr sh stencil2)+    lyt     = EmptyLayout+              `PushLayout`+              (SuccIdx ZeroIdx :: Idx (((), StencilRepr sh stencil1),+                                            StencilRepr sh stencil2)+                                       (StencilRepr sh stencil1))+              `PushLayout`+              (ZeroIdx         :: Idx (((), StencilRepr sh stencil1),+                                            StencilRepr sh stencil2)+                                       (StencilRepr sh stencil2))++    body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1)+                      (stencilPrj (undefined::sh) (undefined::b) stencil2)+    openStencilFun  = convertSharingExp config lyt alyt [] aenv body+++-- Sharing recovery+-- ================++-- Sharing recovery proceeds in two phases:+--+-- /Phase One: build the occurrence map/+--+-- This is a top-down traversal of the AST that computes a map from AST nodes to the number of+-- occurrences of that AST node in the overall Accelerate program.  An occurrences count of two or+-- more indicates sharing.+--+-- IMPORTANT: To avoid unfolding the sharing, we do not descent into subtrees that we have+--   previously encountered.  Hence, the complexity is proportional to the number of nodes in the+--   tree /with/ sharing.  Consequently, the occurrence count is that in the tree with sharing+--   as well.+--+-- During computation of the occurrences, the tree is annotated with stable names on every node+-- using 'AccSharing' constructors and all but the first occurrence of shared subtrees are pruned+-- using 'AvarSharing' constructors (see 'SharingAcc' below).  This phase is impure as it is based+-- on stable names.+--+-- We use a hash table (instead of 'Data.Map') as computing stable names forces us to live in IO+-- anyway.  Once, the computation of occurrence counts is complete, we freeze the hash table into+-- a 'Data.Map'.+--+-- (Implemented by 'makeOccMap*'.)+--+-- /Phase Two: determine scopes and inject sharing information/+--+-- This is a bottom-up traversal that determines the scope for every binding to be introduced+-- to share a subterm.  It uses the occurrence map to determine, for every shared subtree, the+-- lowest AST node at which the binding for that shared subtree can be placed (using a+-- 'AletSharing' constructor)— it's the meet of all the shared subtree occurrences.+--+-- The second phase is also replacing the first occurrence of each shared subtree with a+-- 'AvarSharing' node and floats the shared subtree up to its binding point.+--+--  (Implemented by 'determineScopes*'.)+--+-- /Sharing recovery for expressions/+--+-- We recover sharing for each expression (including function bodies) independently of any other+-- expression — i.e., we cannot share scalar expressions across array computations.  Hence, during+-- Phase One, we mark all scalar expression nodes with a stable name and compute one occurrence map+-- for every scalar expression (including functions) that occurs in an array computation.  These+-- occurrence maps are added to the root of scalar expressions using 'RootExp'.+--+-- NB: We do not need to worry sharing recovery will try to float a shared subexpression past a+--     binder that occurs in that subexpression.  Why?  Otherwise, the binder would already occur+--     out of scope in the original source program.+--+-- /Lambda bound variables/+--+-- During sharing recovery, lambda bound variables appear in the form of 'Atag' and 'Tag' data+-- constructors.  The tag values are determined during Phase One of sharing recovery by computing+-- the /level/ of each variable at its binding occurrence.  The level at the root of the AST is 0+-- and increases by one with each lambda on each path through the AST.++-- Stable names+-- ------------++-- Opaque stable name for AST nodes — used to key the occurrence map.+--+data StableASTName c where+  StableASTName :: (Typeable c, Typeable t) => StableName (c t) -> StableASTName c++instance Show (StableASTName c) where+  show (StableASTName sn) = show $ hashStableName sn++instance Eq (StableASTName c) where+  StableASTName sn1 == StableASTName sn2+    | Just sn1' <- gcast sn1 = sn1' == sn2+    | otherwise              = False++instance Hashable (StableASTName c) where+  hashWithSalt s (StableASTName sn) = hashWithSalt s sn++makeStableAST :: c t -> IO (StableName (c t))+makeStableAST e = e `seq` makeStableName e++-- Stable name for an AST node including the height of the AST representing the array computation.+--+data StableNameHeight t = StableNameHeight (StableName t) Int++instance Eq (StableNameHeight t) where+  (StableNameHeight sn1 _) == (StableNameHeight sn2 _) = sn1 == sn2++higherSNH :: StableNameHeight t1 -> StableNameHeight t2 -> Bool+StableNameHeight _ h1 `higherSNH` StableNameHeight _ h2 = h1 > h2++hashStableNameHeight :: StableNameHeight t -> Int+hashStableNameHeight (StableNameHeight sn _) = hashStableName sn++-- Mutable occurrence map+-- ----------------------++-- Hash table keyed on the stable names of array computations.+--+type HashTable key val = Hash.BasicHashTable key val+type ASTHashTable c v  = HashTable (StableASTName c) v++-- Mutable hashtable version of the occurrence map, which associates each AST node with an+-- occurrence count and the height of the AST.+--+type OccMapHash c = ASTHashTable c (Int, Int)++-- Create a new hash table keyed on AST nodes.+--+newASTHashTable :: IO (ASTHashTable c v)+newASTHashTable = Hash.new++-- Enter one AST node occurrence into an occurrence map.  Returns 'Just h' if this is a repeated+-- occurrence and the height of the repeatedly occurring AST is 'h'.+--+-- If this is the first occurrence, the 'height' *argument* must provide the height of the AST;+-- otherwise, the height will be *extracted* from the occurrence map.  In the latter case, this+-- function yields the AST height.+--+enterOcc :: OccMapHash c -> StableASTName c -> Int -> IO (Maybe Int)+enterOcc occMap sa height+  = Hash.mutate occMap sa+  $ \case+      Nothing           -> (Just (1,   height),  Nothing)+      Just (n, heightS) -> (Just (n+1, heightS), Just heightS)+++-- Immutable occurrence map+-- ------------------------++-- Immutable version of the occurrence map (storing the occurrence count only, not the height).  We+-- use the 'StableName' hash to index an 'IntMap' and disambiguate 'StableName's with identical+-- hashes explicitly, storing them in a list in the 'IntMap'.+--+type OccMap c = IntMap.IntMap [(StableASTName c, Int)]++-- Turn a mutable into an immutable occurrence map.+--+freezeOccMap :: OccMapHash c -> IO (OccMap c)+freezeOccMap oc+  = do+      ocl <- Hash.toList oc+      traceChunk "OccMap" (show ocl)++      return . IntMap.fromList+             . map (\kvs -> (key (head kvs), kvs))+             . groupBy sameKey+             . map dropHeight+             $ ocl+  where+    key (StableASTName sn, _) = hashStableName sn+    sameKey kv1 kv2           = key kv1 == key kv2+    dropHeight (k, (cnt, _))  = (k, cnt)++-- Look up the occurrence map keyed by array computations using a stable name.  If the key does+-- not exist in the map, return an occurrence count of '1'.+--+lookupWithASTName :: OccMap c -> StableASTName c -> Int+lookupWithASTName oc sa@(StableASTName sn)+  = fromMaybe 1 $ IntMap.lookup (hashStableName sn) oc >>= Prelude.lookup sa++-- Look up the occurrence map keyed by array computations using a sharing array computation.  If an+-- the key does not exist in the map, return an occurrence count of '1'.+--+lookupWithSharingAcc :: OccMap Acc -> StableSharingAcc -> Int+lookupWithSharingAcc oc (StableSharingAcc (StableNameHeight sn _) _)+  = lookupWithASTName oc (StableASTName sn)++-- Look up the occurrence map keyed by scalar expressions using a sharing expression.  If an+-- the key does not exist in the map, return an occurrence count of '1'.+--+lookupWithSharingExp :: OccMap Exp -> StableSharingExp -> Int+lookupWithSharingExp oc (StableSharingExp (StableNameHeight sn _) _)+  = lookupWithASTName oc (StableASTName sn)+++-- Stable 'Acc' nodes+-- ------------------++-- Stable name for 'Acc' nodes including the height of the AST.+--+type StableAccName arrs = StableNameHeight (Acc arrs)++-- Interleave sharing annotations into an array computation AST.  Subtrees can be marked as being+-- represented by variable (binding a shared subtree) using 'AvarSharing' and as being prefixed by+-- a let binding (for a shared subtree) using 'AletSharing'.+--+data SharingAcc acc exp arrs where+  AvarSharing :: Arrays arrs+              => StableAccName arrs                        -> SharingAcc acc exp arrs+  AletSharing :: StableSharingAcc -> acc arrs              -> SharingAcc acc exp arrs+  AccSharing  :: Arrays arrs+              => StableAccName arrs -> PreAcc acc exp arrs -> SharingAcc acc exp arrs++-- Array expression with sharing but shared values have not been scoped; i.e. no let bindings. If+-- the expression is rooted in a function, the list contains the tags of the variables bound by the+-- immediate surrounding lambdas.+data UnscopedAcc t = UnscopedAcc [Int] (SharingAcc UnscopedAcc RootExp t)++-- Array expression with sharing. For expressions rooted in functions the list holds a sorted+-- environment corresponding to the variables bound in the immediate surounding lambdas.+data ScopedAcc t = ScopedAcc [StableSharingAcc] (SharingAcc ScopedAcc ScopedExp t)++-- Stable name for an array computation associated with its sharing-annotated version.+--+data StableSharingAcc where+  StableSharingAcc :: Arrays arrs+                   => StableAccName arrs+                   -> SharingAcc ScopedAcc ScopedExp arrs+                   -> StableSharingAcc++instance Show StableSharingAcc where+  show (StableSharingAcc sn _) = show $ hashStableNameHeight sn++instance Eq StableSharingAcc where+  StableSharingAcc sn1 _ == StableSharingAcc sn2 _+    | Just sn1' <- gcast sn1 = sn1' == sn2+    | otherwise              = False++higherSSA :: StableSharingAcc -> StableSharingAcc -> Bool+StableSharingAcc sn1 _ `higherSSA` StableSharingAcc sn2 _ = sn1 `higherSNH` sn2++-- Test whether the given stable names matches an array computation with sharing.+--+matchStableAcc :: Typeable arrs => StableAccName arrs -> StableSharingAcc -> Bool+matchStableAcc sn1 (StableSharingAcc sn2 _)+  | Just sn1' <- gcast sn1 = sn1' == sn2+  | otherwise              = False++-- Dummy entry for environments to be used for unused variables.+--+noStableAccName :: StableAccName arrs+noStableAccName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0++-- Stable 'Exp' nodes+-- ------------------++-- Stable name for 'Exp' nodes including the height of the AST.+--+type StableExpName t = StableNameHeight (Exp t)++-- Interleave sharing annotations into a scalar expressions AST in the same manner as 'SharingAcc'+-- do for array computations.+--+data SharingExp (acc :: * -> *) exp t where+  VarSharing :: Elt t+             => StableExpName t                     -> SharingExp acc exp t+  LetSharing :: StableSharingExp -> exp t           -> SharingExp acc exp t+  ExpSharing :: Elt t+             => StableExpName t -> PreExp acc exp t -> SharingExp acc exp t++-- Specifies a scalar expression AST with sharing annotations but no scoping; i.e. no LetSharing+-- constructors. If the expression is rooted in a function, the list contains the tags of the+-- variables bound by the immediate surrounding lambdas.+data UnscopedExp t = UnscopedExp [Int] (SharingExp UnscopedAcc UnscopedExp t)++-- Specifies a scalar expression AST with sharing. For expressions rooted in functions the list+-- holds a sorted environment corresponding to the variables bound in the immediate surounding+-- lambdas.+data ScopedExp t = ScopedExp [StableSharingExp] (SharingExp ScopedAcc ScopedExp t)++-- Expressions rooted in 'Acc' computations.+--+-- * When counting occurrences, the root of every expression embedded in an 'Acc' is annotated by+--   an occurrence map for that one expression (excluding any subterms that are rooted in embedded+--   'Acc's.)+--+data RootExp t = RootExp (OccMap Exp) (UnscopedExp t)++-- Stable name for an expression associated with its sharing-annotated version.+--+data StableSharingExp where+  StableSharingExp :: Elt t => StableExpName t -> SharingExp ScopedAcc ScopedExp t -> StableSharingExp++instance Show StableSharingExp where+  show (StableSharingExp sn _) = show $ hashStableNameHeight sn++instance Eq StableSharingExp where+  StableSharingExp sn1 _ == StableSharingExp sn2 _+    | Just sn1' <- gcast sn1 = sn1' == sn2+    | otherwise              = False++higherSSE :: StableSharingExp -> StableSharingExp -> Bool+StableSharingExp sn1 _ `higherSSE` StableSharingExp sn2 _ = sn1 `higherSNH` sn2++-- Test whether the given stable names matches an expression with sharing.+--+matchStableExp :: Typeable t => StableExpName t -> StableSharingExp -> Bool+matchStableExp sn1 (StableSharingExp sn2 _)+  | Just sn1' <- gcast sn1 = sn1' == sn2+  | otherwise              = False++-- Dummy entry for environments to be used for unused variables.+--+noStableExpName :: StableExpName t+noStableExpName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0+++{--+-- Stable 'Seq' nodes+-- ------------------++-- Stable name for 'Seq' nodes including the height of the AST.+--+type StableSeqName arrs = StableNameHeight (Seq arrs)++-- Interleave sharing annotations into an sequence computation AST in the same manner as SharingAcc+-- and SharingExp+--+data SharingSeq acc seq exp arrs where+  SvarSharing :: (Typeable arrs, Arrays arrs)+              => StableSeqName [arrs]                       -> SharingSeq acc seq exp [arrs]+  SletSharing :: StableSharingSeq -> seq t                  -> SharingSeq acc seq exp t+  SeqSharing  :: Typeable arrs+              => StableSeqName arrs -> PreSeq acc seq exp arrs -> SharingSeq acc seq exp arrs++-- Array expression with sharing but shared values have not been scoped; i.e. no let bindings. If+-- the expression is rooted in a function, the list contains the tags of the variables bound by the+-- immediate surrounding lambdas.+data UnscopedSeq t = UnscopedSeq (SharingSeq UnscopedAcc UnscopedSeq RootExp t)++-- Array expression with sharing. For expressions rooted in functions the list holds a sorted+-- environment corresponding to the variables bound in the immediate surounding lambdas.+data ScopedSeq t = ScopedSeq (SharingSeq ScopedAcc ScopedSeq ScopedExp t)++-- Sequences rooted in 'Acc' computations.+--+-- * When counting occurrences, the root of every sequence embedded in an 'Acc' is annotated by+--   an occurrence map for that one expression (excluding any subterms that are rooted in embedded+--   'Acc's.)+--+data RootSeq t = RootSeq (OccMap Seq) (UnscopedSeq t)++-- Stable name for an array computation associated with its sharing-annotated version.+--+data StableSharingSeq where+  StableSharingSeq :: Typeable arrs+                   => StableSeqName arrs+                   -> SharingSeq ScopedAcc ScopedSeq ScopedExp arrs+                   -> StableSharingSeq++instance Show StableSharingSeq where+  show (StableSharingSeq sn _) = show $ hashStableNameHeight sn++instance Eq StableSharingSeq where+  StableSharingSeq sn1 _ == StableSharingSeq sn2 _+    | Just sn1' <- gcast sn1 = sn1' == sn2+    | otherwise              = False++higherSSS :: StableSharingSeq -> StableSharingSeq -> Bool+StableSharingSeq sn1 _ `higherSSS` StableSharingSeq sn2 _ = sn1 `higherSNH` sn2++-- Test whether the given stable names matches an array computation with sharing.+--+matchStableSeq :: Typeable arrs => StableSeqName arrs -> StableSharingSeq -> Bool+matchStableSeq sn1 (StableSharingSeq sn2 _)+  | Just sn1' <- gcast sn1 = sn1' == sn2+  | otherwise              = False+--}+++-- Occurrence counting+-- ===================++-- Compute the 'Acc' occurrence map, marks all nodes (both 'Seq' and 'Exp' nodes) with stable names,+-- and drop repeated occurrences of shared 'Acc' and 'Exp' subtrees (Phase One).+--+-- We compute a single 'Acc' occurrence map for the whole AST, but one 'Exp' occurrence map for each+-- sub-expression rooted in an 'Acc' operation.  This is as we cannot float 'Exp' subtrees across+-- 'Acc' operations, but we can float 'Acc' subtrees out of 'Exp' expressions.+--+-- Note [Traversing functions and side effects]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We need to descent into function bodies to build the 'OccMap' with all occurrences in the+-- function bodies.  Due to the side effects in the construction of the occurrence map and, more+-- importantly, the dependence of the second phase on /global/ occurrence information, we may not+-- delay the body traversals by putting them under a lambda.  Hence, we apply each function, to+-- traverse its body and use a /dummy abstraction/ of the result.+--+-- For example, given a function 'f', we traverse 'f (Tag 0)', which yields a transformed body 'e'.+-- As the result of the traversal of the overall function, we use 'const e'.  Hence, it is crucial+-- that the 'Tag' supplied during the initial traversal is already the one required by the HOAS to+-- de Bruijn conversion in 'convertSharingAcc' — any subsequent application of 'const e' will only+-- yield 'e' with the embedded 'Tag 0' of the original application.  During sharing recovery, we+-- float /all/ free variables ('Atag' and 'Tag') out to construct the initial environment for+-- producing de Bruijn indices, which replaces them by 'AvarSharing' or 'VarSharing' nodes.  Hence,+-- the tag values only serve the purpose of determining the ordering in that initial environment.+-- They are /not/ directly used to compute the de Brujin indices.+--+makeOccMapAcc+    :: Typeable arrs+    => Config+    -> Level+    -> Acc arrs+    -> IO (UnscopedAcc arrs, OccMap Acc)+makeOccMapAcc config lvl acc = do+  traceLine "makeOccMapAcc" "Enter"+  accOccMap             <- newASTHashTable+  (acc', _)             <- makeOccMapSharingAcc config accOccMap lvl acc+  frozenAccOccMap       <- freezeOccMap accOccMap+  traceLine "makeOccMapAcc" "Exit"+  return (acc', frozenAccOccMap)+++makeOccMapSharingAcc+    :: Typeable arrs+    => Config+    -> OccMapHash Acc+    -> Level+    -> Acc arrs+    -> IO (UnscopedAcc arrs, Int)+makeOccMapSharingAcc config accOccMap = traverseAcc+  where+    traverseFun1 :: (Elt a, Typeable b) => Level -> (Exp a -> Exp b) -> IO (Exp a -> RootExp b, Int)+    traverseFun1 = makeOccMapFun1 config accOccMap++    traverseFun2 :: (Elt a, Elt b, Typeable c)+                 => Level+                 -> (Exp a -> Exp b -> Exp c)+                 -> IO (Exp a -> Exp b -> RootExp c, Int)+    traverseFun2 = makeOccMapFun2 config accOccMap++    traverseAfun1 :: (Arrays a, Typeable b) => Level -> (Acc a -> Acc b) -> IO (Acc a -> UnscopedAcc b, Int)+    traverseAfun1 = makeOccMapAfun1 config accOccMap++    traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int)+    traverseExp = makeOccMapExp config accOccMap++    traverseBoundary+        :: Level+        -> PreBoundary Acc Exp t+        -> IO (PreBoundary UnscopedAcc RootExp t, Int)+    traverseBoundary lvl bndy =+      case bndy of+        Clamp      -> return (Clamp, 0)+        Mirror     -> return (Mirror, 0)+        Wrap       -> return (Wrap, 0)+        Constant v -> return (Constant v, 0)+        Function f -> do+          (f', h) <- traverseFun1 lvl f+          return (Function f', h)++    -- traverseSeq :: forall arrs. Typeable arrs+    --             => Level -> Seq arrs+    --             -> IO (RootSeq arrs, Int)+    -- traverseSeq = makeOccMapRootSeq config accOccMap++    traverseAcc :: forall arrs. Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)+    traverseAcc lvl acc@(Acc pacc)+      = mfix $ \ ~(_, height) -> do+          -- Compute stable name and enter it into the occurrence map+          --+          sn                         <- makeStableAST acc+          heightIfRepeatedOccurrence <- enterOcc accOccMap (StableASTName sn) height++          traceLine (showPreAccOp pacc) $ do+            let hash = show (hashStableName sn)+            case heightIfRepeatedOccurrence of+              Just height -> "REPEATED occurrence (sn = " ++ hash ++ "; height = " ++ show height ++ ")"+              Nothing     -> "first occurrence (sn = " ++ hash ++ ")"++          -- Reconstruct the computation in shared form.+          --+          -- In case of a repeated occurrence, the height comes from the occurrence map; otherwise+          -- it is computed by the traversal function passed in 'newAcc'. See also 'enterOcc'.+          --+          -- NB: This function can only be used in the case alternatives below; outside of the+          --     case we cannot discharge the 'Arrays arrs' constraint.+          --+          let reconstruct :: Arrays arrs+                          => IO (PreAcc UnscopedAcc RootExp arrs, Int)+                          -> IO (UnscopedAcc arrs, Int)+              reconstruct newAcc+                = case heightIfRepeatedOccurrence of+                    Just height | recoverAccSharing config+                      -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height)), height)+                    _ -> do (acc, height) <- newAcc+                            return (UnscopedAcc [] (AccSharing (StableNameHeight sn height) acc), height)++          case pacc of+            Atag i                      -> reconstruct $ return (Atag i, 0)           -- height is 0!+            Pipe afun1 afun2 acc        -> reconstruct $ do+                                             (afun1', h1) <- traverseAfun1 lvl afun1+                                             (afun2', h2) <- traverseAfun1 lvl afun2+                                             (acc', h3)   <- traverseAcc lvl acc+                                             return (Pipe afun1' afun2' acc'+                                                    , h1 `max` h2 `max` h3 + 1)+            Aforeign ff afun acc        -> reconstruct $ travA (Aforeign ff afun) acc+            Acond e acc1 acc2           -> reconstruct $ do+                                             (e'   , h1) <- traverseExp lvl e+                                             (acc1', h2) <- traverseAcc lvl acc1+                                             (acc2', h3) <- traverseAcc lvl acc2+                                             return (Acond e' acc1' acc2', h1 `max` h2 `max` h3 + 1)+            Awhile pred iter init       -> reconstruct $ do+                                             (pred', h1) <- traverseAfun1 lvl pred+                                             (iter', h2) <- traverseAfun1 lvl iter+                                             (init', h3) <- traverseAcc lvl init+                                             return (Awhile pred' iter' init'+                                                    , h1 `max` h2 `max` h3 + 1)++            Atuple tup                  -> reconstruct $ do+                                             (tup', h) <- travAtup tup+                                             return (Atuple tup', h)+            Aprj ix a                   -> reconstruct $ travA (Aprj ix) a++            Use arr                     -> reconstruct $ return (Use arr, 1)+            Unit e                      -> reconstruct $ do+                                             (e', h) <- traverseExp lvl e+                                             return (Unit e', h + 1)+            Generate e f                -> reconstruct $ do+                                             (e', h1) <- traverseExp lvl e+                                             (f', h2) <- traverseFun1 lvl f+                                             return (Generate e' f', h1 `max` h2 + 1)+            Reshape e acc               -> reconstruct $ travEA Reshape e acc+            Replicate e acc             -> reconstruct $ travEA Replicate e acc+            Slice acc e                 -> reconstruct $ travEA (flip Slice) e acc+            Map f acc                   -> reconstruct $ do+                                             (f'  , h1) <- traverseFun1 lvl f+                                             (acc', h2) <- traverseAcc lvl acc+                                             return (Map f' acc', h1 `max` h2 + 1)+            ZipWith f acc1 acc2         -> reconstruct $ travF2A2 ZipWith f acc1 acc2+            Fold f e acc                -> reconstruct $ travF2EA Fold f e acc+            Fold1 f acc                 -> reconstruct $ travF2A Fold1 f acc+            FoldSeg f e acc1 acc2       -> reconstruct $ do+                                             (f'   , h1) <- traverseFun2 lvl f+                                             (e'   , h2) <- traverseExp lvl e+                                             (acc1', h3) <- traverseAcc lvl acc1+                                             (acc2', h4) <- traverseAcc lvl acc2+                                             return (FoldSeg f' e' acc1' acc2',+                                                     h1 `max` h2 `max` h3 `max` h4 + 1)+            Fold1Seg f acc1 acc2        -> reconstruct $ travF2A2 Fold1Seg f acc1 acc2+            Scanl f e acc               -> reconstruct $ travF2EA Scanl f e acc+            Scanl' f e acc              -> reconstruct $ travF2EA Scanl' f e acc+            Scanl1 f acc                -> reconstruct $ travF2A Scanl1 f acc+            Scanr f e acc               -> reconstruct $ travF2EA Scanr f e acc+            Scanr' f e acc              -> reconstruct $ travF2EA Scanr' f e acc+            Scanr1 f acc                -> reconstruct $ travF2A Scanr1 f acc+            Permute c acc1 p acc2       -> reconstruct $ do+                                             (c'   , h1) <- traverseFun2 lvl c+                                             (p'   , h2) <- traverseFun1 lvl p+                                             (acc1', h3) <- traverseAcc lvl acc1+                                             (acc2', h4) <- traverseAcc lvl acc2+                                             return (Permute c' acc1' p' acc2',+                                                     h1 `max` h2 `max` h3 `max` h4 + 1)+            Backpermute e p acc         -> reconstruct $ do+                                             (e'  , h1) <- traverseExp lvl e+                                             (p'  , h2) <- traverseFun1 lvl p+                                             (acc', h3) <- traverseAcc lvl acc+                                             return (Backpermute e' p' acc', h1 `max` h2 `max` h3 + 1)+            Stencil s bnd acc           -> reconstruct $ do+                                             (s'  , h1) <- makeOccMapStencil1 config accOccMap acc lvl s+                                             (bnd', h2) <- traverseBoundary lvl bnd+                                             (acc', h3) <- traverseAcc lvl acc+                                             return (Stencil s' bnd' acc', h1 `max` h2 `max` h3 + 1)+            Stencil2 s bnd1 acc1+                       bnd2 acc2        -> reconstruct $ do+                                             (s'   , h1) <- makeOccMapStencil2 config accOccMap acc1 acc2 lvl s+                                             (bnd1', h2) <- traverseBoundary lvl bnd1+                                             (acc1', h3) <- traverseAcc lvl acc1+                                             (bnd2', h4) <- traverseBoundary lvl bnd2+                                             (acc2', h5) <- traverseAcc lvl acc2+                                             return (Stencil2 s' bnd1' acc1' bnd2' acc2',+                                                     h1 `max` h2 `max` h3 `max` h4 `max` h5 + 1)+            -- Collect s                   -> reconstruct $ do+            --                                  (s', h) <- traverseSeq lvl s+            --                                  return (Collect s', h + 1)+++      where+        travA :: Arrays arrs'+              => (UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)+              -> Acc arrs' -> IO (PreAcc UnscopedAcc RootExp arrs, Int)+        travA c acc+          = do+              (acc', h) <- traverseAcc lvl acc+              return (c acc', h + 1)++        travEA :: (Typeable b, Arrays arrs')+               => (RootExp b -> UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)+               -> Exp b -> Acc arrs' -> IO (PreAcc UnscopedAcc RootExp arrs, Int)+        travEA c exp acc+          = do+              (exp', h1) <- traverseExp lvl exp+              (acc', h2) <- traverseAcc lvl acc+              return (c exp' acc', h1 `max` h2 + 1)++        travF2A :: (Elt b, Elt c, Typeable d, Arrays arrs')+                => ((Exp b -> Exp c -> RootExp d) -> UnscopedAcc arrs'+                    -> PreAcc UnscopedAcc RootExp arrs)+                -> (Exp b -> Exp c -> Exp d) -> Acc arrs'+                -> IO (PreAcc UnscopedAcc RootExp arrs, Int)+        travF2A c fun acc+          = do+              (fun', h1) <- traverseFun2 lvl fun+              (acc', h2) <- traverseAcc lvl acc+              return (c fun' acc', h1 `max` h2 + 1)++        travF2EA :: (Elt b, Elt c, Typeable d, Typeable e, Arrays arrs')+                 => ((Exp b -> Exp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)+                 -> (Exp b -> Exp c -> Exp d) -> Exp e -> Acc arrs'+                 -> IO (PreAcc UnscopedAcc RootExp arrs, Int)+        travF2EA c fun exp acc+          = do+              (fun', h1) <- traverseFun2 lvl fun+              (exp', h2) <- traverseExp lvl exp+              (acc', h3) <- traverseAcc lvl acc+              return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1)++        travF2A2 :: (Elt b, Elt c, Typeable d, Arrays arrs1, Arrays arrs2)+                 => ((Exp b -> Exp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreAcc UnscopedAcc RootExp arrs)+                 -> (Exp b -> Exp c -> Exp d) -> Acc arrs1 -> Acc arrs2+                 -> IO (PreAcc UnscopedAcc RootExp arrs, Int)+        travF2A2 c fun acc1 acc2+          = do+              (fun' , h1) <- traverseFun2 lvl fun+              (acc1', h2) <- traverseAcc lvl acc1+              (acc2', h3) <- traverseAcc lvl acc2+              return (c fun' acc1' acc2', h1 `max` h2 `max` h3 + 1)++        travAtup :: Atuple Acc a+                 -> IO (Atuple UnscopedAcc a, Int)+        travAtup NilAtup          = return (NilAtup, 1)+        travAtup (SnocAtup tup a) = do+          (tup', h1) <- travAtup tup+          (a',   h2) <- traverseAcc lvl a+          return (SnocAtup tup' a', h1 `max` h2 + 1)++makeOccMapAfun1 :: (Arrays a, Typeable b)+                => Config+                -> OccMapHash Acc+                -> Level+                -> (Acc a -> Acc b)+                -> IO (Acc a -> UnscopedAcc b, Int)+makeOccMapAfun1 config accOccMap lvl f = do+  let x = Acc (Atag lvl)+  --+  (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+1) (f x)+  return (const (UnscopedAcc [lvl] body), height)++{--+makeOccMapAfun2 :: (Arrays a, Arrays b, Typeable c)+                => Config+                -> OccMapHash Acc+                -> Level+                -> (Acc a -> Acc b -> Acc c)+                -> IO (Acc a -> Acc b -> UnscopedAcc c, Int)+makeOccMapAfun2 config accOccMap lvl f = do+  let x = Acc (Atag (lvl + 1))+      y = Acc (Atag (lvl + 0))+  --+  (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+2) (f x y)+  return (\ _ _ -> (UnscopedAcc [lvl, lvl+1] body), height)++makeOccMapAfun3 :: (Arrays a, Arrays b, Arrays c, Typeable d)+                => Config+                -> OccMapHash Acc+                -> Level+                -> (Acc a -> Acc b -> Acc c -> Acc d)+                -> IO (Acc a -> Acc b -> Acc c -> UnscopedAcc d, Int)+makeOccMapAfun3 config accOccMap lvl f = do+  let x = Acc (Atag (lvl + 2))+      y = Acc (Atag (lvl + 1))+      z = Acc (Atag (lvl + 0))+  --+  (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+3) (f x y z)+  return (\ _ _ _ -> (UnscopedAcc [lvl, lvl+1, lvl+2] body), height)+--}++-- Generate occupancy information for scalar functions and expressions. Helper+-- functions wrapping around 'makeOccMapRootExp' with more specific types.+--+-- See Note [Traversing functions and side effects]+--+makeOccMapExp+    :: Typeable e+    => Config+    -> OccMapHash Acc+    -> Level+    -> Exp e+    -> IO (RootExp e, Int)+makeOccMapExp config accOccMap lvl = makeOccMapRootExp config accOccMap lvl []++makeOccMapFun1+    :: (Elt a, Typeable b)+    => Config+    -> OccMapHash Acc+    -> Level+    -> (Exp a -> Exp b)+    -> IO (Exp a -> RootExp b, Int)+makeOccMapFun1 config accOccMap lvl f = do+  let x = Exp (Tag lvl)+  --+  (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (f x)+  return (const body, height)++makeOccMapFun2+    :: (Elt a, Elt b, Typeable c)+    => Config+    -> OccMapHash Acc+    -> Level+    -> (Exp a -> Exp b -> Exp c)+    -> IO (Exp a -> Exp b -> RootExp c, Int)+makeOccMapFun2 config accOccMap lvl f = do+  let x = Exp (Tag (lvl+1))+      y = Exp (Tag lvl)+  --+  (body, height) <- makeOccMapRootExp config accOccMap (lvl+2) [lvl, lvl+1] (f x y)+  return (\_ _ -> body, height)++makeOccMapStencil1+    :: forall sh a b stencil. (Stencil sh a stencil, Typeable b)+    => Config+    -> OccMapHash Acc+    -> Acc (Array sh a)         {- dummy -}+    -> Level+    -> (stencil -> Exp b)+    -> IO (stencil -> RootExp b, Int)+makeOccMapStencil1 config accOccMap _ lvl stencil = do+  let x = Exp (Tag lvl)+      f = stencil . stencilPrj (undefined::sh) (undefined::a)+  --+  (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (f x)+  return (const body, height)++makeOccMapStencil2+    :: forall sh a b c stencil1 stencil2. (Stencil sh a stencil1, Stencil sh b stencil2, Typeable c)+    => Config+    -> OccMapHash Acc+    -> Acc (Array sh a)         {- dummy -}+    -> Acc (Array sh b)         {- dummy -}+    -> Level+    -> (stencil1 -> stencil2 -> Exp c)+    -> IO (stencil1 -> stencil2 -> RootExp c, Int)+makeOccMapStencil2 config accOccMap _ _ lvl stencil = do+  let x         = Exp (Tag (lvl+1))+      y         = Exp (Tag lvl)+      f a b     = stencil (stencilPrj (undefined::sh) (undefined::a) a)+                          (stencilPrj (undefined::sh) (undefined::b) b)+  --+  (body, height) <- makeOccMapRootExp config accOccMap (lvl+2) [lvl, lvl+1] (f x y)+  return (\_ _ -> body, height)+++-- Generate sharing information for expressions embedded in Acc computations.+-- Expressions are annotated with:+--+--  1) the tags of free scalar variables (for scalar functions)+--  2) a local occurrence map for that expression.+--+makeOccMapRootExp+    :: Typeable e+    => Config+    -> OccMapHash Acc+    -> Level                            -- The level of currently bound scalar variables+    -> [Int]                            -- The tags of newly introduced free scalar variables in this expression+    -> Exp e+    -> IO (RootExp e, Int)+makeOccMapRootExp config accOccMap lvl fvs exp = do+  traceLine "makeOccMapRootExp" "Enter"+  expOccMap                     <- newASTHashTable+  (UnscopedExp [] exp', height) <- makeOccMapSharingExp config accOccMap expOccMap lvl exp+  frozenExpOccMap               <- freezeOccMap expOccMap+  traceLine "makeOccMapRootExp" "Exit"+  return (RootExp frozenExpOccMap (UnscopedExp fvs exp'), height)+++-- Generate sharing information for an open scalar expression.+--+makeOccMapSharingExp+    :: Typeable e+    => Config+    -> OccMapHash Acc+    -> OccMapHash Exp+    -> Level                            -- The level of currently bound variables+    -> Exp e+    -> IO (UnscopedExp e, Int)+makeOccMapSharingExp config accOccMap expOccMap = travE+  where+    travE :: forall a. Typeable a => Level -> Exp a -> IO (UnscopedExp a, Int)+    travE lvl exp@(Exp pexp)+      = mfix $ \ ~(_, height) -> do+          -- Compute stable name and enter it into the occurrence map+          --+          sn                         <- makeStableAST exp+          heightIfRepeatedOccurrence <- enterOcc expOccMap (StableASTName sn) height++          traceLine (showPreExpOp pexp) $ do+            let hash = show (hashStableName sn)+            case heightIfRepeatedOccurrence of+              Just height -> "REPEATED occurrence (sn = " ++ hash ++ "; height = " ++ show height ++ ")"+              Nothing     -> "first occurrence (sn = " ++ hash ++ ")"++          -- Reconstruct the computation in shared form.+          --+          -- In case of a repeated occurrence, the height comes from the occurrence map; otherwise+          -- it is computed by the traversal function passed in 'newExp'.  See also 'enterOcc'.+          --+          -- NB: This function can only be used in the case alternatives below; outside of the+          --     case we cannot discharge the 'Elt a' constraint.+          --+          let reconstruct :: Elt a+                          => IO (PreExp UnscopedAcc UnscopedExp a, Int)+                          -> IO (UnscopedExp a, Int)+              reconstruct newExp+                = case heightIfRepeatedOccurrence of+                    Just height | recoverExpSharing config+                      -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height)), height)+                    _ -> do (exp, height) <- newExp+                            return (UnscopedExp [] (ExpSharing (StableNameHeight sn height) exp), height)++          case pexp of+            Tag i               -> reconstruct $ return (Tag i, 0)      -- height is 0!+            Const c             -> reconstruct $ return (Const c, 1)+            Undef               -> reconstruct $ return (Undef, 1)+            Tuple tup           -> reconstruct $ do+                                     (tup', h) <- travTup tup+                                     return (Tuple tup', h)+            Prj i e             -> reconstruct $ travE1 (Prj i) e+            IndexNil            -> reconstruct $ return (IndexNil, 1)+            IndexCons ix i      -> reconstruct $ travE2 IndexCons ix i+            IndexHead i         -> reconstruct $ travE1 IndexHead i+            IndexTail ix        -> reconstruct $ travE1 IndexTail ix+            IndexAny            -> reconstruct $ return (IndexAny, 1)+            ToIndex sh ix       -> reconstruct $ travE2 ToIndex sh ix+            FromIndex sh e      -> reconstruct $ travE2 FromIndex sh e+            Cond e1 e2 e3       -> reconstruct $ travE3 Cond e1 e2 e3+            While p iter init   -> reconstruct $ do+                                     (p'   , h1) <- traverseFun1 lvl p+                                     (iter', h2) <- traverseFun1 lvl iter+                                     (init', h3) <- travE lvl init+                                     return (While p' iter' init', h1 `max` h2 `max` h3 + 1)+            PrimConst c         -> reconstruct $ return (PrimConst c, 1)+            PrimApp p e         -> reconstruct $ travE1 (PrimApp p) e+            Index a e           -> reconstruct $ travAE Index a e+            LinearIndex a i     -> reconstruct $ travAE LinearIndex a i+            Shape a             -> reconstruct $ travA Shape a+            ShapeSize e         -> reconstruct $ travE1 ShapeSize e+            Intersect sh1 sh2   -> reconstruct $ travE2 Intersect sh1 sh2+            Union sh1 sh2       -> reconstruct $ travE2 Union sh1 sh2+            Foreign ff f e      -> reconstruct $ do+                                      (e', h) <- travE lvl e+                                      return  (Foreign ff f e', h+1)+            Coerce e            -> reconstruct $ travE1 Coerce e++      where+        traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)+        traverseAcc = makeOccMapSharingAcc config accOccMap++        traverseFun1 :: (Elt a, Typeable b)+                     => Level+                     -> (Exp a -> Exp b)+                     -> IO (Exp a -> UnscopedExp b, Int)+        traverseFun1 lvl f+          = do+              let x = Exp (Tag lvl)+              (UnscopedExp [] body, height) <- travE (lvl+1) (f x)+              return (const (UnscopedExp [lvl] body), height + 1)+++        travE1 :: Typeable b => (UnscopedExp b -> PreExp UnscopedAcc UnscopedExp a) -> Exp b+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)+        travE1 c e+          = do+              (e', h) <- travE lvl e+              return (c e', h + 1)++        travE2 :: (Typeable b, Typeable c)+               => (UnscopedExp b -> UnscopedExp c -> PreExp UnscopedAcc UnscopedExp a)+               -> Exp b -> Exp c+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)+        travE2 c e1 e2+          = do+              (e1', h1) <- travE lvl e1+              (e2', h2) <- travE lvl e2+              return (c e1' e2', h1 `max` h2 + 1)++        travE3 :: (Typeable b, Typeable c, Typeable d)+               => (UnscopedExp b -> UnscopedExp c -> UnscopedExp d -> PreExp UnscopedAcc UnscopedExp a)+               -> Exp b -> Exp c -> Exp d+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)+        travE3 c e1 e2 e3+          = do+              (e1', h1) <- travE lvl e1+              (e2', h2) <- travE lvl e2+              (e3', h3) <- travE lvl e3+              return (c e1' e2' e3', h1 `max` h2 `max` h3 + 1)++        travA :: Typeable b => (UnscopedAcc b -> PreExp UnscopedAcc UnscopedExp a) -> Acc b+              -> IO (PreExp UnscopedAcc UnscopedExp a, Int)+        travA c acc+          = do+              (acc', h) <- traverseAcc lvl acc+              return (c acc', h + 1)++        travAE :: (Typeable b, Typeable c)+               => (UnscopedAcc b -> UnscopedExp c -> PreExp UnscopedAcc UnscopedExp a)+               -> Acc b -> Exp c+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)+        travAE c acc e+          = do+              (acc', h1) <- traverseAcc lvl acc+              (e'  , h2) <- travE lvl e+              return (c acc' e', h1 `max` h2 + 1)++        travTup :: Tuple Exp tup -> IO (Tuple UnscopedExp tup, Int)+        travTup NilTup          = return (NilTup, 1)+        travTup (SnocTup tup e) = do+                                    (tup', h1) <- travTup tup+                                    (e'  , h2) <- travE lvl e+                                    return (SnocTup tup' e', h1 `max` h2 + 1)+++{--+makeOccMapRootSeq+    :: Typeable arrs+    => Config+    -> OccMapHash Acc+    -> Level+    -> Seq arrs+    -> IO (RootSeq arrs, Int)+makeOccMapRootSeq config accOccMap lvl seq = do+  traceLine "makeOccMapRootSeq" "Enter"+  seqOccMap       <- newASTHashTable+  (seq', height)  <- makeOccMapSharingSeq config accOccMap seqOccMap lvl seq+  frozenSeqOccMap <- freezeOccMap seqOccMap+  traceLine "makeOccMapRootSeq" "Exit"+  return (RootSeq frozenSeqOccMap seq', height)++-- Generate sharing information for an open sequence expression.+--+makeOccMapSharingSeq+    :: Typeable e+    => Config+    -> OccMapHash Acc+    -> OccMapHash Seq+    -> Level                            -- The level of currently bound variables+    -> Seq e+    -> IO (UnscopedSeq e, Int)+makeOccMapSharingSeq config accOccMap seqOccMap = traverseSeq+  where+    traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)+    traverseAcc = makeOccMapSharingAcc config accOccMap++    traverseAfun1 :: (Arrays a, Typeable b) => Level -> (Acc a -> Acc b) -> IO (Acc a -> UnscopedAcc b, Int)+    traverseAfun1 = makeOccMapAfun1 config accOccMap++    traverseAfun2 :: (Arrays a, Arrays b, Typeable c) => Level -> (Acc a -> Acc b -> Acc c) -> IO (Acc a -> Acc b -> UnscopedAcc c, Int)+    traverseAfun2 = makeOccMapAfun2 config accOccMap++    traverseAfun3 :: (Arrays a, Arrays b, Arrays c, Typeable d) => Level -> (Acc a -> Acc b -> Acc c -> Acc d) -> IO (Acc a -> Acc b -> Acc c -> UnscopedAcc d, Int)+    traverseAfun3 = makeOccMapAfun3 config accOccMap++    traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int)+    traverseExp = makeOccMapExp config accOccMap++    traverseFun2 :: (Elt a, Elt b, Typeable c)+                 => Level+                 -> (Exp a -> Exp b -> Exp c)+                 -> IO (Exp a -> Exp b -> RootExp c, Int)+    traverseFun2 = makeOccMapFun2 config accOccMap++    traverseTup :: Level -> Atuple Seq tup -> IO (Atuple UnscopedSeq tup, Int)+    traverseTup _   NilAtup          = return (NilAtup, 1)+    traverseTup lvl (SnocAtup tup s) = do+                                        (tup', h1) <- traverseTup lvl tup+                                        (s'  , h2) <- traverseSeq lvl s+                                        return (SnocAtup tup' s', h1 `max` h2 + 1)++    traverseSeq :: forall arrs. Typeable arrs => Level -> Seq arrs -> IO (UnscopedSeq arrs, Int)+    traverseSeq lvl acc@(Seq seq)+      = mfix $ \ ~(_, height) -> do+          -- Compute stable name and enter it into the occurrence map+          --+          sn                         <- makeStableAST acc+          heightIfRepeatedOccurrence <- enterOcc seqOccMap (StableASTName sn) height++          traceLine (showPreSeqOp seq) $ do+            let hash = show (hashStableName sn)+            case heightIfRepeatedOccurrence of+              Just height -> "REPEATED occurrence (sn = " ++ hash ++ "; height = " ++ show height ++ ")"+              Nothing     -> "first occurrence (sn = " ++ hash ++ ")"++          -- Reconstruct the computation in shared form.+          --+          -- In case of a repeated occurrence, the height comes from the occurrence map; otherwise+          -- it is computed by the traversal function passed in 'newAcc'. See also 'enterOcc'.+          --+          -- NB: This function can only be used in the case alternatives below; outside of the+          --     case we cannot discharge the 'Arrays arrs' constraint.+          --+          let producer :: (arrs ~ [a], Arrays a)+                       => IO (PreSeq UnscopedAcc UnscopedSeq RootExp arrs, Int)+                       -> IO (UnscopedSeq arrs, Int)+              producer newSeq+                = case heightIfRepeatedOccurrence of+                    Just height | recoverSeqSharing config+                      -> return (UnscopedSeq (SvarSharing (StableNameHeight sn height)), height)+                    _ -> do (seq, height) <- newSeq+                            return (UnscopedSeq (SeqSharing (StableNameHeight sn height) seq), height)++          let consumer :: IO (PreSeq UnscopedAcc UnscopedSeq RootExp arrs, Int)+                       -> IO (UnscopedSeq arrs, Int)+              consumer newSeq+                = do (seq, height) <- newSeq+                     return (UnscopedSeq (SeqSharing (StableNameHeight sn height) seq), height)++          case seq of+            StreamIn arrs -> producer $ return (StreamIn arrs, 1)+            ToSeq sl acc -> producer $ do+              (acc', h1) <- traverseAcc lvl acc+              return (ToSeq sl acc', h1 + 1)+            MapSeq afun s -> producer $ do+              (afun', h1) <- traverseAfun1 lvl afun+              (s'   , h2) <- traverseSeq lvl s+              return (MapSeq afun' s', h1 `max` h2 + 1)+            ZipWithSeq afun s1 s2 -> producer $ do+              (afun', h1) <- traverseAfun2 lvl afun+              (s1'  , h2) <- traverseSeq lvl s1+              (s2'  , h3) <- traverseSeq lvl s2+              return (ZipWithSeq afun' s1' s2', h1 `max` h2 `max` h3 + 1)+            ScanSeq fun e s -> producer $ do+              (fun', h1) <- traverseFun2 lvl fun+              (e',  h2) <- traverseExp lvl e+              (s'   , h3) <- traverseSeq lvl s+              return (ScanSeq fun' e' s', h1 `max` h2 `max` h3 + 1)+            FoldSeq fun e s -> consumer $ do+              (fun', h1) <- traverseFun2 lvl fun+              (e'  , h2) <- traverseExp lvl e+              (s'  , h3) <- traverseSeq lvl s+              return (FoldSeq fun' e' s', h1 `max` h2 `max` h3 + 1)+            FoldSeqFlatten afun acc s -> consumer $ do+              (afun', h1) <- traverseAfun3 lvl afun+              (acc',  h2) <- traverseAcc lvl acc+              (s'   , h3) <- traverseSeq lvl s+              return (FoldSeqFlatten afun' acc' s', h1 `max` h2 `max` h3 + 1)+            Stuple t -> consumer $ do+              (t', h1) <- traverseTup lvl t+              return (Stuple t', h1 + 1)+--}+++-- Type used to maintain how often each shared subterm, so far, occurred during a bottom-up sweep,+-- as well as the relation between subterms. It is comprised of a list of terms and a graph giving+-- their relation.+--+--   Invariants of the list:+--   - If one shared term 's' is itself a subterm of another shared term 't', then 's' must occur+--     *after* 't' in the list.+--   - No shared term occurs twice.+--   - A term may have a final occurrence count of only 1 iff it is either a free variable ('Atag'+--     or 'Tag') or an array computation lifted out of an expression.+--   - All 'Exp' node counts precede all 'Acc' node counts as we don't share 'Exp' nodes across 'Acc'+--     nodes. Similarly, all 'Seq' nodes precede 'Acc' nodes and 'Exp' nodes precede 'Seq' nodes.+--+-- We determine the subterm property by using the tree height in 'StableNameHeight'.  Trees get+-- smaller towards the end of a 'NodeCounts' list.  The height of free variables ('Atag' or 'Tag')+-- is 0, whereas other leaves have height 1.  This guarantees that all free variables are at the end+-- of the 'NodeCounts' list.+--+-- The graph is represented as a map where a stable name 'a' is mapped to a set of stables names 'b'+-- such that if there exists a edge from 'a' to 'c' that 'c' is contained within 'b'.+--+--  Properties of the graph:+--  - There exists an edge from 'a' to 'b' if the term 'a' names is a subterm of the term named by+--    'b'.+--+-- To ensure the list invariant and the graph properties are preserved over merging node counts from+-- sibling subterms, the function '(+++)' must be used.+--+type NodeCounts = ([NodeCount], Map.HashMap NodeName (Set.HashSet NodeName))++data NodeName where+  NodeName :: Typeable a => StableName a -> NodeName++instance Eq NodeName where+  (NodeName sn1) == (NodeName sn2) | Just sn2' <- gcast sn2 = sn1 == sn2'+                                   | otherwise              = False++instance Hashable NodeName where+  hashWithSalt hash (NodeName sn1) = hash + hashStableName sn1++instance Show NodeName where+  show (NodeName sn) = show (hashStableName sn)++data NodeCount = AccNodeCount StableSharingAcc Int+               | ExpNodeCount StableSharingExp Int+               -- SeqNodeCount StableSharingSeq Int+               deriving Show++-- Empty node counts+--+noNodeCounts :: NodeCounts+noNodeCounts = ([], Map.empty)++-- Insert an Acc node into the node counts, assuming that it is a superterm of the all the existing+-- nodes.+--+-- TODO: Perform cycle detection here.+insertAccNode :: StableSharingAcc -> NodeCounts -> NodeCounts+insertAccNode ssa@(StableSharingAcc (StableNameHeight sn _) _) (subterms,g)+  = ([AccNodeCount ssa 1], g') +++ (subterms,g)+  where+    k  = NodeName sn+    hs = map nodeName subterms+    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs]++-- Insert an Exp node into the node counts, assuming that it is a superterm of the all the existing+-- nodes.+--+-- TODO: Perform cycle detection here.+insertExpNode :: StableSharingExp -> NodeCounts -> NodeCounts+insertExpNode ssa@(StableSharingExp (StableNameHeight sn _) _) (subterms,g)+  = ([ExpNodeCount ssa 1], g') +++ (subterms,g)+  where+    k  = NodeName sn+    hs = map nodeName subterms+    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs]++{--+-- Insert an Seq node into the node counts, assuming that it is a superterm of the all the existing+-- nodes.+--+-- TODO: Perform cycle detection here.+insertSeqNode :: StableSharingSeq -> NodeCounts -> NodeCounts+insertSeqNode ssa@(StableSharingSeq (StableNameHeight sn _) _) (subterms,g)+  = ([SeqNodeCount ssa 1], g') +++ (subterms,g)+  where+    k  = NodeName sn+    hs = map nodeName subterms+    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs]+--}++-- Remove nodes that aren't in the list from the graph.+--+-- RCE: This is no longer necessary when NDP is supported.+cleanCounts :: NodeCounts -> NodeCounts+cleanCounts (ns, g) = (ns, Map.fromList $ [(h, Set.filter (flip elem hs) (g Map.! h)) | h <- hs ])+  where+    hs = (map nodeName ns)++nodeName :: NodeCount -> NodeName+nodeName (AccNodeCount (StableSharingAcc (StableNameHeight sn _) _) _) = NodeName sn+nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeName sn+-- nodeName (SeqNodeCount (StableSharingSeq (StableNameHeight sn _) _) _) = NodeName sn++-- Combine node counts that belong to the same node.+--+-- * We assume that the list invariant —subterms follow their parents— holds for both arguments and+--   guarantee that it still holds for the result.+-- * In the same manner, we assume that all 'Exp' node counts precede 'Acc' node counts and+--   guarantee that this also hold for the result.+--+-- RCE: The list combination should be able to be performed as a more efficient merge.+--+(+++) :: NodeCounts -> NodeCounts -> NodeCounts+(ns1,g1) +++ (ns2,g2) = (foldr insert ns1 ns2, Map.unionWith Set.union g1 g2)+  where+    insert x               []                         = [x]+    insert x@(AccNodeCount sa1 count1) ys@(y@(AccNodeCount sa2 count2) : ys')+      | sa1 == sa2          = AccNodeCount (sa1 `pickNoneAvar` sa2) (count1 + count2) : ys'+      | sa1 `higherSSA` sa2 = x : ys+      | otherwise           = y : insert x ys'+    insert x@(ExpNodeCount se1 count1) ys@(y@(ExpNodeCount se2 count2) : ys')+      | se1 == se2          = ExpNodeCount (se1 `pickNoneVar` se2) (count1 + count2) : ys'+      | se1 `higherSSE` se2 = x : ys+      | otherwise           = y : insert x ys'+    -- insert x@(SeqNodeCount se1 count1) ys@(y@(SeqNodeCount se2 count2) : ys')+    --   | se1 == se2          = SeqNodeCount (se1 `pickNoneSvar` se2) (count1 + count2) : ys'+    --   | se1 `higherSSS` se2 = x : ys+    --   | otherwise           = y : insert x ys'+    insert x@(AccNodeCount _ _) (y@(ExpNodeCount _ _) : ys')+      = y : insert x ys'+    insert x@(ExpNodeCount _ _) (y@(AccNodeCount _ _) : ys')+      = x : insert y ys'+    -- insert x@(SeqNodeCount _ _) (y@(ExpNodeCount _ _) : ys')+    --   = y : insert x ys'+    -- insert x@(ExpNodeCount _ _) (y@(SeqNodeCount _ _) : ys')+    --   = x : insert y ys'+    -- insert x@(AccNodeCount _ _) (y@(SeqNodeCount _ _) : ys')+    --   = y : insert x ys'+    -- insert x@(SeqNodeCount _ _) (y@(AccNodeCount _ _) : ys')+    --   = x : insert y ys'++    (StableSharingAcc _ (AvarSharing _)) `pickNoneAvar` sa2  = sa2+    sa1                                  `pickNoneAvar` _sa2 = sa1++    (StableSharingExp _ (VarSharing _))  `pickNoneVar`  sa2  = sa2+    sa1                                  `pickNoneVar`  _sa2 = sa1++    -- pickNoneSvar :: StableSharingSeq -> StableSharingSeq -> StableSharingSeq+    -- (StableSharingSeq _ (SvarSharing _)) `pickNoneSvar` sa2  = sa2+    -- sa1                                  `pickNoneSvar` _sa2 = sa1++-- Build an initial environment for the tag values given in the first argument for traversing an+-- array expression.  The 'StableSharingAcc's for all tags /actually used/ in the expressions are+-- in the second argument. (Tags are not used if a bound variable has no usage occurrence.)+--+-- Bail out if any tag occurs multiple times as this indicates that the sharing of an argument+-- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments+-- at 'determineScopesAcc'.+--+buildInitialEnvAcc :: [Level] -> [StableSharingAcc] -> [StableSharingAcc]+buildInitialEnvAcc tags sas = map (lookupSA sas) tags+  where+    lookupSA sas tag1+      = case filter hasTag sas of+          []   -> noStableSharing    -- tag is not used in the analysed expression+          [sa] -> sa                 -- tag has a unique occurrence+          sas2 -> $internalError "buildInitialEnvAcc"+                $ "Encountered duplicate 'ATag's\n  " ++ intercalate ", " (map showSA sas2)+      where+        hasTag (StableSharingAcc _ (AccSharing _ (Atag tag2))) = tag1 == tag2+        hasTag sa+          = $internalError "buildInitialEnvAcc"+          $ "Encountered a node that is not a plain 'Atag'\n  " ++ showSA sa++        noStableSharing :: StableSharingAcc+        noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ())++    showSA (StableSharingAcc _ (AccSharing  sn acc)) = show (hashStableNameHeight sn) ++ ": " +++                                                       showPreAccOp acc+    showSA (StableSharingAcc _ (AvarSharing sn))     = "AvarSharing " ++ show (hashStableNameHeight sn)+    showSA (StableSharingAcc _ (AletSharing sa _ ))  = "AletSharing " ++ show sa ++ "..."++-- Build an initial environment for the tag values given in the first argument for traversing a+-- scalar expression.  The 'StableSharingExp's for all tags /actually used/ in the expressions are+-- in the second argument. (Tags are not used if a bound variable has no usage occurrence.)+--+-- Bail out if any tag occurs multiple times as this indicates that the sharing of an argument+-- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments+-- at 'determineScopesAcc'.+--+buildInitialEnvExp :: [Level] -> [StableSharingExp] -> [StableSharingExp]+buildInitialEnvExp tags ses = map (lookupSE ses) tags+  where+    lookupSE ses tag1+      = case filter hasTag ses of+          []   -> noStableSharing    -- tag is not used in the analysed expression+          [se] -> se                 -- tag has a unique occurrence+          ses2 -> $internalError "buildInitialEnvExp"+                    ("Encountered a duplicate 'Tag'\n  " ++ intercalate ", " (map showSE ses2))+      where+        hasTag (StableSharingExp _ (ExpSharing _ (Tag tag2))) = tag1 == tag2+        hasTag se+          = $internalError "buildInitialEnvExp"+              ("Encountered a node that is not a plain 'Tag'\n  " ++ showSE se)++        noStableSharing :: StableSharingExp+        noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp acc exp ())++    showSE (StableSharingExp _ (ExpSharing sn exp)) = show (hashStableNameHeight sn) ++ ": " +++                                                      showPreExpOp exp+    showSE (StableSharingExp _ (VarSharing sn))     = "VarSharing " ++ show (hashStableNameHeight sn)+    showSE (StableSharingExp _ (LetSharing se _ ))  = "LetSharing " ++ show se ++ "..."++-- Determine whether a 'NodeCount' is for an 'Atag' or 'Tag', which represent free variables.+--+isFreeVar :: NodeCount -> Bool+isFreeVar (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag _))) _) = True+isFreeVar (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag  _))) _) = True+isFreeVar _                                                             = False+++-- Determine scope of shared subterms+-- ==================================++-- Determine the scopes of all variables representing shared subterms (Phase Two) in a bottom-up+-- sweep.  The first argument determines whether array computations are floated out of expressions+-- irrespective of whether they are shared or not — 'True' implies floating them out.+--+-- In addition to the AST with sharing information, yield the 'StableSharingAcc's for all free+-- variables of 'rootAcc', which are represented by 'Atag' leaves in the tree. They are in order of+-- the tag values — i.e., in the same order that they need to appear in an environment to use the+-- tag for indexing into that environment.+--+-- Precondition: there are only 'AvarSharing' and 'AccSharing' nodes in the argument.+--+determineScopesAcc+    :: Typeable a+    => Config+    -> [Level]+    -> OccMap Acc+    -> UnscopedAcc a+    -> (ScopedAcc a, [StableSharingAcc])+determineScopesAcc config fvs accOccMap rootAcc+  = let (sharingAcc, (counts, _)) = determineScopesSharingAcc config accOccMap rootAcc+        unboundTrees              = filter (not . isFreeVar) counts+    in+    if all isFreeVar counts+       then (sharingAcc, buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- counts])+       else $internalError "determineScopesAcc" ("unbound shared subtrees" ++ show unboundTrees)+++determineScopesSharingAcc+    :: Config+    -> OccMap Acc+    -> UnscopedAcc a+    -> (ScopedAcc a, NodeCounts)+determineScopesSharingAcc config accOccMap = scopesAcc+  where+    scopesAcc :: forall arrs. UnscopedAcc arrs -> (ScopedAcc arrs, NodeCounts)+    scopesAcc (UnscopedAcc _ (AletSharing _ _))+      = $internalError "determineScopesSharingAcc: scopesAcc" "unexpected 'AletSharing'"++    scopesAcc (UnscopedAcc _ (AvarSharing sn))+      = (ScopedAcc [] (AvarSharing sn), StableSharingAcc sn (AvarSharing sn) `insertAccNode` noNodeCounts)++    scopesAcc (UnscopedAcc _ (AccSharing sn pacc))+      = case pacc of+          Atag i                  -> reconstruct (Atag i) noNodeCounts+          Pipe afun1 afun2 acc    -> let+                                       (afun1', accCount1) = scopesAfun1 afun1+                                       (afun2', accCount2) = scopesAfun1 afun2+                                       (acc', accCount3)   = scopesAcc acc+                                     in+                                     reconstruct (Pipe afun1' afun2' acc')+                                                 (accCount1 +++ accCount2 +++ accCount3)++          Aforeign ff afun acc    -> let+                                       (acc', accCount) = scopesAcc acc+                                     in+                                     reconstruct (Aforeign ff afun acc') accCount+          Acond e acc1 acc2       -> let+                                       (e'   , accCount1) = scopesExp e+                                       (acc1', accCount2) = scopesAcc acc1+                                       (acc2', accCount3) = scopesAcc acc2+                                     in+                                     reconstruct (Acond e' acc1' acc2')+                                                 (accCount1 +++ accCount2 +++ accCount3)++          Awhile pred iter init   -> let+                                       (pred', accCount1) = scopesAfun1 pred+                                       (iter', accCount2) = scopesAfun1 iter+                                       (init', accCount3) = scopesAcc init+                                     in+                                     reconstruct (Awhile pred' iter' init')+                                                 (accCount1 +++ accCount2 +++ accCount3)++          Atuple tup              -> let (tup', accCount) = travAtup tup+                                     in  reconstruct (Atuple tup') accCount+          Aprj ix a               -> travA (Aprj ix) a++          Use arr                 -> reconstruct (Use arr) noNodeCounts+          Unit e                  -> let+                                       (e', accCount) = scopesExp e+                                     in+                                     reconstruct (Unit e') accCount+          Generate sh f           -> let+                                       (sh', accCount1) = scopesExp sh+                                       (f' , accCount2) = scopesFun1 f+                                     in+                                     reconstruct (Generate sh' f') (accCount1 +++ accCount2)+          Reshape sh acc          -> travEA Reshape sh acc+          Replicate n acc         -> travEA Replicate n acc+          Slice acc i             -> travEA (flip Slice) i acc+          Map f acc               -> let+                                       (f'  , accCount1) = scopesFun1 f+                                       (acc', accCount2) = scopesAcc  acc+                                     in+                                     reconstruct (Map f' acc') (accCount1 +++ accCount2)+          ZipWith f acc1 acc2     -> travF2A2 ZipWith f acc1 acc2+          Fold f z acc            -> travF2EA Fold f z acc+          Fold1 f acc             -> travF2A Fold1 f acc+          FoldSeg f z acc1 acc2   -> let+                                       (f'   , accCount1)  = scopesFun2 f+                                       (z'   , accCount2)  = scopesExp  z+                                       (acc1', accCount3)  = scopesAcc  acc1+                                       (acc2', accCount4)  = scopesAcc  acc2+                                     in+                                     reconstruct (FoldSeg f' z' acc1' acc2')+                                       (accCount1 +++ accCount2 +++ accCount3 +++ accCount4)+          Fold1Seg f acc1 acc2    -> travF2A2 Fold1Seg f acc1 acc2+          Scanl f z acc           -> travF2EA Scanl f z acc+          Scanl' f z acc          -> travF2EA Scanl' f z acc+          Scanl1 f acc            -> travF2A Scanl1 f acc+          Scanr f z acc           -> travF2EA Scanr f z acc+          Scanr' f z acc          -> travF2EA Scanr' f z acc+          Scanr1 f acc            -> travF2A Scanr1 f acc+          Permute fc acc1 fp acc2 -> let+                                       (fc'  , accCount1) = scopesFun2 fc+                                       (acc1', accCount2) = scopesAcc  acc1+                                       (fp'  , accCount3) = scopesFun1 fp+                                       (acc2', accCount4) = scopesAcc  acc2+                                     in+                                     reconstruct (Permute fc' acc1' fp' acc2')+                                       (accCount1 +++ accCount2 +++ accCount3 +++ accCount4)+          Backpermute sh fp acc   -> let+                                       (sh' , accCount1) = scopesExp  sh+                                       (fp' , accCount2) = scopesFun1 fp+                                       (acc', accCount3) = scopesAcc  acc+                                     in+                                     reconstruct (Backpermute sh' fp' acc')+                                       (accCount1 +++ accCount2 +++ accCount3)+          Stencil st bnd acc      -> let+                                       (st' , accCount1) = scopesStencil1 acc st+                                       (bnd', accCount2) = scopesBoundary bnd+                                       (acc', accCount3) = scopesAcc acc+                                     in+                                     reconstruct (Stencil st' bnd' acc') (accCount1 +++ accCount2 +++ accCount3)+          Stencil2 st bnd1 acc1 bnd2 acc2+                                  -> let+                                       (st'  , accCount1) = scopesStencil2 acc1 acc2 st+                                       (bnd1', accCount2) = scopesBoundary bnd1+                                       (acc1', accCount3) = scopesAcc acc1+                                       (bnd2', accCount4) = scopesBoundary bnd2+                                       (acc2', accCount5) = scopesAcc acc2+                                     in+                                     reconstruct (Stencil2 st' bnd1' acc1' bnd2' acc2')+                                       (accCount1 +++ accCount2 +++ accCount3 +++ accCount4 +++ accCount5)+          -- Collect seq             -> let+          --                              (seq', accCount1) = scopesSeq seq+          --                            in+          --                            reconstruct (Collect seq') accCount1++      where+        travEA :: (ScopedExp e -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)+               -> RootExp e+               -> UnscopedAcc arrs'+               -> (ScopedAcc arrs, NodeCounts)+        travEA c e acc = reconstruct (c e' acc') (accCount1 +++ accCount2)+          where+            (e'  , accCount1) = scopesExp e+            (acc', accCount2) = scopesAcc acc++        travF2A :: (Elt a, Elt b)+                => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs'+                    -> PreAcc ScopedAcc ScopedExp arrs)+                -> (Exp a -> Exp b -> RootExp c)+                -> UnscopedAcc arrs'+                -> (ScopedAcc arrs, NodeCounts)+        travF2A c f acc = reconstruct (c f' acc') (accCount1 +++ accCount2)+          where+            (f'  , accCount1) = scopesFun2 f+            (acc', accCount2) = scopesAcc  acc++        travF2EA :: (Elt a, Elt b)+                 => ((Exp a -> Exp b -> ScopedExp c) -> ScopedExp e+                     -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)+                 -> (Exp a -> Exp b -> RootExp c)+                 -> RootExp e+                 -> UnscopedAcc arrs'+                 -> (ScopedAcc arrs, NodeCounts)+        travF2EA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3)+          where+            (f'  , accCount1) = scopesFun2 f+            (e'  , accCount2) = scopesExp  e+            (acc', accCount3) = scopesAcc  acc++        travF2A2 :: (Elt a, Elt b)+                 => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs1+                     -> ScopedAcc arrs2 -> PreAcc ScopedAcc ScopedExp arrs)+                 -> (Exp a -> Exp b -> RootExp c)+                 -> UnscopedAcc arrs1+                 -> UnscopedAcc arrs2+                 -> (ScopedAcc arrs, NodeCounts)+        travF2A2 c f acc1 acc2 = reconstruct (c f' acc1' acc2')+                                             (accCount1 +++ accCount2 +++ accCount3)+          where+            (f'   , accCount1) = scopesFun2 f+            (acc1', accCount2) = scopesAcc  acc1+            (acc2', accCount3) = scopesAcc  acc2++        travAtup ::  Atuple UnscopedAcc a+                 -> (Atuple ScopedAcc a, NodeCounts)+        travAtup NilAtup          = (NilAtup, noNodeCounts)+        travAtup (SnocAtup tup a) = let (tup', accCountT) = travAtup tup+                                        (a',   accCountA) = scopesAcc a+                                    in+                                    (SnocAtup tup' a', accCountT +++ accCountA)++        travA :: (ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)+              -> UnscopedAcc arrs'+              -> (ScopedAcc arrs, NodeCounts)+        travA c acc = reconstruct (c acc') accCount+          where+            (acc', accCount) = scopesAcc acc++          -- Occurrence count of the currently processed node+        accOccCount = let StableNameHeight sn' _ = sn+                      in+                      lookupWithASTName accOccMap (StableASTName sn')++        -- Reconstruct the current tree node.+        --+        -- * If the current node is being shared ('accOccCount > 1'), replace it by a 'AvarSharing'+        --   node and float the shared subtree out wrapped in a 'NodeCounts' value.+        -- * If the current node is not shared, reconstruct it in place.+        -- * Special case for free variables ('Atag'): Replace the tree by a sharing variable and+        --   float the 'Atag' out in a 'NodeCounts' value.  This is independent of the number of+        --   occurrences.+        --+        -- In either case, any completed 'NodeCounts' are injected as bindings using 'AletSharing'+        -- node.+        --+        reconstruct :: PreAcc ScopedAcc ScopedExp arrs+                    -> NodeCounts+                    -> (ScopedAcc arrs, NodeCounts)+        reconstruct newAcc@(Atag _) _subCount+              -- free variable => replace by a sharing variable regardless of the number of+              -- occurrences+          = let thisCount = StableSharingAcc sn (AccSharing sn newAcc) `insertAccNode` noNodeCounts+            in+            tracePure "FREE" (show thisCount)+            (ScopedAcc [] (AvarSharing sn), thisCount)+        reconstruct newAcc subCount+              -- shared subtree => replace by a sharing variable (if 'recoverAccSharing' enabled)+          | accOccCount > 1 && recoverAccSharing config+          = let allCount = (StableSharingAcc sn sharingAcc `insertAccNode` newCount)+            in+            tracePure ("SHARED" ++ completed) (show allCount)+            (ScopedAcc [] (AvarSharing sn), allCount)+              -- neither shared nor free variable => leave it as it is+          | otherwise+          = tracePure ("Normal" ++ completed) (show newCount)+            (ScopedAcc [] sharingAcc, newCount)+          where+              -- Determine the bindings that need to be attached to the current node...+            (newCount, bindHere) = filterCompleted subCount++              -- ...and wrap them in 'AletSharing' constructors+            lets       = foldl (flip (.)) id . map (\x y -> AletSharing x (ScopedAcc [] y)) $ bindHere+            sharingAcc = lets $ AccSharing sn newAcc++              -- trace support+            completed | null bindHere = ""+                      | otherwise     = "(" ++ show (length bindHere) ++ " lets)"++        -- Extract *leading* nodes that have a complete node count (i.e., their node count is equal+        -- to the number of occurrences of that node in the overall expression).+        --+        -- Nodes with a completed node count should be let bound at the currently processed node.+        --+        -- NB: Only extract leading nodes (i.e., the longest run at the *front* of the list that is+        --     complete).  Otherwise, we would let-bind subterms before their parents, which leads+        --     scope errors.+        --+        filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingAcc])+        filterCompleted (ns, graph)+          = let bindable     = map (isBindable bindable (map nodeName ns)) ns+                (bind, rest) = partition fst $ zip bindable ns+            in ((map snd rest, graph), [sa | AccNodeCount sa _ <- map snd bind])+          where+            -- a node is not yet complete while the node count 'n' is below the overall number+            -- of occurrences for that node in the whole program, with the exception that free+            -- variables are never complete+            isCompleted nc@(AccNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingAcc accOccMap sa == n+            isCompleted _                                             = False++            isBindable :: [Bool] -> [NodeName] -> NodeCount -> Bool+            isBindable bindable nodes nc@(AccNodeCount _ _) =+              let superTerms = Set.toList $ graph Map.! nodeName nc+                  unbound    = mapMaybe (`elemIndex` nodes) superTerms+              in    isCompleted nc+                 && all (bindable !!) unbound+            isBindable _ _ (ExpNodeCount _ _) = False+            -- isBindable _ _ (SeqNodeCount _ _) = False++    -- scopesSeq :: forall arrs. RootSeq arrs -> (ScopedSeq arrs, NodeCounts)+    -- scopesSeq = determineScopesSeq config accOccMap++    scopesExp :: RootExp t -> (ScopedExp t, NodeCounts)+    scopesExp = determineScopesExp config accOccMap++    -- The lambda bound variable is at this point already irrelevant; for details, see+    -- Note [Traversing functions and side effects]+    --+    scopesAfun1 :: Arrays a1 => (Acc a1 -> UnscopedAcc a2) -> (Acc a1 -> ScopedAcc a2, NodeCounts)+    scopesAfun1 f = (const (ScopedAcc ssa body'), (counts',graph))+      where+        body@(UnscopedAcc fvs _) = f undefined+        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body+        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]+        (freeCounts, counts') = partition isBoundHere counts++        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs+        isBoundHere _                                                             = False++    -- The lambda bound variable is at this point already irrelevant; for details, see+    -- Note [Traversing functions and side effects]+    --+    scopesFun1 :: Elt e1 => (Exp e1 -> RootExp e2) -> (Exp e1 -> ScopedExp e2, NodeCounts)+    scopesFun1 f = (const body, counts)+      where+        (body, counts) = scopesExp (f undefined)++    -- The lambda bound variable is at this point already irrelevant; for details, see+    -- Note [Traversing functions and side effects]+    --+    scopesFun2 :: (Elt e1, Elt e2)+               => (Exp e1 -> Exp e2 -> RootExp e3)+               -> (Exp e1 -> Exp e2 -> ScopedExp e3, NodeCounts)+    scopesFun2 f = (\_ _ -> body, counts)+      where+        (body, counts) = scopesExp (f undefined undefined)++    -- The lambda bound variable is at this point already irrelevant; for details, see+    -- Note [Traversing functions and side effects]+    --+    scopesStencil1 :: forall sh e1 e2 stencil. Stencil sh e1 stencil+                   => UnscopedAcc (Array sh e1){-dummy-}+                   -> (stencil -> RootExp e2)+                   -> (stencil -> ScopedExp e2, NodeCounts)+    scopesStencil1 _ stencilFun = (const body, counts)+      where+        (body, counts) = scopesExp (stencilFun undefined)++    -- The lambda bound variable is at this point already irrelevant; for details, see+    -- Note [Traversing functions and side effects]+    --+    scopesStencil2 :: forall sh e1 e2 e3 stencil1 stencil2.+                      (Stencil sh e1 stencil1, Stencil sh e2 stencil2)+                   => UnscopedAcc (Array sh e1){-dummy-}+                   -> UnscopedAcc (Array sh e2){-dummy-}+                   -> (stencil1 -> stencil2 -> RootExp e3)+                   -> (stencil1 -> stencil2 -> ScopedExp e3, NodeCounts)+    scopesStencil2 _ _ stencilFun = (\_ _ -> body, counts)+      where+        (body, counts) = scopesExp (stencilFun undefined undefined)++    scopesBoundary :: PreBoundary UnscopedAcc RootExp t+                   -> (PreBoundary ScopedAcc ScopedExp t, NodeCounts)+    scopesBoundary bndy =+      case bndy of+        Clamp      -> (Clamp, noNodeCounts)+        Mirror     -> (Mirror, noNodeCounts)+        Wrap       -> (Wrap, noNodeCounts)+        Constant v -> (Constant v, noNodeCounts)+        Function f -> let (body, counts) = scopesFun1 f+                      in  (Function body, counts)+++determineScopesExp+    :: Config+    -> OccMap Acc+    -> RootExp t+    -> (ScopedExp t, NodeCounts)          -- Root (closed) expression plus Acc node counts+determineScopesExp config accOccMap (RootExp expOccMap exp@(UnscopedExp fvs _))+  = let+        ((ScopedExp [] expWithScopes), (nodeCounts,graph)) = determineScopesSharingExp config accOccMap expOccMap exp+        (expCounts, accCounts)          = partition isExpNodeCount nodeCounts++        isExpNodeCount ExpNodeCount{}   = True+        isExpNodeCount _                = False+    in+    (ScopedExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, cleanCounts (accCounts,graph))+++determineScopesSharingExp+    :: Config+    -> OccMap Acc+    -> OccMap Exp+    -> UnscopedExp t+    -> (ScopedExp t, NodeCounts)+determineScopesSharingExp config accOccMap expOccMap = scopesExp+  where+    scopesAcc :: UnscopedAcc a -> (ScopedAcc a, NodeCounts)+    scopesAcc = determineScopesSharingAcc config accOccMap++    scopesFun1 :: (Exp a -> UnscopedExp b) -> (Exp a -> ScopedExp b, NodeCounts)+    scopesFun1 f = tracePure ("LAMBDA " ++ (show ssa)) (show counts) (const (ScopedExp ssa body'), (counts',graph))+      where+        body@(UnscopedExp fvs _) = f undefined+        ((ScopedExp [] body'), (counts, graph)) = scopesExp body+        ssa     = buildInitialEnvExp fvs [se | ExpNodeCount se _ <- freeCounts]+        (freeCounts, counts') = partition isBoundHere counts++        isBoundHere (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag i))) _) = i `elem` fvs+        isBoundHere _                                                            = False+++    scopesExp :: forall t. UnscopedExp t -> (ScopedExp t, NodeCounts)+    scopesExp (UnscopedExp _ (LetSharing _ _))+      = $internalError "determineScopesSharingExp: scopesExp" "unexpected 'LetSharing'"++    scopesExp (UnscopedExp _ (VarSharing sn))+      = (ScopedExp [] (VarSharing sn), StableSharingExp sn (VarSharing sn) `insertExpNode` noNodeCounts)++    scopesExp (UnscopedExp _ (ExpSharing sn pexp))+      = case pexp of+          Tag i                 -> reconstruct (Tag i) noNodeCounts+          Const c               -> reconstruct (Const c) noNodeCounts+          Undef                 -> reconstruct Undef noNodeCounts+          Tuple tup             -> let (tup', accCount) = travTup tup+                                   in+                                   reconstruct (Tuple tup') accCount+          Prj i e               -> travE1 (Prj i) e+          IndexNil              -> reconstruct IndexNil noNodeCounts+          IndexCons ix i        -> travE2 IndexCons ix i+          IndexHead i           -> travE1 IndexHead i+          IndexTail ix          -> travE1 IndexTail ix+          IndexAny              -> reconstruct IndexAny noNodeCounts+          ToIndex sh ix         -> travE2 ToIndex sh ix+          FromIndex sh e        -> travE2 FromIndex sh e+          Cond e1 e2 e3         -> travE3 Cond e1 e2 e3+          While p it i          -> let+                                     (p' , accCount1) = scopesFun1 p+                                     (it', accCount2) = scopesFun1 it+                                     (i' , accCount3) = scopesExp i+                                   in reconstruct (While p' it' i') (accCount1 +++ accCount2 +++ accCount3)+          PrimConst c           -> reconstruct (PrimConst c) noNodeCounts+          PrimApp p e           -> travE1 (PrimApp p) e+          Index a e             -> travAE Index a e+          LinearIndex a e       -> travAE LinearIndex a e+          Shape a               -> travA Shape a+          ShapeSize e           -> travE1 ShapeSize e+          Intersect sh1 sh2     -> travE2 Intersect sh1 sh2+          Union sh1 sh2         -> travE2 Union sh1 sh2+          Foreign ff f e        -> travE1 (Foreign ff f) e+          Coerce e              -> travE1 Coerce e+      where+        travTup :: Tuple UnscopedExp tup -> (Tuple ScopedExp tup, NodeCounts)+        travTup NilTup          = (NilTup, noNodeCounts)+        travTup (SnocTup tup e) = let+                                    (tup', accCountT) = travTup tup+                                    (e'  , accCountE) = scopesExp e+                                  in+                                  (SnocTup tup' e', accCountT +++ accCountE)++        travE1 :: (ScopedExp a -> PreExp ScopedAcc ScopedExp t) -> UnscopedExp a+               -> (ScopedExp t, NodeCounts)+        travE1 c e = reconstruct (c e') accCount+          where+            (e', accCount) = scopesExp e++        travE2 :: (ScopedExp a -> ScopedExp b -> PreExp ScopedAcc ScopedExp t)+               -> UnscopedExp a+               -> UnscopedExp b+               -> (ScopedExp t, NodeCounts)+        travE2 c e1 e2 = reconstruct (c e1' e2') (accCount1 +++ accCount2)+          where+            (e1', accCount1) = scopesExp e1+            (e2', accCount2) = scopesExp e2++        travE3 :: (ScopedExp a -> ScopedExp b -> ScopedExp c -> PreExp ScopedAcc ScopedExp t)+               -> UnscopedExp a+               -> UnscopedExp b+               -> UnscopedExp c+               -> (ScopedExp t, NodeCounts)+        travE3 c e1 e2 e3 = reconstruct (c e1' e2' e3') (accCount1 +++ accCount2 +++ accCount3)+          where+            (e1', accCount1) = scopesExp e1+            (e2', accCount2) = scopesExp e2+            (e3', accCount3) = scopesExp e3++        travA :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t) -> UnscopedAcc a+              -> (ScopedExp t, NodeCounts)+        travA c acc = maybeFloatOutAcc c acc' accCount+          where+            (acc', accCount)  = scopesAcc acc++        travAE :: (ScopedAcc a -> ScopedExp b -> PreExp ScopedAcc ScopedExp t)+               -> UnscopedAcc a+               -> UnscopedExp b+               -> (ScopedExp t, NodeCounts)+        travAE c acc e = maybeFloatOutAcc (`c` e') acc' (accCountA +++ accCountE)+          where+            (acc', accCountA) = scopesAcc acc+            (e'  , accCountE) = scopesExp e++        maybeFloatOutAcc :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t)+                         -> ScopedAcc a+                         -> NodeCounts+                         -> (ScopedExp t, NodeCounts)+        maybeFloatOutAcc c acc@(ScopedAcc _ (AvarSharing _)) accCount        -- nothing to float out+          = reconstruct (c acc) accCount+        maybeFloatOutAcc c acc                 accCount+          | floatOutAcc config = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount)+          | otherwise          = reconstruct (c acc) accCount+          where+             (var, stableAcc) = abstract acc (\(ScopedAcc _ s) -> s)++        abstract :: ScopedAcc a -> (ScopedAcc a -> SharingAcc ScopedAcc ScopedExp a)+                 -> (ScopedAcc a, StableSharingAcc)+        abstract (ScopedAcc _ (AvarSharing _))       _      = $internalError "sharingAccToVar" "AvarSharing"+        abstract (ScopedAcc ssa (AletSharing sa acc))  lets = abstract acc (lets . (\x -> ScopedAcc ssa (AletSharing sa x)))+        abstract acc@(ScopedAcc ssa (AccSharing sn _)) lets = (ScopedAcc ssa (AvarSharing sn), StableSharingAcc sn (lets acc))++        -- Occurrence count of the currently processed node+        expOccCount = let StableNameHeight sn' _ = sn+                      in+                      lookupWithASTName expOccMap (StableASTName sn')++        -- Reconstruct the current tree node.+        --+        -- * If the current node is being shared ('expOccCount > 1'), replace it by a 'VarSharing'+        --   node and float the shared subtree out wrapped in a 'NodeCounts' value.+        -- * If the current node is not shared, reconstruct it in place.+        -- * Special case for free variables ('Tag'): Replace the tree by a sharing variable and+        --   float the 'Tag' out in a 'NodeCounts' value.  This is independent of the number of+        --   occurrences.+        --+        -- In either case, any completed 'NodeCounts' are injected as bindings using 'LetSharing'+        -- node.+        --+        reconstruct :: PreExp ScopedAcc ScopedExp t -> NodeCounts+                    -> (ScopedExp t, NodeCounts)+        reconstruct newExp@(Tag _) _subCount+              -- free variable => replace by a sharing variable regardless of the number of+              -- occurrences+          = let thisCount = StableSharingExp sn (ExpSharing sn newExp) `insertExpNode` noNodeCounts+            in+            tracePure "FREE" (show thisCount)+            (ScopedExp [] (VarSharing sn), thisCount)+        reconstruct newExp subCount+              -- shared subtree => replace by a sharing variable (if 'recoverExpSharing' enabled)+          | expOccCount > 1 && recoverExpSharing config+          = let allCount = StableSharingExp sn sharingExp `insertExpNode` newCount+            in+            tracePure ("SHARED" ++ completed) (show allCount)+            (ScopedExp [] (VarSharing sn), allCount)+              -- neither shared nor free variable => leave it as it is+          | otherwise+          = tracePure ("Normal" ++ completed) (show newCount)+            (ScopedExp [] sharingExp, newCount)+          where+              -- Determine the bindings that need to be attached to the current node...+            (newCount, bindHere) = filterCompleted subCount++              -- ...and wrap them in 'LetSharing' constructors+            lets       = foldl (flip (.)) id . map (\x y -> LetSharing x (ScopedExp [] y)) $ bindHere+            sharingExp = lets $ ExpSharing sn newExp++              -- trace support+            completed | null bindHere = ""+                      | otherwise     = "(" ++ show (length bindHere) ++ " lets)"++        -- Extract *leading* nodes that have a complete node count (i.e., their node count is equal+        -- to the number of occurrences of that node in the overall expression).+        --+        -- Nodes with a completed node count should be let bound at the currently processed node.+        --+        -- NB: Only extract leading nodes (i.e., the longest run at the *front* of the list that is+        --     complete).  Otherwise, we would let-bind subterms before their parents, which leads+        --     scope errors.+        --+        filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingExp])+        filterCompleted (ns,graph)+          = let bindable       = map (isBindable bindable (map nodeName ns)) ns+                (bind, unbind) = partition fst $ zip bindable ns+            in ((map snd unbind, graph), [se | ExpNodeCount se _ <- map snd bind])+          where+            -- a node is not yet complete while the node count 'n' is below the overall number+            -- of occurrences for that node in the whole program, with the exception that free+            -- variables are never complete+            isCompleted nc@(ExpNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingExp expOccMap sa == n+            isCompleted _                                             = False++            isBindable :: [Bool] -> [NodeName] -> NodeCount -> Bool+            isBindable bindable nodes nc@(ExpNodeCount _ _) =+              let superTerms = Set.toList $ graph Map.! nodeName nc+                  unbound    = mapMaybe (`elemIndex` nodes) superTerms+              in    isCompleted nc+                 && all (bindable !!) unbound+            isBindable _ _ (AccNodeCount _ _) = False+            -- isBindable _ _ (SeqNodeCount _ _) = False++{--+determineScopesSeq+    :: Config+    -> OccMap Acc+    -> RootSeq t+    -> (ScopedSeq t, NodeCounts)          -- Root (closed) expression plus Acc node counts+determineScopesSeq config accOccMap (RootSeq seqOccMap seq)+  = let+        (ScopedSeq seqWithScopes, (nodeCounts,graph)) = determineScopesSharingSeq config accOccMap seqOccMap seq+        binds      = [s | SeqNodeCount s _ <- nodeCounts]+        lets       = foldl (flip (.)) id . map (\x y -> SletSharing x (ScopedSeq y)) $ binds+        sharingSeq = lets seqWithScopes+        newCounts  = filter (not . isSeqCount) nodeCounts+        isSeqCount SeqNodeCount{} = True+        isSeqCount _              = False+    in+    (ScopedSeq sharingSeq, cleanCounts (newCounts,graph))++determineScopesSharingSeq+  :: Config+  -> OccMap Acc+  -> OccMap Seq+  -> UnscopedSeq t+  -> (ScopedSeq t, NodeCounts)+determineScopesSharingSeq config accOccMap _seqOccMap = scopesSeq+  where+    scopesAcc :: UnscopedAcc a -> (ScopedAcc a, NodeCounts)+    scopesAcc = determineScopesSharingAcc config accOccMap++    scopesExp :: RootExp t -> (ScopedExp t, NodeCounts)+    scopesExp = determineScopesExp config accOccMap++    scopesFun2 :: (Elt e1, Elt e2)+               => (Exp e1 -> Exp e2 -> RootExp e3)+               -> (Exp e1 -> Exp e2 -> ScopedExp e3, NodeCounts)+    scopesFun2 f = (\_ _ -> body, counts)+      where+        (body, counts) = scopesExp (f undefined undefined)++    -- The lambda bound variable is at this point already irrelevant; for details, see+    -- Note [Traversing functions and side effects]+    --+    scopesAfun1 :: Arrays a1 => (Acc a1 -> UnscopedAcc a2) -> (Acc a1 -> ScopedAcc a2, NodeCounts)+    scopesAfun1 f = (const (ScopedAcc ssa body'), (counts',graph))+      where+        body@(UnscopedAcc fvs _) = f undefined+        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body+        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]+        (freeCounts, counts') = partition isBoundHere counts++        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs+        isBoundHere _                                                             = False++    scopesAfun2 :: (Arrays a1, Arrays a2) => (Acc a1 -> Acc a2 -> UnscopedAcc a3) -> (Acc a1 -> Acc a2 -> ScopedAcc a3, NodeCounts)+    scopesAfun2 f = (\ _ _ -> (ScopedAcc ssa body'), (counts',graph))+      where+        body@(UnscopedAcc fvs _) = f undefined undefined+        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body+        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]+        (freeCounts, counts') = partition isBoundHere counts++        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs+        isBoundHere _                                                             = False++    scopesAfun3 :: (Arrays a1, Arrays a2, Arrays a3) => (Acc a1 -> Acc a2 -> Acc a3 -> UnscopedAcc a4) -> (Acc a1 -> Acc a2 -> Acc a3 -> ScopedAcc a4, NodeCounts)+    scopesAfun3 f = (\ _ _ _ -> (ScopedAcc ssa body'), (counts',graph))+      where+        body@(UnscopedAcc fvs _) = f undefined undefined undefined+        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body+        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]+        (freeCounts, counts') = partition isBoundHere counts++        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs+        isBoundHere _                                                             = False++    scopesTup :: Atuple UnscopedSeq tup -> (Atuple ScopedSeq tup, NodeCounts)+    scopesTup NilAtup          = (NilAtup, noNodeCounts)+    scopesTup (SnocAtup tup s) = let+                                   (tup', accCountT) = scopesTup tup+                                   (s'  , accCountS) = scopesSeq s+                                 in+                                 (SnocAtup tup' s', accCountT +++ accCountS)++    scopesSeq :: forall t. UnscopedSeq t -> (ScopedSeq t, NodeCounts)+    scopesSeq (UnscopedSeq (SletSharing _ _))+      = $internalError "determineScopesSharingSeq: scopesSeq" "unexpected 'LetSharing'"+    scopesSeq (UnscopedSeq (SvarSharing sn))+      = (ScopedSeq (SvarSharing sn), StableSharingSeq sn (SvarSharing sn) `insertSeqNode` noNodeCounts)++    scopesSeq (UnscopedSeq (SeqSharing sn s)) =+      case s of+        StreamIn arrs -> producer (StreamIn arrs) noNodeCounts+        ToSeq sl acc   -> let+                            (acc', accCount1) = scopesAcc acc+                          in producer (ToSeq sl acc') accCount1+        MapSeq     afun s'  -> let+                                 (afun', accCount1) = scopesAfun1 afun+                                 (s''  , accCount2) = scopesSeq s'+                               in producer (MapSeq afun' s'') (accCount1 +++ accCount2)+        ZipWithSeq afun s1 s2 -> let+                                   (afun', accCount1) = scopesAfun2 afun+                                   (s1'  , accCount2) = scopesSeq s1+                                   (s2'  , accCount3) = scopesSeq s2+                                 in producer (ZipWithSeq afun' s1' s2') (accCount1 +++ accCount2 +++ accCount3)+        ScanSeq fun e s' -> let+                              (fun', accCount1) = scopesFun2 fun+                              (e'  , accCount2) = scopesExp e+                              (s'' , accCount3) = scopesSeq s'+                            in producer (ScanSeq fun' e' s'') (accCount1 +++ accCount2 +++ accCount3)+        FoldSeq fun e s' -> let+                              (fun', accCount1) = scopesFun2 fun+                              (e'  , accCount2) = scopesExp e+                              (s'' , accCount3) = scopesSeq s'+                            in consumer (FoldSeq fun' e' s'') (accCount1 +++ accCount2 +++ accCount3)+        FoldSeqFlatten afun acc s' ->+                               let+                                 (afun', accCount1) = scopesAfun3 afun+                                 (acc' , accCount2) = scopesAcc acc+                                 (s''  , accCount3) = scopesSeq s'+                               in consumer (FoldSeqFlatten afun' acc' s'') (accCount1 +++ accCount2 +++ accCount3)+        Stuple tup          -> let+                                 (tup', accCount1) = scopesTup tup+                               in consumer (Stuple tup') accCount1+      where+        -- All producers must be replaced by sharing variables+        --+        producer :: (t ~ [a], Arrays a)+                 => PreSeq ScopedAcc ScopedSeq ScopedExp t+                 -> NodeCounts+                 -> (ScopedSeq t, NodeCounts)+        producer newSeq subCount+          = let allCount = StableSharingSeq sn (SeqSharing sn newSeq) `insertSeqNode` subCount+            in+            tracePure "Producer" (show allCount)+            (ScopedSeq (SvarSharing sn), allCount)++        -- Consumers cannot be shared.+        --+        consumer :: PreSeq ScopedAcc ScopedSeq ScopedExp t+                 -> NodeCounts+                 -> (ScopedSeq t, NodeCounts)+        consumer newSeq subCount+          = tracePure "Consumer" (show subCount)+            (ScopedSeq (SeqSharing sn newSeq), subCount)+--}++-- |Recover sharing information and annotate the HOAS AST with variable and let binding+-- annotations.  The first argument determines whether array computations are floated out of+-- expressions irrespective of whether they are shared or not — 'True' implies floating them out.+--+-- Also returns the 'StableSharingAcc's of all 'Atag' leaves in environment order — they represent+-- the free variables of the AST.+--+-- NB: Strictly speaking, this function is not deterministic, as it uses stable pointers to+--     determine the sharing of subterms.  The stable pointer API does not guarantee its+--     completeness; i.e., it may miss some equalities, which implies that we may fail to discover+--     some sharing.  However, sharing does not affect the denotational meaning of an array+--     computation; hence, we do not compromise denotational correctness.+--+--     There is one caveat: We currently rely on the 'Atag' and 'Tag' leaves representing free+--     variables to be shared if any of them is used more than once.  If one is duplicated, the+--     environment for de Bruijn conversion will have a duplicate entry, and hence, be of the wrong+--     size, which is fatal. (The 'buildInitialEnv*' functions will already bail out.)+--+{-# NOINLINE recoverSharingAcc #-}+recoverSharingAcc+    :: Typeable a+    => Config+    -> Level            -- The level of currently bound array variables+    -> [Level]          -- The tags of newly introduced free array variables+    -> Acc a+    -> (ScopedAcc a, [StableSharingAcc])+recoverSharingAcc config alvl avars acc+  = let (acc', occMap)+          = unsafePerformIO             -- to enable stable pointers; this is safe as explained above+          $ makeOccMapAcc config alvl acc+    in+    determineScopesAcc config avars occMap acc'+++{-# NOINLINE recoverSharingExp #-}+recoverSharingExp+    :: Typeable e+    => Config+    -> Level            -- The level of currently bound scalar variables+    -> [Level]          -- The tags of newly introduced free scalar variables+    -> Exp e+    -> (ScopedExp e, [StableSharingExp])+recoverSharingExp config lvl fvar exp+  = let+        (rootExp, accOccMap) = unsafePerformIO $ do+          accOccMap       <- newASTHashTable+          (exp', _)       <- makeOccMapRootExp config accOccMap lvl fvar exp+          frozenAccOccMap <- freezeOccMap accOccMap++          return (exp', frozenAccOccMap)++        (ScopedExp sse sharingExp, _) =+          determineScopesExp config accOccMap rootExp+    in+    (ScopedExp [] sharingExp, sse)+++{--+{-# NOINLINE recoverSharingSeq #-}+recoverSharingSeq+    :: Typeable e+    => Config+    -> Seq e+    -> (ScopedSeq e, [StableSharingSeq])+recoverSharingSeq config seq+  = let+        (rootSeq, accOccMap) = unsafePerformIO $ do+          accOccMap       <- newASTHashTable+          (seq', _)       <- makeOccMapRootSeq config accOccMap 0 seq+          frozenAccOccMap <- freezeOccMap accOccMap++          return (seq', frozenAccOccMap)++        (ScopedSeq sharingSeq, (ns, _)) =+          determineScopesSeq config accOccMap rootSeq+    in+    (ScopedSeq sharingSeq, [a | SeqNodeCount a _ <- ns])+--}+++-- Debugging+-- ---------++traceLine :: String -> String -> IO ()+traceLine header msg+  = Debug.traceIO Debug.dump_sharing+  $ header ++ ": " ++ msg++traceChunk :: String -> String -> IO ()+traceChunk header msg+  = Debug.traceIO Debug.dump_sharing+  $ header ++ "\n      " ++ msg++tracePure :: String -> String -> a -> a+tracePure header msg+  = Debug.trace Debug.dump_sharing+  $ header ++ ": " ++ msg+
+ src/Data/Array/Accelerate/Trafo/Shrink.hs view
@@ -0,0 +1,489 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+-- |+-- Module      : Data.Array.Accelerate.Trafo.Shrink+-- 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)+--+-- The shrinking substitution arises as a restriction of beta-reduction to cases+-- where the bound variable is used zero (dead-code elimination) or one (linear+-- inlining) times. By simplifying terms, the shrinking reduction can expose+-- opportunities for further optimisation.+--+-- TODO: replace with a linear shrinking algorithm; e.g.+--+--   * Andrew Appel & Trevor Jim, "Shrinking lambda expressions in linear time".+--+--   * Nick Benton, Andrew Kennedy, Sam Lindley and Claudio Russo, "Shrinking+--     Reductions in SML.NET"+--++module Data.Array.Accelerate.Trafo.Shrink (++  -- Shrinking+  Shrink(..),+  ShrinkAcc, shrinkPreAcc, basicReduceAcc,++  -- Occurrence counting+  UsesOfAcc, usesOfPreAcc, usesOfExp,++) where++-- standard library+import Data.Monoid+import Control.Applicative                              hiding ( Const )+import Prelude                                          hiding ( exp, seq )++-- friends+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Array.Sugar               hiding ( Any )+import Data.Array.Accelerate.Trafo.Base+import Data.Array.Accelerate.Trafo.Substitution++import qualified Data.Array.Accelerate.Debug            as Stats+++class Shrink f where+  shrink  :: f -> f+  shrink' :: f -> (Bool, f)++  shrink = snd . shrink'++instance Kit acc => Shrink (PreOpenExp acc env aenv e) where+  shrink' = shrinkExp++instance Kit acc => Shrink (PreOpenFun acc env aenv f) where+  shrink' = shrinkFun+++-- Shrinking+-- =========++-- The shrinking substitution for scalar expressions. This is a restricted+-- instance of beta-reduction to cases where the bound variable is used zero+-- (dead-code elimination) or one (linear inlining) times.+--+shrinkExp :: Kit acc => PreOpenExp acc env aenv t -> (Bool, PreOpenExp acc env aenv t)+shrinkExp = Stats.substitution "shrink exp" . first getAny . shrinkE+  where+    -- If the bound variable is used at most this many times, it will be inlined+    -- into the body. In cases where it is not used at all, this is equivalent+    -- to dead-code elimination.+    --+    lIMIT :: Int+    lIMIT = 1++    shrinkE :: Kit acc => PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t)+    shrinkE exp = case exp of+      Let bnd body+        | Var _ <- bnd  -> Stats.inline "Var"   . yes $ shrinkE (inline body bnd)+        | uses <= lIMIT -> Stats.betaReduce msg . yes $ shrinkE (inline (snd body') (snd bnd'))+        | otherwise     -> Let <$> bnd' <*> body'+        where+          bnd'  = shrinkE bnd+          body' = shrinkE body+          uses  = usesOfExp ZeroIdx (snd body')++          msg   = case uses of+            0 -> "dead exp"+            _ -> "inline exp"   -- forced inlining when lIMIT > 1+      --+      Var idx                   -> pure (Var idx)+      Const c                   -> pure (Const c)+      Undef                     -> pure Undef+      Tuple t                   -> Tuple <$> shrinkT t+      Prj tup e                 -> Prj tup <$> shrinkE e+      IndexNil                  -> pure IndexNil+      IndexCons sl sz           -> IndexCons <$> shrinkE sl <*> shrinkE sz+      IndexHead sh              -> IndexHead <$> shrinkE sh+      IndexTail sh              -> IndexTail <$> shrinkE sh+      IndexSlice x ix sh        -> IndexSlice x <$> shrinkE ix <*> shrinkE sh+      IndexFull x ix sl         -> IndexFull x <$> shrinkE ix <*> shrinkE sl+      IndexAny                  -> pure IndexAny+      ToIndex sh ix             -> ToIndex <$> shrinkE sh <*> shrinkE ix+      FromIndex sh i            -> FromIndex <$> shrinkE sh <*> shrinkE i+      Cond p t e                -> Cond <$> shrinkE p <*> shrinkE t <*> shrinkE e+      While p f x               -> While <$> shrinkF p <*> shrinkF f <*> shrinkE x+      PrimConst c               -> pure (PrimConst c)+      PrimApp f x               -> PrimApp f <$> shrinkE x+      Index a sh                -> Index a <$> shrinkE sh+      LinearIndex a i           -> LinearIndex a <$> shrinkE i+      Shape a                   -> pure (Shape a)+      ShapeSize sh              -> ShapeSize <$> shrinkE sh+      Intersect sh sz           -> Intersect <$> shrinkE sh <*> shrinkE sz+      Union sh sz               -> Union <$> shrinkE sh <*> shrinkE sz+      Foreign ff f e            -> Foreign ff <$> shrinkF f <*> shrinkE e+      Coerce e                  -> Coerce <$> shrinkE e++    shrinkT :: Kit acc => Tuple (PreOpenExp acc env aenv) t -> (Any, Tuple (PreOpenExp acc env aenv) t)+    shrinkT NilTup        = pure NilTup+    shrinkT (SnocTup t e) = SnocTup <$> shrinkT t <*> shrinkE e++    shrinkF :: Kit acc => PreOpenFun acc env aenv t -> (Any, PreOpenFun acc env aenv t)+    shrinkF = first Any . shrinkFun++    first :: (a -> a') -> (a,b) -> (a',b)+    first f (x,y) = (f x, y)++    yes :: (Any, x) -> (Any, x)+    yes (_, x) = (Any True, x)++shrinkFun :: Kit acc => PreOpenFun acc env aenv f -> (Bool, PreOpenFun acc env aenv f)+shrinkFun (Lam f)  = Lam  <$> shrinkFun f+shrinkFun (Body b) = Body <$> shrinkExp b+++-- The shrinking substitution for array computations. This is further limited to+-- dead-code elimination only, primarily because linear inlining may inline+-- array computations into scalar expressions, which is generally not desirable.+--+type ShrinkAcc acc = forall aenv a.   acc aenv a -> acc aenv a+type ReduceAcc acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Maybe (PreOpenAcc acc aenv t)++shrinkPreAcc+    :: forall acc aenv arrs. ShrinkAcc acc -> ReduceAcc acc+    -> PreOpenAcc acc aenv arrs+    -> PreOpenAcc acc aenv arrs+shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrink acc" shrinkA+  where+    shrinkA :: PreOpenAcc acc aenv' a -> PreOpenAcc acc aenv' a+    shrinkA pacc = case pacc of+      Alet bnd body+        | Just reduct <- reduceAcc bnd' body'   -> shrinkA reduct+        | otherwise                             -> Alet bnd' body'+        where+          bnd'  = shrinkAcc bnd+          body' = shrinkAcc body+      --+      Avar ix                   -> Avar ix+      Atuple tup                -> Atuple (shrinkAT tup)+      Aprj tup a                -> Aprj tup (shrinkAcc a)+      Apply f a                 -> Apply (shrinkAF f) (shrinkAcc a)+      Aforeign ff af a          -> Aforeign ff af (shrinkAcc a)+      Acond p t e               -> Acond (shrinkE p) (shrinkAcc t) (shrinkAcc e)+      Awhile p f a              -> Awhile (shrinkAF p) (shrinkAF f) (shrinkAcc a)+      Use a                     -> Use a+      Unit e                    -> Unit (shrinkE e)+      Reshape e a               -> Reshape (shrinkE e) (shrinkAcc a)+      Generate e f              -> Generate (shrinkE e) (shrinkF f)+      Transform sh ix f a       -> Transform (shrinkE sh) (shrinkF ix) (shrinkF f) (shrinkAcc a)+      Replicate sl slix a       -> Replicate sl (shrinkE slix) (shrinkAcc a)+      Slice sl a slix           -> Slice sl (shrinkAcc a) (shrinkE slix)+      Map f a                   -> Map (shrinkF f) (shrinkAcc a)+      ZipWith f a1 a2           -> ZipWith (shrinkF f) (shrinkAcc a1) (shrinkAcc a2)+      Fold f z a                -> Fold (shrinkF f) (shrinkE z) (shrinkAcc a)+      Fold1 f a                 -> Fold1 (shrinkF f) (shrinkAcc a)+      FoldSeg f z a b           -> FoldSeg (shrinkF f) (shrinkE z) (shrinkAcc a) (shrinkAcc b)+      Fold1Seg f a b            -> Fold1Seg (shrinkF f) (shrinkAcc a) (shrinkAcc b)+      Scanl f z a               -> Scanl (shrinkF f) (shrinkE z) (shrinkAcc a)+      Scanl' f z a              -> Scanl' (shrinkF f) (shrinkE z) (shrinkAcc a)+      Scanl1 f a                -> Scanl1 (shrinkF f) (shrinkAcc a)+      Scanr f z a               -> Scanr (shrinkF f) (shrinkE z) (shrinkAcc a)+      Scanr' f z a              -> Scanr' (shrinkF f) (shrinkE z) (shrinkAcc a)+      Scanr1 f a                -> Scanr1 (shrinkF f) (shrinkAcc a)+      Permute f1 a1 f2 a2       -> Permute (shrinkF f1) (shrinkAcc a1) (shrinkF f2) (shrinkAcc a2)+      Backpermute sh f a        -> Backpermute (shrinkE sh) (shrinkF f) (shrinkAcc a)+      Stencil f b a             -> Stencil (shrinkF f) b (shrinkAcc a)+      Stencil2 f b1 a1 b2 a2    -> Stencil2 (shrinkF f) b1 (shrinkAcc a1) b2 (shrinkAcc a2)+      -- Collect s                 -> Collect (shrinkS s)++{--+    shrinkS :: PreOpenSeq acc aenv' senv a -> PreOpenSeq acc aenv' senv a+    shrinkS seq =+      case seq of+        Producer p s -> Producer (shrinkP p) (shrinkS s)+        Consumer c   -> Consumer (shrinkC c)+        Reify ix     -> Reify ix++    shrinkP :: Producer acc aenv' senv a -> Producer acc aenv' senv a+    shrinkP p =+      case p of+        StreamIn arrs        -> StreamIn arrs+        ToSeq sl slix a      -> ToSeq sl slix (shrinkAcc a)+        MapSeq f x           -> MapSeq (shrinkAF f) x+        ChunkedMapSeq f x    -> ChunkedMapSeq (shrinkAF f) x+        ZipWithSeq f x y     -> ZipWithSeq (shrinkAF f) x y+        ScanSeq f e x        -> ScanSeq (shrinkF f) (shrinkE e) x++    shrinkC :: Consumer acc aenv' senv a -> Consumer acc aenv' senv a+    shrinkC c =+      case c of+        FoldSeq f e x        -> FoldSeq (shrinkF f) (shrinkE e) x+        FoldSeqFlatten f a x -> FoldSeqFlatten (shrinkAF f) (shrinkAcc a) x+        Stuple t             -> Stuple (shrinkCT t)++    shrinkCT :: Atuple (Consumer acc aenv' senv) t -> Atuple (Consumer acc aenv' senv) t+    shrinkCT NilAtup        = NilAtup+    shrinkCT (SnocAtup t c) = SnocAtup (shrinkCT t) (shrinkC c)+--}++    shrinkE :: PreOpenExp acc env aenv' t -> PreOpenExp acc env aenv' t+    shrinkE exp = case exp of+      Let bnd body              -> Let (shrinkE bnd) (shrinkE body)+      Var idx                   -> Var idx+      Const c                   -> Const c+      Undef                     -> Undef+      Tuple t                   -> Tuple (shrinkT t)+      Prj tup e                 -> Prj tup (shrinkE e)+      IndexNil                  -> IndexNil+      IndexCons sl sz           -> IndexCons (shrinkE sl) (shrinkE sz)+      IndexHead sh              -> IndexHead (shrinkE sh)+      IndexTail sh              -> IndexTail (shrinkE sh)+      IndexSlice x ix sh        -> IndexSlice x (shrinkE ix) (shrinkE sh)+      IndexFull x ix sl         -> IndexFull x (shrinkE ix) (shrinkE sl)+      IndexAny                  -> IndexAny+      ToIndex sh ix             -> ToIndex (shrinkE sh) (shrinkE ix)+      FromIndex sh i            -> FromIndex (shrinkE sh) (shrinkE i)+      Cond p t e                -> Cond (shrinkE p) (shrinkE t) (shrinkE e)+      While p f x               -> While (shrinkF p) (shrinkF f) (shrinkE x)+      PrimConst c               -> PrimConst c+      PrimApp f x               -> PrimApp f (shrinkE x)+      Index a sh                -> Index (shrinkAcc a) (shrinkE sh)+      LinearIndex a i           -> LinearIndex (shrinkAcc a) (shrinkE i)+      Shape a                   -> Shape (shrinkAcc a)+      ShapeSize sh              -> ShapeSize (shrinkE sh)+      Intersect sh sz           -> Intersect (shrinkE sh) (shrinkE sz)+      Union sh sz               -> Union (shrinkE sh) (shrinkE sz)+      Foreign ff f e            -> Foreign ff (shrinkF f) (shrinkE e)+      Coerce e                  -> Coerce (shrinkE e)++    shrinkF :: PreOpenFun acc env aenv' f -> PreOpenFun acc env aenv' f+    shrinkF (Lam f)  = Lam (shrinkF f)+    shrinkF (Body b) = Body (shrinkE b)++    shrinkT :: Tuple (PreOpenExp acc env aenv') t -> Tuple (PreOpenExp acc env aenv') t+    shrinkT NilTup        = NilTup+    shrinkT (SnocTup t e) = shrinkT t `SnocTup` shrinkE e++    shrinkAT :: Atuple (acc aenv') t -> Atuple (acc aenv') t+    shrinkAT NilAtup        = NilAtup+    shrinkAT (SnocAtup t a) = shrinkAT t `SnocAtup` shrinkAcc a++    shrinkAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f+    shrinkAF (Alam  f) = Alam (shrinkAF f)+    shrinkAF (Abody a) = Abody (shrinkAcc a)+++-- A somewhat hacky example implementation of the reduction step. It requires a+-- function to open the recursive closure of an array term.+--+basicReduceAcc+    :: Kit acc+    => (forall aenv a. acc aenv a -> PreOpenAcc acc aenv a)+    -> UsesOfAcc acc+    -> ReduceAcc acc+basicReduceAcc unwrapAcc countAcc (unwrapAcc -> bnd) body@(unwrapAcc -> pbody)+  | Avar _ <- bnd       = Stats.inline "Avar"  . Just $ rebuildA (subAtop bnd) pbody+  | uses <= lIMIT       = Stats.betaReduce msg . Just $ rebuildA (subAtop bnd) pbody+  | otherwise           = Nothing+  where+    -- If the bound variable is used at most this many times, it will be inlined+    -- into the body. Since this implies an array computation could be inlined+    -- into a scalar expression, we limit the shrinking reduction for array+    -- computations to dead-code elimination only.+    --+    lIMIT = 0++    uses  = countAcc True ZeroIdx body+    msg   = case uses of+      0 -> "dead acc"+      _ -> "inline acc"         -- forced inlining when lIMIT > 1+++-- Occurrence Counting+-- ===================++-- Count the number of occurrences an in-scope scalar expression bound at the+-- given variable index recursively in a term.+--+usesOfExp :: forall acc env aenv s t. Idx env s -> PreOpenExp acc env aenv t -> Int+usesOfExp idx = countE+  where+    countE :: PreOpenExp acc env aenv e -> Int+    countE exp = case exp of+      Var this+        | Just Refl <- match this idx   -> 1+        | otherwise                     -> 0+      --+      Let bnd body              -> countE bnd + usesOfExp (SuccIdx idx) body+      Const _                   -> 0+      Undef                     -> 0+      Tuple t                   -> countT t+      Prj _ e                   -> countE e+      IndexNil                  -> 0+      IndexCons sl sz           -> countE sl + countE sz+      IndexHead sh              -> countE sh+      IndexTail sh              -> countE sh+      IndexSlice _ ix sh        -> countE ix + countE sh+      IndexFull _ ix sl         -> countE ix + countE sl+      IndexAny                  -> 0+      ToIndex sh ix             -> countE sh + countE ix+      FromIndex sh i            -> countE sh + countE i+      Cond p t e                -> countE p  + countE t + countE e+      While p f x               -> countE x  + countF idx p + countF idx f+      PrimConst _               -> 0+      PrimApp _ x               -> countE x+      Index _ sh                -> countE sh+      LinearIndex _ i           -> countE i+      Shape _                   -> 0+      ShapeSize sh              -> countE sh+      Intersect sh sz           -> countE sh + countE sz+      Union sh sz               -> countE sh + countE sz+      Foreign _ _ e             -> countE e+      Coerce e                  -> countE e++    countF :: Idx env' s -> PreOpenFun acc env' aenv f -> Int+    countF idx' (Lam  f) = countF (SuccIdx idx') f+    countF idx' (Body b) = usesOfExp idx' b++    countT :: Tuple (PreOpenExp acc env aenv) e -> Int+    countT NilTup        = 0+    countT (SnocTup t e) = countT t + countE e+++-- Count the number of occurrences of the array term bound at the given+-- environment index. If the first argument is 'True' then it includes in the+-- total uses of the variable for 'Shape' information, otherwise not.+--+type UsesOfAcc acc = forall aenv s t. Bool -> Idx aenv s -> acc aenv t -> Int++usesOfPreAcc+    :: forall acc aenv s t.+       Bool+    -> UsesOfAcc  acc+    -> Idx            aenv s+    -> PreOpenAcc acc aenv t+    -> Int+usesOfPreAcc withShape countAcc idx = count+  where+    countIdx :: Idx aenv a -> Int+    countIdx this+        | Just Refl <- match this idx   = 1+        | otherwise                     = 0++    count :: PreOpenAcc acc aenv a -> Int+    count pacc = case pacc of+      Avar this                 -> countIdx this+      --+      Alet bnd body             -> countA bnd + countAcc withShape (SuccIdx idx) body+      Atuple tup                -> countAT tup+      Aprj _ a                  -> countA a     -- special case discount?+      Apply _ a                 -> countA a+      Aforeign _ _ a            -> countA a+      Acond p t e               -> countE p  + countA t + countA e+      Awhile _ _ a              -> countA a+      Use _                     -> 0+      Unit e                    -> countE e+      Reshape e a               -> countE e  + countA a+      Generate e f              -> countE e  + countF f+      Transform sh ix f a       -> countE sh + countF ix + countF f  + countA a+      Replicate _ sh a          -> countE sh + countA a+      Slice _ a sl              -> countE sl + countA a+      Map f a                   -> countF f  + countA a+      ZipWith f a1 a2           -> countF f  + countA a1 + countA a2+      Fold f z a                -> countF f  + countE z  + countA a+      Fold1 f a                 -> countF f  + countA a+      FoldSeg f z a s           -> countF f  + countE z  + countA a  + countA s+      Fold1Seg f a s            -> countF f  + countA a  + countA s+      Scanl f z a               -> countF f  + countE z  + countA a+      Scanl' f z a              -> countF f  + countE z  + countA a+      Scanl1 f a                -> countF f  + countA a+      Scanr f z a               -> countF f  + countE z  + countA a+      Scanr' f z a              -> countF f  + countE z  + countA a+      Scanr1 f a                -> countF f  + countA a+      Permute f1 a1 f2 a2       -> countF f1 + countA a1 + countF f2 + countA a2+      Backpermute sh f a        -> countE sh + countF f  + countA a+      Stencil f _ a             -> countF f  + countA a+      Stencil2 f _ a1 _ a2      -> countF f  + countA a1 + countA a2+      -- Collect s                 -> countS s++    countE :: PreOpenExp acc env aenv e -> Int+    countE exp = case exp of+      Let bnd body              -> countE bnd + countE body+      Var _                     -> 0+      Const _                   -> 0+      Undef                     -> 0+      Tuple t                   -> countT t+      Prj _ e                   -> countE e+      IndexNil                  -> 0+      IndexCons sl sz           -> countE sl + countE sz+      IndexHead sh              -> countE sh+      IndexTail sh              -> countE sh+      IndexSlice _ ix sh        -> countE ix + countE sh+      IndexFull _ ix sl         -> countE ix + countE sl+      IndexAny                  -> 0+      ToIndex sh ix             -> countE sh + countE ix+      FromIndex sh i            -> countE sh + countE i+      Cond p t e                -> countE p  + countE t + countE e+      While p f x               -> countF p  + countF f + countE x+      PrimConst _               -> 0+      PrimApp _ x               -> countE x+      Index a sh                -> countA a + countE sh+      LinearIndex a i           -> countA a + countE i+      ShapeSize sh              -> countE sh+      Intersect sh sz           -> countE sh + countE sz+      Union sh sz               -> countE sh + countE sz+      Shape a+        | withShape             -> countA a+        | otherwise             -> 0+      Foreign _ _ e             -> countE e+      Coerce e                  -> countE e++    countA :: acc aenv a -> Int+    countA = countAcc withShape idx++    -- countAF :: PreOpenAfun acc aenv' f+    --         -> Idx aenv' s+    --         -> Int+    -- countAF (Alam f)  v = countAF f (SuccIdx v)+    -- countAF (Abody a) v = countAcc withShape v a++    countF :: PreOpenFun acc env aenv f -> Int+    countF (Lam  f) = countF f+    countF (Body b) = countE b++    countT :: Tuple (PreOpenExp acc env aenv) e -> Int+    countT NilTup        = 0+    countT (SnocTup t e) = countT t + countE e++    countAT :: Atuple (acc aenv) a -> Int+    countAT NilAtup        = 0+    countAT (SnocAtup t a) = countAT t + countA a++{--+    countS :: PreOpenSeq acc aenv senv arrs -> Int+    countS seq =+      case seq of+        Producer p s -> countP p + countS s+        Consumer c   -> countC c+        Reify _      -> 0++    countP :: Producer acc aenv senv arrs -> Int+    countP p =+      case p of+        StreamIn _           -> 0+        ToSeq _ _ a          -> countA a+        MapSeq f _           -> countAF f idx+        ChunkedMapSeq f _    -> countAF f idx+        ZipWithSeq f _ _     -> countAF f idx+        ScanSeq f e _        -> countF f + countE e++    countC :: Consumer acc aenv senv arrs -> Int+    countC c =+      case c of+        FoldSeq f e _        -> countF f + countE e+        FoldSeqFlatten f a _ -> countAF f idx + countA a+        Stuple t             -> countCT t++    countCT :: Atuple (Consumer acc aenv senv) t' -> Int+    countCT NilAtup        = 0+    countCT (SnocAtup t c) = countCT t + countC c+--}+
+ src/Data/Array/Accelerate/Trafo/Simplify.hs view
@@ -0,0 +1,711 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE PatternGuards        #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns         #-}+-- |+-- Module      : Data.Array.Accelerate.Trafo.Simplify+-- 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.Trafo.Simplify (++  Simplify(..),++) where++-- standard library+import Control.Applicative                              hiding ( Const )+import Control.Lens                                     hiding ( Const, ix )+import Data.List                                        ( nubBy )+import Data.Maybe+import Data.Monoid+import Data.Typeable+import Text.Printf+import Prelude                                          hiding ( exp, iterate )++-- friends+import Data.Array.Accelerate.AST                        hiding ( prj )+import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Analysis.Shape+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Trafo.Algebra+import Data.Array.Accelerate.Trafo.Base+import Data.Array.Accelerate.Trafo.Shrink+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Array.Sugar                ( Array, Elt(eltType), Shape, Slice, toElt, fromElt, Z(..), (:.)(..)+                                                        , Tuple(..), IsTuple, fromTuple, TupleRepr, shapeToList )+import qualified Data.Array.Accelerate.Debug            as Stats+++class Simplify f where+  simplify :: f -> f++instance Kit acc => Simplify (PreFun acc aenv f) where+  simplify = simplifyFun++instance (Kit acc, Elt e) => Simplify (PreExp acc aenv e) where+  simplify = simplifyExp+++-- Scalar optimisations+-- ====================++{--+-- Common subexpression elimination finds computations that are performed at+-- least twice on a given execution path and eliminates the second and later+-- occurrences, replacing them with uses of saved values. This implements a+-- simplified version of that idea, where we look for the expressions of the+-- form:+--+--   let x = e1 in e2+--+-- and replace all occurrences of e1 in e2 with x. This is not full redundancy+-- elimination, but good enough to catch some cases, and in particular those+-- likely to be introduced by scalar composition of terms in the fusion process.+--+-- While it may seem that common subexpression elimination is always worthwhile,+-- as it reduces the number of arithmetic operations performed, this is not+-- necessarily advantageous. The simplest case in which it may not be desirable+-- is if it causes a register to be occupied for a long time in order to hold+-- the shared expression's value, which hence reduces the number of registers+-- available for other uses. Even worse is if the value has to be spilled to+-- memory because there are insufficient registers available. We sidestep this+-- tricky and target-dependent issue by, for now, simply ignoring it.+--+localCSE :: (Kit acc, Elt a)+         => Gamma      acc env env aenv+         -> PreOpenExp acc env     aenv a+         -> PreOpenExp acc (env,a) aenv b+         -> Maybe (PreOpenExp acc env aenv b)+localCSE env bnd body+  | Just ix <- lookupExp env bnd = Stats.ruleFired "CSE" . Just $ inline body (Var ix)+  | otherwise                    = Nothing+--}+{--+-- Common subexpression elimination, which attempts to match the given+-- expression against something already bound in the environment. This can occur+-- due to simplification, in which case we replace the entire subterm with x.+--+-- > let x = e in .. e ..+--+globalCSE :: (Kit acc, Elt t)+          => Gamma      acc env env aenv+          -> PreOpenExp acc env     aenv t+          -> Maybe (PreOpenExp acc env aenv t)+globalCSE env exp+  | Just ix <- lookupExp env exp = Stats.ruleFired "CSE" . Just $ Var ix+  | otherwise                    = Nothing+--}++{--+-- Compared to regular Haskell, the scalar expression language of Accelerate is+-- rather limited in order to meet the restrictions of what can be efficiently+-- implemented on specialised hardware, such as GPUs. For example, to avoid+-- excessive SIMD divergence, we do not support any form of recursion or+-- iteration in scalar expressions. This harmonises well with the stratified+-- design of the Accelerate language: collective array operations comprise many+-- scalar computations that are executed in parallel, so for simplicity of+-- scheduling these operations we would like some assurance that each scalar+-- computation takes approximately the same time to execute as all others.+--+-- However, some computations are naturally expressed in terms of iteration. For+-- some problems, we can instead use generative techniques to implement the+-- program by defining a single step of a recurrence relation as an Accelerate+-- collective operation and using standard Haskell to unroll the loop a _fixed_+-- number of times.+--+-- However, this is outrageously slow because the intermediate values are+-- written to memory at the end of every iteration. Luckily the fusion process+-- will eliminate this intermediate memory traffic by combining the 'n'+-- collective operations into a single operation with 'n' instances of the loop+-- body. However, doing this we uncover an embarrassing secret: C compilers do+-- not compile C code, they compile _idiomatic_ C code.+--+-- This process recovers the iteration structure that was lost in the process of+-- fusing the collective operations. This allows a backend to generate explicit+-- loops in its target language.+--+recoverLoops+    :: (Kit acc, Elt b)+    => Gamma      acc env env aenv+    -> PreOpenExp acc env     aenv a+    -> PreOpenExp acc (env,a) aenv b+    -> Maybe (PreOpenExp acc env aenv b)+recoverLoops _ bnd e3+  -- To introduce scaler loops, we look for expressions of the form:+  --+  --   let x =+  --     let y = e1 in e2+  --   in e3+  --+  -- and if e2 and e3 are congruent, replace with:+  --+  --   iterate[2] (\y -> e2) e1+  --+  | Let e1 e2           <- bnd+  , Just Refl           <- matchEnvTop e2 e3+  , Just Refl           <- match e2 e3+  = Stats.ruleFired "loop recovery/intro" . Just+  $ Iterate (constant 2) e2 e1++  -- To merge expressions into a loop body, look for the pattern:+  --+  --   let x = iterate[n] f e1+  --   in e3+  --+  -- and if e3 matches the loop body, replace the let binding with the bare+  -- iteration with the trip count increased by one.+  --+  | Iterate n f e1      <- bnd+  , Just Refl           <- match f e3+  = Stats.ruleFired "loop recovery/merge" . Just+  $ Iterate (constant 1 `plus` n) f e1++  | otherwise+  = Nothing++  where+    plus :: PreOpenExp acc env aenv Int -> PreOpenExp acc env aenv Int -> PreOpenExp acc env aenv Int+    plus x y = PrimApp (PrimAdd numType) $ Tuple $ NilTup `SnocTup` x `SnocTup` y++    constant :: Int -> PreOpenExp acc env aenv Int+    constant i = Const ((),i)++    matchEnvTop :: (Elt s, Elt t)+                => PreOpenExp acc (env,s) aenv f+                -> PreOpenExp acc (env,t) aenv g+                -> Maybe (s :=: t)+    matchEnvTop _ _ = gcast Refl+--}+++-- Walk a scalar expression applying simplifications to terms bottom-up.+--+-- TODO: Look for particular patterns of expressions that can be replaced by+--       something equivalent and simpler. In particular, indexing operations+--       introduced by the fusion transformation. This would benefit from a+--       rewrite rule schema.+--+simplifyOpenExp+    :: forall acc env aenv e. (Kit acc, Elt e)+    => Gamma acc env env aenv+    -> PreOpenExp acc env aenv e+    -> (Bool, PreOpenExp acc env aenv e)+simplifyOpenExp env = first getAny . cvtE+  where+    cvtE :: Elt t => PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t)+    cvtE exp = case exp of+      Let bnd body+        -- Just reduct <- recoverLoops env (snd bnd') (snd body') -> yes . snd $ cvtE reduct+        -- Just reduct <- localCSE     env (snd bnd') (snd body') -> yes . snd $ cvtE reduct+        | otherwise -> Let <$> bnd' <*> body'+        where+          bnd'  = cvtE bnd+          env'  = env `pushExp` snd bnd'+          body' = cvtE' (incExp env') body++      Var ix                    -> pure $ Var ix+      Const c                   -> pure $ Const c+      Undef                     -> pure Undef+      Tuple tup                 -> Tuple <$> cvtT tup+      Prj ix t                  -> prj env ix (cvtE t)+      IndexNil                  -> pure IndexNil+      IndexAny                  -> pure IndexAny+      IndexCons sh sz           -> indexCons (cvtE sh) (cvtE sz)+      IndexHead sh              -> indexHead (cvtE sh)+      IndexTail sh              -> indexTail (cvtE sh)+      IndexSlice x ix sh        -> IndexSlice x <$> cvtE ix <*> cvtE sh+      IndexFull x ix sl         -> IndexFull x <$> cvtE ix <*> cvtE sl+      ToIndex sh ix             -> toIndex (cvtE sh) (cvtE ix)+      FromIndex sh ix           -> fromIndex (cvtE sh) (cvtE ix)+      Cond p t e                -> cond (cvtE p) (cvtE t) (cvtE e)+      PrimConst c               -> pure $ PrimConst c+      PrimApp f x               -> (u<>v, fx)+        where+          (u, x') = cvtE x+          (v, fx) = evalPrimApp env f x'+      Index a sh                -> Index a <$> cvtE sh+      LinearIndex a i           -> LinearIndex a <$> cvtE i+      Shape a                   -> shape a+      ShapeSize sh              -> shapeSize (cvtE sh)+      Intersect s t             -> cvtE s `intersect` cvtE t+      Union s t                 -> cvtE s `union` cvtE t+      Foreign ff f e            -> Foreign ff <$> first Any (simplifyOpenFun EmptyExp f) <*> cvtE e+      While p f x               -> While <$> cvtF env p <*> cvtF env f <*> cvtE x+      Coerce e                  -> Coerce <$> cvtE e++    cvtT :: Tuple (PreOpenExp acc env aenv) t -> (Any, Tuple (PreOpenExp acc env aenv) t)+    cvtT NilTup        = pure NilTup+    cvtT (SnocTup t e) = SnocTup <$> cvtT t <*> cvtE e++    cvtE' :: Elt e' => Gamma acc env' env' aenv -> PreOpenExp acc env' aenv e' -> (Any, PreOpenExp acc env' aenv e')+    cvtE' env' = first Any . simplifyOpenExp env'++    cvtF :: Gamma acc env' env' aenv -> PreOpenFun acc env' aenv f -> (Any, PreOpenFun acc env' aenv f)+    cvtF env' = first Any . simplifyOpenFun env'++    -- Return the minimal set of unique shapes to intersect. This is a bit+    -- inefficient, but the number of shapes is expected to be small so should+    -- be fine in practice.+    --+    intersect :: Shape t+              => (Any, PreOpenExp acc env aenv t)+              -> (Any, PreOpenExp acc env aenv t)+              -> (Any, PreOpenExp acc env aenv t)+    intersect (c1, sh1) (c2, sh2)+      | Nothing <- match sh sh' = Stats.ruleFired "intersect" (yes sh')+      | otherwise               = (c1 <> c2, sh')+      where+        sh      = Intersect sh1 sh2+        sh'     = foldl1 Intersect+                $ nubBy (\x y -> isJust (match x y))+                $ leaves sh1 ++ leaves sh2++        leaves :: Shape t => PreOpenExp acc env aenv t -> [PreOpenExp acc env aenv t]+        leaves (Intersect x y)  = leaves x ++ leaves y+        leaves rest             = [rest]++    -- Return the minimal set of unique shapes to take the union of. This is a bit+    -- inefficient, but the number of shapes is expected to be small so should+    -- be fine in practice.+    --+    union :: Shape t+          => (Any, PreOpenExp acc env aenv t)+          -> (Any, PreOpenExp acc env aenv t)+          -> (Any, PreOpenExp acc env aenv t)+    union (c1, sh1) (c2, sh2)+      | Nothing <- match sh sh' = Stats.ruleFired "union" (yes sh')+      | otherwise               = (c1 <> c2, sh')+      where+        sh      = Union sh1 sh2+        sh'     = foldl1 Union+                $ nubBy (\x y -> isJust (match x y))+                $ leaves sh1 ++ leaves sh2++        leaves :: Shape t => PreOpenExp acc env aenv t -> [PreOpenExp acc env aenv t]+        leaves (Union x y)  = leaves x ++ leaves y+        leaves rest         = [rest]+++    -- Simplify conditional expressions, in particular by eliminating branches+    -- when the predicate is a known constant.+    --+    cond :: forall t. Elt t+         => (Any, PreOpenExp acc env aenv Bool)+         -> (Any, PreOpenExp acc env aenv t)+         -> (Any, PreOpenExp acc env aenv t)+         -> (Any, PreOpenExp acc env aenv t)+    cond p@(_,p') t@(_,t') e@(_,e')+      | Const True  <- p'        = Stats.knownBranch "True"      (yes t')+      | Const False <- p'        = Stats.knownBranch "False"     (yes e')+      | Just Refl <- match t' e' = Stats.knownBranch "redundant" (yes e')+      | otherwise                = Cond <$> p <*> t <*> e++    -- If we are projecting elements from a tuple structure or tuple of constant+    -- valued tuple, pick out the appropriate component directly.+    --+    -- Follow variable bindings, but only if they result in a simplification.+    --+    prj :: forall env' s t. (Elt s, Elt t, IsTuple t)+        => Gamma acc env' env' aenv+        -> TupleIdx (TupleRepr t) s+        -> (Any, PreOpenExp acc env' aenv t)+        -> (Any, PreOpenExp acc env' aenv s)+    prj env' ix top@(_,e) = case e of+      Tuple t                      -> Stats.inline "prj/Tuple" . yes $ prjT ix t+      Const c                      -> Stats.inline "prj/Const" . yes $ prjC ix (fromTuple (toElt c :: t))+      Var v   | Just x <- prjV v   -> Stats.inline "prj/Var"   . yes $ x+      Let a b | Just x <- prjL a b -> Stats.inline "prj/Let"   . yes $ x+      _                            -> Prj ix <$> top+      where+        prjT :: TupleIdx tup s -> Tuple (PreOpenExp acc env' aenv) tup -> PreOpenExp acc env' aenv s+        prjT ZeroTupIdx       (SnocTup _ v) = v+        prjT (SuccTupIdx idx) (SnocTup t _) = prjT idx t+#if __GLASGOW_HASKELL__ < 800+        prjT _                _             = error "DO MORE OF WHAT MAKES YOU HAPPY"+#endif++        prjC :: TupleIdx tup s -> tup -> PreOpenExp acc env' aenv s+        prjC ZeroTupIdx       (_,   v) = Const (fromElt v)+        prjC (SuccTupIdx idx) (tup, _) = prjC idx tup++        prjV :: Idx env' t -> Maybe (PreOpenExp acc env' aenv s)+        prjV var+          | e'      <- prjExp var env'+          , Nothing <- match e e'+          = case e' of+              -- Don't push through nested let-bindings; this leads to code explosion+              Let _ _                                    -> Nothing+              _ | (Any True, x) <- prj env' ix (pure e') -> Just x+              _                                          -> Nothing+          | otherwise+          = Nothing++        prjL :: Elt a+             => PreOpenExp acc env'     aenv a+             -> PreOpenExp acc (env',a) aenv t+             -> Maybe (PreOpenExp acc env' aenv s)+        prjL a b+          | (Any True, c) <- prj (incExp $ pushExp env' a) ix (pure b) = Just (Let a c)+        prjL _ _                                                       = Nothing+++    -- Shape manipulations+    --+    indexCons :: (Slice sl, Elt sz)+              => (Any, PreOpenExp acc env aenv sl)+              -> (Any, PreOpenExp acc env aenv sz)+              -> (Any, PreOpenExp acc env aenv (sl :. sz))+    indexCons (_,IndexNil) (_,Const c)+      | Just c'         <- cast c       -- EltRepr Z ~ EltRepr ()+      = Stats.ruleFired "Z:.const" $ yes (Const c')+    indexCons (_,IndexNil) (_,IndexHead sz')+      | 1               <- expDim sz'   -- no type information that this is a 1D shape, hence gcast next+      , Just sh'        <- gcast sz'+      = Stats.ruleFired "Z:.indexHead" $ yes sh'+    indexCons (_,IndexTail sl') (_,IndexHead sz')+      | Just Refl       <- match sl' sz'+      = Stats.ruleFired "indexTail:.indexHead" $ yes sl'+    indexCons sl sz+      = IndexCons <$> sl <*> sz++    indexHead :: forall sl sz. (Slice sl, Elt sz) => (Any, PreOpenExp acc env aenv (sl :. sz)) -> (Any, PreOpenExp acc env aenv sz)+    indexHead (_, Const c)+      | _ :. sz <- toElt c :: sl :. sz  = Stats.ruleFired "indexHead/const"     $ yes (Const (fromElt sz))+    indexHead (_, IndexCons _ sz)       = Stats.ruleFired "indexHead/indexCons" $ yes sz+    indexHead sh                        = IndexHead <$> sh++    indexTail :: forall sl sz. (Slice sl, Elt sz) => (Any, PreOpenExp acc env aenv (sl :. sz)) -> (Any, PreOpenExp acc env aenv sl)+    indexTail (_, Const c)+      | sl :. _ <- toElt c :: sl :. sz  = Stats.ruleFired "indexTail/const"     $ yes (Const (fromElt sl))+    indexTail (_, IndexCons sl _)       = Stats.ruleFired "indexTail/indexCons" $ yes sl+    indexTail sh                        = IndexTail <$> sh++    shape :: forall sh t. (Shape sh, Elt t) => acc aenv (Array sh t) -> (Any, PreOpenExp acc env aenv sh)+    shape _+      | Just Refl <- matchTupleType (eltType (undefined::sh)) (eltType (undefined::Z))+      = Stats.ruleFired "shape/Z" $ yes (Const (fromElt Z))+    shape a+      = pure $ Shape a++    shapeSize :: forall sh. Shape sh => (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int)+    shapeSize (_, Const c) = Stats.ruleFired "shapeSize/const" $ yes (Const (product (shapeToList (toElt c :: sh))))+    shapeSize sh           = ShapeSize <$> sh++    toIndex :: forall sh. Shape sh => (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int)+    toIndex  (_,sh) (_,FromIndex sh' ix)+      | Just Refl <- match sh sh' = Stats.ruleFired "toIndex/fromIndex" $ yes ix+    toIndex sh ix                 = ToIndex <$> sh <*> ix++    fromIndex :: forall sh. Shape sh => (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) -> (Any, PreOpenExp acc env aenv sh)+    fromIndex  (_,sh) (_,ToIndex sh' ix)+      | Just Refl <- match sh sh' = Stats.ruleFired "fromIndex/toIndex" $ yes ix+    fromIndex sh ix               = FromIndex <$> sh <*> ix++    first :: (a -> a') -> (a,b) -> (a',b)+    first f (x,y) = (f x, y)++    yes :: x -> (Any, x)+    yes x = (Any True, x)+++-- Simplification for open functions+--+simplifyOpenFun+    :: Kit acc+    => Gamma acc env env aenv+    -> PreOpenFun acc env aenv f+    -> (Bool, PreOpenFun acc env aenv f)+simplifyOpenFun env (Body e) = Body <$> simplifyOpenExp env  e+simplifyOpenFun env (Lam f)  = Lam  <$> simplifyOpenFun env' f+  where+    env' = incExp env `pushExp` Var ZeroIdx+++-- Simplify closed expressions and functions. The process is applied+-- repeatedly until no more changes are made.+--+simplifyExp :: (Elt t, Kit acc) => PreExp acc aenv t -> PreExp acc aenv t+simplifyExp = iterate summariseOpenExp (simplifyOpenExp EmptyExp)++simplifyFun :: Kit acc => PreFun acc aenv f -> PreFun acc aenv f+simplifyFun = iterate summariseOpenFun (simplifyOpenFun EmptyExp)+++-- NOTE: [Simplifier iterations]+--+-- Run the simplification pass _before_ the shrinking step. There are cases+-- where it is better to run shrinking first, and then simplification would+-- complete in a single step, but the converse is also true. However, as+-- shrinking can remove some structure of the let bindings, which might be+-- useful for the transformations (e.g. loop recovery) we want to maintain this+-- information for at least the first pass.+--+-- We always apply the simplification step once. Following this, we iterate+-- shrinking and simplification until the expression no longer changes. Both+-- shrink and simplify return a boolean indicating whether any work was done; we+-- stop as soon as either returns false.+--+-- With internal checks on, we also issue a warning if the iteration limit is+-- reached, but it was still possible to make changes to the expression.+--+{-# SPECIALISE iterate :: (Exp aenv t -> Stats) -> (Exp aenv t -> (Bool, Exp aenv t)) -> Exp aenv t -> Exp aenv t #-}+{-# SPECIALISE iterate :: (Fun aenv t -> Stats) -> (Fun aenv t -> (Bool, Fun aenv t)) -> Fun aenv t -> Fun aenv t #-}++iterate+    :: forall f a. (Match f, Shrink (f a))+    => (f a -> Stats)+    -> (f a -> (Bool, f a))+    -> f a+    -> f a+iterate summarise f = fix 1 . setup+  where+    -- The maximum number of simplifier iterations. To be conservative and avoid+    -- excessive run times, we (should) set this value very low.+    --+    -- TODO: make this tunable via debug flags.+    --+    lIMIT       = 25++    simplify'   = Stats.simplifierDone . f+    setup x     = Stats.trace Stats.dump_simpl_iterations (msg 0 "init" x)+                $ snd (trace 1 "simplify" (simplify' x))++    fix :: Int -> f a -> f a+    fix i x0+      | i > lIMIT       = $internalWarning "simplify" "iteration limit reached" (not (x0 ==^ f x0)) x0+      | not shrunk      = x1+      | not simplified  = x2+      | otherwise       = fix (i+1) x2+      where+        (shrunk,     x1) = trace i "shrink"   $ shrink' x0+        (simplified, x2) = trace i "simplify" $ simplify' x1++    -- debugging support+    --+    u ==^ (_,v)         = isJust (match u v)++    trace i s v@(changed,x)+      | changed         = Stats.trace Stats.dump_simpl_iterations (msg i s x) v+      | otherwise       = v++    msg :: Int -> String -> f a -> String+    msg i s x = printf "simpl-iters/%-8s [%d]: %s" s i (ppr x)++    ppr :: f a -> String+    ppr = show . summarise+++-- Debugging support+-- -----------------++data Stats = Stats+  { _terms    :: {-# UNPACK #-} !Int+  , _types    :: {-# UNPACK #-} !Int+  , _binders  :: {-# UNPACK #-} !Int+  , _vars     :: {-# UNPACK #-} !Int+  , _ops      :: {-# UNPACK #-} !Int+  }++instance Show Stats where+  show (Stats a b c d e) =+    printf "terms = %d, types = %d, lets = %d, vars = %d, primops = %d" a b c d e++infixl 6 ++++(+++) :: Stats -> Stats -> Stats+Stats a1 b1 c1 d1 e1 +++ Stats a2 b2 c2 d2 e2 = Stats (a1+a2) (b1+b2) (c1+c2) (d1+d2) (e1+e2)+{-# INLINE (+++) #-}++terms, types, binders, vars, ops :: Lens' Stats Int+terms   = lens _terms   (\Stats{..} v -> Stats { _terms   = v, ..})+types   = lens _types   (\Stats{..} v -> Stats { _types   = v, ..})+binders = lens _binders (\Stats{..} v -> Stats { _binders = v, ..})+vars    = lens _vars    (\Stats{..} v -> Stats { _vars    = v, ..})+ops     = lens _ops     (\Stats{..} v -> Stats { _ops     = v, ..})+{-# INLINE terms   #-}+{-# INLINE types   #-}+{-# INLINE binders #-}+{-# INLINE vars    #-}+{-# INLINE ops     #-}++summariseOpenFun :: PreOpenFun acc env aenv f -> Stats+summariseOpenFun (Body e) = summariseOpenExp e & terms +~ 1+summariseOpenFun (Lam f)  = summariseOpenFun f & terms +~ 1 & binders +~ 1++summariseOpenExp :: PreOpenExp acc env aenv t -> Stats+summariseOpenExp = (terms +~ 1) . goE+  where+    zero = Stats 0 0 0 0 0++    travE :: PreOpenExp acc env aenv t -> Stats+    travE = summariseOpenExp++    travF :: PreOpenFun acc env aenv t -> Stats+    travF = summariseOpenFun++    travA :: acc aenv a -> Stats+    travA _ = zero & vars +~ 1  -- assume an array index, else we should have failed elsewhere++    travT :: Tuple (PreOpenExp acc env aenv) t -> Stats+    travT NilTup        = zero & terms +~ 1+    travT (SnocTup t e) = travT t +++ travE e & terms +~ 1++    travTix :: TupleIdx t e -> Stats+    travTix ZeroTupIdx     = zero & terms +~ 1+    travTix (SuccTupIdx t) = travTix t & terms +~ 1++    travC :: PrimConst c -> Stats+    travC (PrimMinBound t) = travBoundedType t & terms +~ 1+    travC (PrimMaxBound t) = travBoundedType t & terms +~ 1+    travC (PrimPi t)       = travFloatingType t & terms +~ 1++    travNonNumType :: NonNumType t -> Stats+    travNonNumType _ = zero & types +~ 1++    travIntegralType :: IntegralType t -> Stats+    travIntegralType _ = zero & types +~ 1++    travFloatingType :: FloatingType t -> Stats+    travFloatingType _ = zero & types +~ 1++    travNumType :: NumType t -> Stats+    travNumType (IntegralNumType t) = travIntegralType t & types +~ 1+    travNumType (FloatingNumType t) = travFloatingType t & types +~ 1++    travBoundedType :: BoundedType t -> Stats+    travBoundedType (IntegralBoundedType t) = travIntegralType t & types +~ 1+    travBoundedType (NonNumBoundedType t)   = travNonNumType t & types +~ 1++    -- travScalarType :: ScalarType t -> Stats+    -- travScalarType (SingleScalarType t) = travSingleType t & types +~ 1+    -- travScalarType (VectorScalarType t) = travVectorType t & types +~ 1++    travSingleType :: SingleType t -> Stats+    travSingleType (NumSingleType t)    = travNumType t & types +~ 1+    travSingleType (NonNumSingleType t) = travNonNumType t & types +~ 1++    -- travVectorType :: VectorType t -> Stats+    -- travVectorType (Vector2Type t)  = travSingleType t & types +~ 1+    -- travVectorType (Vector3Type t)  = travSingleType t & types +~ 1+    -- travVectorType (Vector4Type t)  = travSingleType t & types +~ 1+    -- travVectorType (Vector8Type t)  = travSingleType t & types +~ 1+    -- travVectorType (Vector16Type t) = travSingleType t & types +~ 1++    -- The scrutinee has already been counted+    goE :: PreOpenExp acc env aenv t -> Stats+    goE exp =+      case exp of+        Let bnd body          -> travE bnd +++ travE body & binders +~ 1+        Var{}                 -> zero & vars +~ 1+        Foreign _ _ x         -> travE x & terms +~ 1   -- +1 for asm, ignore fallback impls.+        Const{}               -> zero+        Undef                 -> zero+        Tuple tup             -> travT tup & terms +~ 1+        Prj ix e              -> travTix ix +++ travE e+        IndexNil              -> zero+        IndexCons sh sz       -> travE sh +++ travE sz+        IndexHead sh          -> travE sh+        IndexTail sh          -> travE sh+        IndexAny              -> zero+        IndexSlice _ slix sh  -> travE slix +++ travE sh & terms +~ 1 -- +1 for sliceIndex+        IndexFull _ slix sl   -> travE slix +++ travE sl & terms +~ 1 -- +1 for sliceIndex+        ToIndex sh ix         -> travE sh +++ travE ix+        FromIndex sh ix       -> travE sh +++ travE ix+        Cond p t e            -> travE p +++ travE t +++ travE e+        While p f x           -> travF p +++ travF f +++ travE x+        PrimConst c           -> travC c+        Index a ix            -> travA a +++ travE ix+        LinearIndex a ix      -> travA a +++ travE ix+        Shape a               -> travA a+        ShapeSize sh          -> travE sh+        Intersect sh1 sh2     -> travE sh1 +++ travE sh2+        Union sh1 sh2         -> travE sh1 +++ travE sh2+        PrimApp f x           -> travPrimFun f +++ travE x+        Coerce e              -> travE e++    travPrimFun :: PrimFun f -> Stats+    travPrimFun = (ops +~ 1) . goF+      where+        goF :: PrimFun f -> Stats+        goF fun =+          case fun of+            PrimAdd                t -> travNumType t+            PrimSub                t -> travNumType t+            PrimMul                t -> travNumType t+            PrimNeg                t -> travNumType t+            PrimAbs                t -> travNumType t+            PrimSig                t -> travNumType t+            PrimQuot               t -> travIntegralType t+            PrimRem                t -> travIntegralType t+            PrimQuotRem            t -> travIntegralType t+            PrimIDiv               t -> travIntegralType t+            PrimMod                t -> travIntegralType t+            PrimDivMod             t -> travIntegralType t+            PrimBAnd               t -> travIntegralType t+            PrimBOr                t -> travIntegralType t+            PrimBXor               t -> travIntegralType t+            PrimBNot               t -> travIntegralType t+            PrimBShiftL            t -> travIntegralType t+            PrimBShiftR            t -> travIntegralType t+            PrimBRotateL           t -> travIntegralType t+            PrimBRotateR           t -> travIntegralType t+            PrimPopCount           t -> travIntegralType t+            PrimCountLeadingZeros  t -> travIntegralType t+            PrimCountTrailingZeros t -> travIntegralType t+            PrimFDiv               t -> travFloatingType t+            PrimRecip              t -> travFloatingType t+            PrimSin                t -> travFloatingType t+            PrimCos                t -> travFloatingType t+            PrimTan                t -> travFloatingType t+            PrimAsin               t -> travFloatingType t+            PrimAcos               t -> travFloatingType t+            PrimAtan               t -> travFloatingType t+            PrimSinh               t -> travFloatingType t+            PrimCosh               t -> travFloatingType t+            PrimTanh               t -> travFloatingType t+            PrimAsinh              t -> travFloatingType t+            PrimAcosh              t -> travFloatingType t+            PrimAtanh              t -> travFloatingType t+            PrimExpFloating        t -> travFloatingType t+            PrimSqrt               t -> travFloatingType t+            PrimLog                t -> travFloatingType t+            PrimFPow               t -> travFloatingType t+            PrimLogBase            t -> travFloatingType t+            PrimTruncate         f i -> travFloatingType f +++ travIntegralType i+            PrimRound            f i -> travFloatingType f +++ travIntegralType i+            PrimFloor            f i -> travFloatingType f +++ travIntegralType i+            PrimCeiling          f i -> travFloatingType f +++ travIntegralType i+            PrimIsNaN              t -> travFloatingType t+            PrimIsInfinite         t -> travFloatingType t+            PrimAtan2              t -> travFloatingType t+            PrimLt                 t -> travSingleType t+            PrimGt                 t -> travSingleType t+            PrimLtEq               t -> travSingleType t+            PrimGtEq               t -> travSingleType t+            PrimEq                 t -> travSingleType t+            PrimNEq                t -> travSingleType t+            PrimMax                t -> travSingleType t+            PrimMin                t -> travSingleType t+            PrimLAnd                 -> zero+            PrimLOr                  -> zero+            PrimLNot                 -> zero+            PrimOrd                  -> zero+            PrimChr                  -> zero+            PrimBoolToInt            -> zero+            PrimFromIntegral     i n -> travIntegralType i +++ travNumType n+            PrimToFloating       n f -> travNumType n +++ travFloatingType f+
+ src/Data/Array/Accelerate/Trafo/Substitution.hs view
@@ -0,0 +1,602 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Trafo.Substitution+-- 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.Trafo.Substitution (++  -- ** Renaming & Substitution+  inline, substitute, compose,+  subTop, subAtop,++  -- ** Weakening+  (:>), Sink(..), SinkExp(..),++  -- ** Strengthening+  (:?>), strengthen, strengthenE,++  -- ** Rebuilding terms+  RebuildAcc, Rebuildable(..), RebuildableAcc,+  RebuildableExp(..), RebuildTup(..)++) where++import Control.Applicative                              hiding ( Const )+import Prelude                                          hiding ( exp, seq )++import Data.Array.Accelerate.AST+import Data.Array.Accelerate.Array.Sugar                ( Elt, Arrays, Tuple(..), Atuple(..) )+import qualified Data.Array.Accelerate.Debug.Stats      as Stats+++-- NOTE: [Renaming and Substitution]+--+-- To do things like renaming and substitution, we need some operation on+-- variables that we push structurally through terms, applying to each variable.+-- We have a type preserving but environment changing operation:+--+--   v :: forall t. Idx env t -> f env' aenv t+--+-- The crafty bit is that 'f' might represent variables (for renaming) or terms+-- (for substitutions). The demonic forall, --- which is to say that the+-- quantifier is in a position which gives us obligation, not opportunity ---+-- forces us to respect type: when pattern matching detects the variable we care+-- about, happily we discover that it has the type we must respect. The demon is+-- not so free to mess with us as one might fear at first.+--+-- We then lift this to an operation which traverses terms and rebuild them+-- after applying 'v' to the variables:+--+--   rebuildPartial v :: OpenExp env aenv t -> OpenExp env' aenv t+--+-- The Syntactic class tells us what we need to know about 'f' if we want to be+-- able to rebuildPartial terms. In essence, the crucial functionality is to propagate+-- a class of operations on variables that is closed under shifting.+--+infixr `compose`+infixr `substitute`++-- | Replace the first variable with the given expression. The environment+-- shrinks.+--+inline :: RebuildableAcc acc+       => PreOpenExp acc (env, s) aenv t+       -> PreOpenExp acc env      aenv s+       -> PreOpenExp acc env      aenv t+inline f g = Stats.substitution "inline" $ rebuildE (subTop g) f++-- | Replace an expression that uses the top environment variable with another.+-- The result of the first is let bound into the second.+--+substitute :: (RebuildableAcc acc, Elt b, Elt c)+           => PreOpenExp acc (env, b) aenv c+           -> PreOpenExp acc (env, a) aenv b+           -> PreOpenExp acc (env, a) aenv c+substitute f g+  | Stats.substitution "substitute" False = undefined++  | Var ZeroIdx <- g    = f     -- don't rebind an identity function+  | otherwise           = Let g $ rebuildE split f+  where+    split :: Elt c => Idx (env,b) c -> PreOpenExp acc ((env,a),b) aenv c+    split ZeroIdx       = Var ZeroIdx+    split (SuccIdx ix)  = Var (SuccIdx (SuccIdx ix))+++-- | Composition of unary functions.+--+compose :: (RebuildableAcc acc, Elt c)+        => PreOpenFun acc env aenv (b -> c)+        -> PreOpenFun acc env aenv (a -> b)+        -> PreOpenFun acc env aenv (a -> c)+compose (Lam (Body f)) (Lam (Body g)) = Stats.substitution "compose" . Lam . Body $ substitute f g+compose _              _              = error "compose: impossible evaluation"++subTop :: Elt t => PreOpenExp acc env aenv s -> Idx (env, s) t -> PreOpenExp acc env aenv t+subTop s ZeroIdx      = s+subTop _ (SuccIdx ix) = Var ix++subAtop :: Arrays t => PreOpenAcc acc aenv s -> Idx (aenv, s) t -> PreOpenAcc acc aenv t+subAtop t ZeroIdx       = t+subAtop _ (SuccIdx idx) = Avar idx++data Identity a = Identity { runIdentity :: a }++instance Functor Identity where+  {-# INLINE fmap #-}+  fmap f (Identity a) = Identity (f a)++instance Applicative Identity where+  {-# INLINE (<*>) #-}+  {-# INLINE pure  #-}+  Identity f <*> Identity a = Identity (f a)+  pure a                    = Identity a++-- A class for rebuilding terms.+--+class Rebuildable f where+  {-# MINIMAL rebuildPartial #-}+  type AccClo f :: (* -> * -> *)++  rebuildPartial :: (Applicative f', SyntacticAcc fa)+                 => (forall a'. Arrays a' => Idx aenv a' -> f' (fa (AccClo f) aenv' a'))+                 -> f aenv  a+                 -> f' (f aenv' a)++  {-# INLINEABLE rebuildA #-}+  rebuildA :: (SyntacticAcc fa)+           => (forall a'. Arrays a' => Idx aenv a' -> fa (AccClo f) aenv' a')+           -> f aenv  a+           -> f aenv' a+  rebuildA av = runIdentity . rebuildPartial (Identity . av)++-- A class for rebuilding scalar terms.+--+class RebuildableExp f where+  {-# MINIMAL rebuildPartialE #-}+  rebuildPartialE :: (Applicative f', SyntacticExp fe)+                  => (forall e'. Elt e' => Idx env e' -> f' (fe (AccClo (f env)) env' aenv e'))+                  -> f env aenv  e+                  -> f' (f env' aenv e)++  {-# INLINABLE rebuildE #-}+  rebuildE :: SyntacticExp fe+           => (forall e'. Elt e' => Idx env e' -> fe (AccClo (f env)) env' aenv e')+           -> f env  aenv e+           -> f env' aenv e+  rebuildE v = runIdentity . rebuildPartialE (Identity . v)++-- Terms that are rebuildable and also recursive closures+--+type RebuildableAcc acc = (Rebuildable acc, AccClo acc ~ acc)++-- We can use the same plumbing to rebuildPartial all the things we want to rebuild.+--+instance RebuildableAcc acc => Rebuildable (PreOpenExp acc env) where+  type AccClo (PreOpenExp acc env) = acc+  {-# INLINEABLE rebuildPartial #-}+  rebuildPartial = rebuildPreOpenExp rebuildPartial (pure . IE)++instance RebuildableAcc acc => Rebuildable (PreOpenFun acc env) where+  type AccClo (PreOpenFun acc env) = acc+  {-# INLINEABLE rebuildPartial #-}+  rebuildPartial = rebuildFun rebuildPartial (pure . IE)++instance RebuildableAcc acc => Rebuildable (PreOpenAcc acc) where+  type AccClo (PreOpenAcc acc) = acc+  {-# INLINEABLE rebuildPartial #-}+  rebuildPartial = rebuildPreOpenAcc rebuildPartial++instance RebuildableAcc acc => Rebuildable (PreOpenAfun acc) where+  type AccClo (PreOpenAfun acc) = acc+  {-# INLINEABLE rebuildPartial #-}+  rebuildPartial = rebuildAfun rebuildPartial++-- Tuples have to be handled specially.+newtype RebuildTup acc env aenv t = RebuildTup { unRTup :: Tuple (PreOpenExp acc env aenv) t }++instance RebuildableAcc acc => Rebuildable (RebuildTup acc env) where+  type AccClo (RebuildTup acc env) = acc+  {-# INLINEABLE rebuildPartial #-}+  rebuildPartial v t = RebuildTup <$> rebuildTup rebuildPartial (pure . IE) v (unRTup t)++instance Rebuildable OpenAcc where+  type AccClo OpenAcc = OpenAcc+  {-# INLINEABLE rebuildPartial #-}+  rebuildPartial = rebuildOpenAcc++instance RebuildableAcc acc => RebuildableExp (PreOpenExp acc) where+  {-# INLINEABLE rebuildPartialE #-}+  rebuildPartialE v = rebuildPreOpenExp rebuildPartial v (pure . IA)++instance RebuildableAcc acc => RebuildableExp (PreOpenFun acc) where+  {-# INLINEABLE rebuildPartialE #-}+  rebuildPartialE v = rebuildFun rebuildPartial v (pure . IA)++-- NOTE: [Weakening]+--+-- Weakening is something we usually take for granted: every time you learn a+-- new word, old sentences still make sense. If a conclusion is justified by a+-- hypothesis, it is still justified if you add more hypotheses. Similarly, a+-- term remains in scope if you bind more (fresh) variables. Weakening is the+-- operation of shifting things from one scope to a larger scope in which new+-- things have become meaningful, but no old things have vanished.+--+-- When we use a named representation (or HOAS) we get weakening for free. But+-- in the de Bruijn representation weakening takes work: you have to shift all+-- variable references to make room for the new bindings.+--++-- The type of shifting terms from one context into another+--+type env :> env' = forall t'. Idx env t' -> Idx env' t'++class Sink f where+  weaken :: env :> env' -> f env t -> f env' t++  -- TLM: We can't use this default instance because it doesn't lead to+  --      specialised code. Perhaps the INLINEABLE pragma is ignored: GHC bug?+  --+  -- {-# INLINEABLE weaken #-}+  -- default weaken :: Rebuildable f => env :> env' -> f env t -> f env' t+  -- weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)++--instance Rebuildable f => Sink f where -- undecidable, incoherent+--  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)++instance Sink Idx where+  {-# INLINEABLE weaken #-}+  weaken k = k++instance RebuildableAcc acc => Sink (PreOpenAcc acc) where+  {-# INLINEABLE weaken #-}+  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)++instance RebuildableAcc acc => Sink (PreOpenAfun acc) where+  {-# INLINEABLE weaken #-}+  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)++instance RebuildableAcc acc => Sink (PreOpenExp acc env) where+  {-# INLINEABLE weaken #-}+  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)++instance RebuildableAcc acc => Sink (PreOpenFun acc env) where+  {-# INLINEABLE weaken #-}+  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)++instance RebuildableAcc acc => Sink (RebuildTup acc env) where+  {-# INLINEABLE weaken #-}+  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)++instance RebuildableAcc acc => Sink (PreBoundary acc) where+  {-# INLINEABLE weaken #-}+  weaken k bndy =+    case bndy of+      Clamp      -> Clamp+      Mirror     -> Mirror+      Wrap       -> Wrap+      Constant c -> Constant c+      Function f -> Function (weaken k f)++instance Sink OpenAcc where+  {-# INLINEABLE weaken #-}+  weaken k = Stats.substitution "weaken" . rebuildA (Avar . k)++-- This rewrite rule is disabled because 'weaken' is now part of a type class.+-- As such, we cannot attach a NOINLINE pragma because it has many definitions.+-- {-# RULES+-- "weaken/weaken" forall a (v1 :: env' :> env'') (v2 :: env :> env').+--     weaken v1 (weaken v2 a) = weaken (v1 . v2) a+--  #-}++class SinkExp f where+  weakenE :: env :> env' -> f env aenv t -> f env' aenv t++  -- See comment in 'weaken'+  --+  -- {-# INLINEABLE weakenE #-}+  -- default weakenE :: RebuildableExp f => env :> env' -> f env aenv t -> f env' aenv t+  -- weakenE v = Stats.substitution "weakenE" . rebuildE (IE . v)++instance RebuildableAcc acc => SinkExp (PreOpenExp acc) where+  {-# INLINEABLE weakenE #-}+  weakenE v = Stats.substitution "weakenE" . rebuildE (IE . v)++instance RebuildableAcc acc => SinkExp (PreOpenFun acc) where+  {-# INLINEABLE weakenE #-}+  weakenE v = Stats.substitution "weakenE" . rebuildE (IE . v)++-- See above for why this is disabled.+-- {-# RULES+-- "weakenE/weakenE" forall a (v1 :: env' :> env'') (v2 :: env :> env').+--    weakenE v1 (weakenE v2 a) = weakenE (v1 . v2) a+--  #-}++-- NOTE: [Strengthening]+--+-- Strengthening is the dual of weakening. Shifting terms from one scope to a+-- smaller scope. Of course this is not always possible. If the term contains+-- any variables not in the new environment, then it cannot be strengthened.+-- This partial behaviour is captured with 'Maybe'.+--++-- The type of partially shifting terms from one context into another.+type env :?> env' = forall t'. Idx env t' -> Maybe (Idx env' t')++{-# INLINEABLE strengthen #-}+strengthen :: Rebuildable f => env :?> env' -> f env t -> Maybe (f env' t)+strengthen k = rebuildPartial (fmap IA . k)++{-# INLINEABLE strengthenE #-}+strengthenE :: RebuildableExp f => env :?> env' -> f env aenv t -> Maybe (f env' aenv t)+strengthenE k = rebuildPartialE (fmap IE . k)++-- Simultaneous Substitution ===================================================+--++-- The scalar environment+-- ------------------++-- SEE: [Renaming and Substitution]+-- SEE: [Weakening]+--+class SyntacticExp f where+  varIn         :: Elt t => Idx env t        -> f acc env aenv t+  expOut        :: Elt t => f acc env aenv t -> PreOpenExp acc env aenv t+  weakenExp     :: Elt t => RebuildAcc acc -> f acc env aenv t -> f acc (env, s) aenv t+  -- weakenExpAcc  :: Elt t => RebuildAcc acc -> f acc env aenv t -> f acc env (aenv, s) t++newtype IdxE (acc :: * -> * -> *) env aenv t = IE { unIE :: Idx env t }++instance SyntacticExp IdxE where+  varIn          = IE+  expOut         = Var . unIE+  weakenExp _    = IE . SuccIdx . unIE+  -- weakenExpAcc _ = IE . unIE++instance SyntacticExp PreOpenExp where+  varIn          = Var+  expOut         = id+  weakenExp k    = runIdentity . rebuildPreOpenExp k (Identity . weakenExp k . IE) (Identity . IA)+  -- weakenExpAcc k = runIdentity . rebuildPreOpenExp k (Identity . IE) (Identity . weakenAcc k . IA)++{-# INLINEABLE shiftE #-}+shiftE+    :: (Applicative f, SyntacticExp fe, Elt t)+    => RebuildAcc acc+    -> (forall t'. Elt t' => Idx env t' -> f (fe acc env' aenv t'))+    -> Idx       (env,  s)      t+    -> f (fe acc (env', s) aenv t)+shiftE _ _ ZeroIdx      = pure $ varIn ZeroIdx+shiftE k v (SuccIdx ix) = weakenExp k <$> (v ix)++{-# INLINEABLE rebuildPreOpenExp #-}+rebuildPreOpenExp+    :: (Applicative f, SyntacticExp fe, SyntacticAcc fa)+    => RebuildAcc acc+    -> (forall t'. Elt t'    => Idx env t'  -> f (fe acc env' aenv' t'))+    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+    -> PreOpenExp acc env  aenv t+    -> f (PreOpenExp acc env' aenv' t)+rebuildPreOpenExp k v av exp =+  case exp of+    Const c             -> pure (Const c)+    PrimConst c         -> pure (PrimConst c)+    Undef               -> pure Undef+    IndexNil            -> pure IndexNil+    IndexAny            -> pure IndexAny+    Var ix              -> expOut       <$> v ix+    Let a b             -> Let          <$> rebuildPreOpenExp k v av a  <*> rebuildPreOpenExp k (shiftE k v) av b+    Tuple tup           -> Tuple        <$> rebuildTup k v av tup+    Prj tup e           -> Prj tup      <$> rebuildPreOpenExp k v av e+    IndexCons sh sz     -> IndexCons    <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av sz+    IndexHead sh        -> IndexHead    <$> rebuildPreOpenExp k v av sh+    IndexTail sh        -> IndexTail    <$> rebuildPreOpenExp k v av sh+    IndexSlice x ix sh  -> IndexSlice x <$> rebuildPreOpenExp k v av ix <*> rebuildPreOpenExp k v av sh+    IndexFull x ix sl   -> IndexFull x  <$> rebuildPreOpenExp k v av ix <*> rebuildPreOpenExp k v av sl+    ToIndex sh ix       -> ToIndex      <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av ix+    FromIndex sh ix     -> FromIndex    <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av ix+    Cond p t e          -> Cond         <$> rebuildPreOpenExp k v av p  <*> rebuildPreOpenExp k v av t  <*> rebuildPreOpenExp k v av e+    While p f x         -> While        <$> rebuildFun k v av p         <*> rebuildFun k v av f         <*> rebuildPreOpenExp k v av x+    PrimApp f x         -> PrimApp f    <$> rebuildPreOpenExp k v av x+    Index a sh          -> Index        <$> k av a                      <*> rebuildPreOpenExp k v av sh+    LinearIndex a i     -> LinearIndex  <$> k av a                      <*> rebuildPreOpenExp k v av i+    Shape a             -> Shape        <$> k av a+    ShapeSize sh        -> ShapeSize    <$> rebuildPreOpenExp k v av sh+    Intersect s t       -> Intersect    <$> rebuildPreOpenExp k v av s  <*> rebuildPreOpenExp k v av t+    Union s t           -> Union        <$> rebuildPreOpenExp k v av s  <*> rebuildPreOpenExp k v av t+    Foreign ff f e      -> Foreign ff f <$> rebuildPreOpenExp k v av e+    Coerce e            -> Coerce       <$> rebuildPreOpenExp k v av e++{-# INLINEABLE rebuildTup #-}+rebuildTup+    :: (Applicative f, SyntacticExp fe, SyntacticAcc fa)+    => RebuildAcc acc+    -> (forall t'. Elt t'    => Idx env t'  -> f (fe acc env' aenv' t'))+    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+    -> Tuple (PreOpenExp acc env  aenv)  t+    -> f (Tuple (PreOpenExp acc env' aenv') t)+rebuildTup k v av tup =+  case tup of+    NilTup      -> pure NilTup+    SnocTup t e -> SnocTup <$> rebuildTup k v av t <*> rebuildPreOpenExp k v av e++{-# INLINEABLE rebuildFun #-}+rebuildFun+    :: (Applicative f, SyntacticExp fe, SyntacticAcc fa)+    => RebuildAcc acc+    -> (forall t'. Elt t'    => Idx env t'  -> f (fe acc env' aenv' t'))+    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+    -> PreOpenFun acc env  aenv  t+    -> f (PreOpenFun acc env' aenv' t)+rebuildFun k v av fun =+  case fun of+    Body e      -> Body <$> rebuildPreOpenExp k v av e+    Lam f       -> Lam  <$> rebuildFun k (shiftE k v) av f++-- The array environment+-- -----------------++type RebuildAcc acc =+  forall aenv aenv' f fa a. (Applicative f, SyntacticAcc fa)+    => (forall a'. Arrays a' => Idx aenv a' -> f (fa acc aenv' a'))+    -> acc aenv  a+    -> f (acc aenv' a)++class SyntacticAcc f where+  avarIn        :: Arrays t => Idx aenv t     -> f acc aenv t+  accOut        :: Arrays t => f acc aenv t   -> PreOpenAcc acc aenv t+  weakenAcc     :: Arrays t => RebuildAcc acc -> f acc aenv t -> f acc (aenv, s) t++newtype IdxA (acc :: * -> * -> *) aenv t = IA { unIA :: Idx aenv t }++instance SyntacticAcc IdxA where+  avarIn         = IA+  accOut         = Avar . unIA+  weakenAcc _    = IA . SuccIdx . unIA++instance SyntacticAcc PreOpenAcc where+  avarIn        = Avar+  accOut        = id+  weakenAcc k   = runIdentity . rebuildPreOpenAcc k (Identity . weakenAcc k . IA)++{-# INLINEABLE shiftA #-}+shiftA+    :: (Applicative f, SyntacticAcc fa, Arrays t)+    => RebuildAcc acc+    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+    -> Idx         (aenv,  s) t+    -> f (fa   acc (aenv', s) t)+shiftA _ _ ZeroIdx      = pure $ avarIn ZeroIdx+shiftA k v (SuccIdx ix) = weakenAcc k <$> v ix++{-# INLINEABLE rebuildOpenAcc #-}+rebuildOpenAcc+    :: (Applicative f, SyntacticAcc fa)+    => (forall t'. Arrays t' => Idx aenv t' -> f (fa OpenAcc aenv' t'))+    -> OpenAcc aenv  t+    -> f (OpenAcc aenv' t)+rebuildOpenAcc av (OpenAcc acc) = OpenAcc <$> rebuildPreOpenAcc rebuildOpenAcc av acc++{-# INLINEABLE rebuildPreOpenAcc #-}+rebuildPreOpenAcc+    :: (Applicative f, SyntacticAcc fa)+    => RebuildAcc acc+    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+    -> PreOpenAcc acc aenv  t+    -> f (PreOpenAcc acc aenv' t)+rebuildPreOpenAcc k av acc =+  case acc of+    Use a                   -> pure (Use a)+    Alet a b                -> Alet         <$> k av a <*> k (shiftA k av) b+    Avar ix                 -> accOut       <$> av ix+    Atuple tup              -> Atuple       <$> rebuildAtup k av tup+    Aprj tup a              -> Aprj tup     <$> k av a+    Apply f a               -> Apply        <$> rebuildAfun k av f <*> k av a+    Acond p t e             -> Acond        <$> rebuildPreOpenExp k (pure . IE) av p <*> k av t <*> k av e+    Awhile p f a            -> Awhile       <$> rebuildAfun k av p <*> rebuildAfun k av f <*> k av a+    Unit e                  -> Unit         <$> rebuildPreOpenExp k (pure . IE) av e+    Reshape e a             -> Reshape      <$> rebuildPreOpenExp k (pure . IE) av e <*> k av a+    Generate e f            -> Generate     <$> rebuildPreOpenExp k (pure . IE) av e <*> rebuildFun k (pure . IE) av f+    Transform sh ix f a     -> Transform    <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av ix <*> rebuildFun k (pure . IE) av f <*> k av a+    Replicate sl slix a     -> Replicate sl <$> rebuildPreOpenExp k (pure . IE) av slix <*> k av a+    Slice sl a slix         -> Slice sl     <$> k av a <*> rebuildPreOpenExp k (pure . IE) av slix+    Map f a                 -> Map          <$> rebuildFun k (pure . IE) av f <*> k av a+    ZipWith f a1 a2         -> ZipWith      <$> rebuildFun k (pure . IE) av f <*> k av a1 <*> k av a2+    Fold f z a              -> Fold         <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a+    Fold1 f a               -> Fold1        <$> rebuildFun k (pure . IE) av f <*> k av a+    FoldSeg f z a s         -> FoldSeg      <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a <*> k av s+    Fold1Seg f a s          -> Fold1Seg     <$> rebuildFun k (pure . IE) av f <*> k av a <*> k av s+    Scanl f z a             -> Scanl        <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a+    Scanl' f z a            -> Scanl'       <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a+    Scanl1 f a              -> Scanl1       <$> rebuildFun k (pure . IE) av f <*> k av a+    Scanr f z a             -> Scanr        <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a+    Scanr' f z a            -> Scanr'       <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a+    Scanr1 f a              -> Scanr1       <$> rebuildFun k (pure . IE) av f <*> k av a+    Permute f1 a1 f2 a2     -> Permute      <$> rebuildFun k (pure . IE) av f1 <*> k av a1 <*> rebuildFun k (pure . IE) av f2 <*> k av a2+    Backpermute sh f a      -> Backpermute  <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av f <*> k av a+    Stencil f b a           -> Stencil      <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b  <*> k av a+    Stencil2 f b1 a1 b2 a2  -> Stencil2     <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b1 <*> k av a1 <*> rebuildBoundary k av b2 <*> k av a2+    -- Collect seq             -> Collect      <$> rebuildSeq k av seq+    Aforeign ff afun as     -> Aforeign ff afun <$> k av as++{-# INLINEABLE rebuildAfun #-}+rebuildAfun+    :: (Applicative f, SyntacticAcc fa)+    => RebuildAcc acc+    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+    -> PreOpenAfun acc aenv  t+    -> f (PreOpenAfun acc aenv' t)+rebuildAfun k av afun =+  case afun of+    Abody b     -> Abody <$> k av b+    Alam f      -> Alam  <$> rebuildAfun k (shiftA k av) f++{-# INLINEABLE rebuildAtup #-}+rebuildAtup+    :: (Applicative f, SyntacticAcc fa)+    => RebuildAcc acc+    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+    -> Atuple (acc aenv)  t+    -> f (Atuple (acc aenv') t)+rebuildAtup k av atup =+  case atup of+    NilAtup      -> pure NilAtup+    SnocAtup t a -> SnocAtup <$> rebuildAtup k av t <*> k av a++{-# INLINEABLE rebuildBoundary #-}+rebuildBoundary+    :: (Applicative f, SyntacticAcc fa)+    => RebuildAcc acc+    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+    -> PreBoundary acc aenv t+    -> f (PreBoundary acc aenv' t)+rebuildBoundary k av bndy =+  case bndy of+    Clamp       -> pure Clamp+    Mirror      -> pure Mirror+    Wrap        -> pure Wrap+    Constant v  -> pure (Constant v)+    Function f  -> Function <$> rebuildFun k (pure . IE) av f++{--+{-# INLINEABLE rebuildSeq #-}+rebuildSeq+    :: (SyntacticAcc fa, Applicative f)+    => RebuildAcc acc+    -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+    -> PreOpenSeq acc aenv senv t+    -> f (PreOpenSeq acc aenv' senv t)+rebuildSeq k v seq =+  case seq of+    Producer p s -> Producer <$> (rebuildP k v p) <*> (rebuildSeq k v s)+    Consumer c   -> Consumer <$> (rebuildC k v c)+    Reify ix     -> pure $ Reify ix++{-# INLINEABLE rebuildP #-}+rebuildP :: (SyntacticAcc fa, Applicative f)+         => RebuildAcc acc+         -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+         -> Producer acc aenv senv a+         -> f (Producer acc aenv' senv a)+rebuildP k v p =+  case p of+    StreamIn arrs        -> pure (StreamIn arrs)+    ToSeq sl slix acc    -> ToSeq sl slix <$> k v acc+    MapSeq f x           -> MapSeq <$> rebuildAfun k v f <*> pure x+    ChunkedMapSeq f x    -> ChunkedMapSeq <$> rebuildAfun k v f <*> pure x+    ZipWithSeq f x y     -> ZipWithSeq <$> rebuildAfun k v f <*> pure x <*> pure y+    ScanSeq f e x        -> ScanSeq <$> rebuildFun k (pure . IE) v f <*> rebuildPreOpenExp k (pure . IE) v e <*> pure x++{-# INLINEABLE rebuildC #-}+rebuildC :: forall acc fa f aenv aenv' senv a. (SyntacticAcc fa, Applicative f)+         => RebuildAcc acc+         -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t'))+         -> Consumer acc aenv senv a+         -> f (Consumer acc aenv' senv a)+rebuildC k v c =+  case c of+    FoldSeq f e x          -> FoldSeq <$> rebuildFun k (pure . IE) v f <*> rebuildPreOpenExp k (pure . IE) v e <*> pure x+    FoldSeqFlatten f acc x -> FoldSeqFlatten <$> rebuildAfun k v f <*> k v acc <*> pure x+    Stuple t               -> Stuple <$> rebuildT t+  where+    rebuildT :: Atuple (Consumer acc aenv senv) t -> f (Atuple (Consumer acc aenv' senv) t)+    rebuildT NilAtup        = pure NilAtup+    rebuildT (SnocAtup t s) = SnocAtup <$> (rebuildT t) <*> (rebuildC k v s)+--}+
+ src/Data/Array/Accelerate/Type.hs view
@@ -0,0 +1,540 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module      : Data.Array.Accelerate.Type+-- Copyright   : [2008..2018] Manuel M T Chakravarty, Gabriele Keller+--               [2009..2018] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--+--  /Scalar types supported in array computations/+--+--  Integral types:+--    * Int+--    * Int8+--    * Int16+--    * Int32+--    * Int64+--    * Word+--    * Word8+--    * Word16+--    * Word32+--    * Word64+--    * CShort+--    * CUShort+--    * CInt+--    * CUInt+--    * CLong+--    * CULong+--    * CLLong+--    * CULLong+--+--  Floating types:+--    * Half+--    * Float+--    * Double+--    * CFloat+--    * CDouble+--+--  Non-numeric types:+--    * Bool+--    * Char+--    * CChar+--    * CSChar+--    * CUChar+--+--  SIMD vector types:+--    * V2+--    * V3+--    * V4+--    * V8+--    * V16+--+-- Note that 'Int' has the same bit width as in plain Haskell computations.+-- 'Float' and 'Double' represent IEEE single and double precision floating+-- point numbers, respectively.+--++module Data.Array.Accelerate.Type (+  Half(..), Float, Double, Char, Bool(..),+  module Data.Int,+  module Data.Word,+  module Foreign.C.Types,+  module Data.Array.Accelerate.Type+) where+++import Data.Orphans ()    -- orphan instances for 8-tuples and beyond++-- standard libraries+import Data.Bits+import Data.Int+import Data.Type.Equality+import Data.Typeable+import Data.Word+import GHC.TypeLits+import Language.Haskell.TH+import Numeric.Half+import Text.Printf+import Foreign.Storable+import Foreign.C.Types+    (CChar, CSChar, CUChar, CShort, CUShort, CInt, CUInt, CLong, CULong, CLLong, CULLong, CFloat, CDouble)+++-- Scalar types+-- ------------++-- Reified dictionaries+--++data IntegralDict a where+  IntegralDict :: ( Bounded a, Eq a, Ord a, Show a+                  , Bits a, FiniteBits a, Integral a, Num a, Real a, Storable a )+               => IntegralDict a++data FloatingDict a where+  FloatingDict :: ( Eq a, Ord a, Show a+                  , Floating a, Fractional a, Num a, Real a, RealFrac a+                  , RealFloat a, Storable a )+               => FloatingDict a++data NonNumDict a where+  NonNumDict :: ( Bounded a, Eq a, Ord a, Show a, Storable a )+             => NonNumDict a+++-- Scalar type representation+--++-- | Integral types supported in array computations.+--+data IntegralType a where+  TypeInt     :: IntegralDict Int     -> IntegralType Int+  TypeInt8    :: IntegralDict Int8    -> IntegralType Int8+  TypeInt16   :: IntegralDict Int16   -> IntegralType Int16+  TypeInt32   :: IntegralDict Int32   -> IntegralType Int32+  TypeInt64   :: IntegralDict Int64   -> IntegralType Int64+  TypeWord    :: IntegralDict Word    -> IntegralType Word+  TypeWord8   :: IntegralDict Word8   -> IntegralType Word8+  TypeWord16  :: IntegralDict Word16  -> IntegralType Word16+  TypeWord32  :: IntegralDict Word32  -> IntegralType Word32+  TypeWord64  :: IntegralDict Word64  -> IntegralType Word64+  TypeCShort  :: IntegralDict CShort  -> IntegralType CShort+  TypeCUShort :: IntegralDict CUShort -> IntegralType CUShort+  TypeCInt    :: IntegralDict CInt    -> IntegralType CInt+  TypeCUInt   :: IntegralDict CUInt   -> IntegralType CUInt+  TypeCLong   :: IntegralDict CLong   -> IntegralType CLong+  TypeCULong  :: IntegralDict CULong  -> IntegralType CULong+  TypeCLLong  :: IntegralDict CLLong  -> IntegralType CLLong+  TypeCULLong :: IntegralDict CULLong -> IntegralType CULLong++-- | Floating-point types supported in array computations.+--+data FloatingType a where+  TypeHalf    :: FloatingDict Half    -> FloatingType Half+  TypeFloat   :: FloatingDict Float   -> FloatingType Float+  TypeDouble  :: FloatingDict Double  -> FloatingType Double+  TypeCFloat  :: FloatingDict CFloat  -> FloatingType CFloat+  TypeCDouble :: FloatingDict CDouble -> FloatingType CDouble++-- | Non-numeric types supported in array computations.+--+data NonNumType a where+  TypeBool    :: NonNumDict Bool      -> NonNumType Bool   --  marshalled to Word8+  TypeChar    :: NonNumDict Char      -> NonNumType Char+  TypeCChar   :: NonNumDict CChar     -> NonNumType CChar+  TypeCSChar  :: NonNumDict CSChar    -> NonNumType CSChar+  TypeCUChar  :: NonNumDict CUChar    -> NonNumType CUChar++-- | Numeric element types implement Num & Real+--+data NumType a where+  IntegralNumType :: IntegralType a -> NumType a+  FloatingNumType :: FloatingType a -> NumType a++-- | Bounded element types implement Bounded+--+data BoundedType a where+  IntegralBoundedType :: IntegralType a -> BoundedType a+  NonNumBoundedType   :: NonNumType a   -> BoundedType a++-- | All scalar element types implement Eq & Ord+--+data ScalarType a where+  SingleScalarType :: SingleType a     -> ScalarType a+  VectorScalarType :: VectorType (v a) -> ScalarType (v a)++data SingleType a where+  NumSingleType    :: NumType a    -> SingleType a+  NonNumSingleType :: NonNumType a -> SingleType a++data VectorType v where+  Vector2Type   :: SingleType a -> VectorType (V2 a)+  Vector3Type   :: SingleType a -> VectorType (V3 a)+  Vector4Type   :: SingleType a -> VectorType (V4 a)+  Vector8Type   :: SingleType a -> VectorType (V8 a)+  Vector16Type  :: SingleType a -> VectorType (V16 a)++-- Showing type names+--++instance Show (IntegralType a) where+  show (TypeInt _)     = "Int"+  show (TypeInt8 _)    = "Int8"+  show (TypeInt16 _)   = "Int16"+  show (TypeInt32 _)   = "Int32"+  show (TypeInt64 _)   = "Int64"+  show (TypeWord _)    = "Word"+  show (TypeWord8 _)   = "Word8"+  show (TypeWord16 _)  = "Word16"+  show (TypeWord32 _)  = "Word32"+  show (TypeWord64 _)  = "Word64"+  show (TypeCShort _)  = "CShort"+  show (TypeCUShort _) = "CUShort"+  show (TypeCInt _)    = "CInt"+  show (TypeCUInt _)   = "CUInt"+  show (TypeCLong _)   = "CLong"+  show (TypeCULong _)  = "CULong"+  show (TypeCLLong _)  = "CLLong"+  show (TypeCULLong _) = "CULLong"++instance Show (FloatingType a) where+  show (TypeHalf _)    = "Half"+  show (TypeFloat _)   = "Float"+  show (TypeDouble _)  = "Double"+  show (TypeCFloat _)  = "CFloat"+  show (TypeCDouble _) = "CDouble"++instance Show (NonNumType a) where+  show (TypeBool _)   = "Bool"+  show (TypeChar _)   = "Char"+  show (TypeCChar _)  = "CChar"+  show (TypeCSChar _) = "CSChar"+  show (TypeCUChar _) = "CUChar"++instance Show (NumType a) where+  show (IntegralNumType ty) = show ty+  show (FloatingNumType ty) = show ty++instance Show (BoundedType a) where+  show (IntegralBoundedType ty) = show ty+  show (NonNumBoundedType ty)   = show ty++instance Show (SingleType a) where+  show (NumSingleType ty)    = show ty+  show (NonNumSingleType ty) = show ty++instance Show (VectorType a) where+  show (Vector2Type t)  = printf "<2 x %s>" (show t)+  show (Vector3Type t)  = printf "<3 x %s>" (show t)+  show (Vector4Type t)  = printf "<4 x %s>" (show t)+  show (Vector8Type t)  = printf "<8 x %s>" (show t)+  show (Vector16Type t) = printf "<16 x %s>" (show t)++instance Show (ScalarType a) where+  show (SingleScalarType ty) = show ty+  show (VectorScalarType ty) = show ty+++-- Querying scalar type representations+--++-- | Integral types+--+class (IsSingle a, IsNum a, IsBounded a) => IsIntegral a where+  integralType :: IntegralType a++-- | Floating types+--+class (Floating a, IsSingle a, IsNum a) => IsFloating a where+  floatingType :: FloatingType a++-- | Non-numeric types+--+class IsNonNum a where+  nonNumType :: NonNumType a++-- | Numeric types+--+class (Num a, IsSingle a) => IsNum a where+  numType :: NumType a++-- | Bounded types+--+class IsBounded a where+  boundedType :: BoundedType a++-- | All single value types+--+class IsScalar a => IsSingle a where+  singleType :: SingleType a++-- | All scalar types+--+class Typeable a => IsScalar a where+  scalarType :: ScalarType a+++-- Extract reified dictionaries+--++integralDict :: IntegralType a -> IntegralDict a+integralDict (TypeInt     dict) = dict+integralDict (TypeInt8    dict) = dict+integralDict (TypeInt16   dict) = dict+integralDict (TypeInt32   dict) = dict+integralDict (TypeInt64   dict) = dict+integralDict (TypeWord    dict) = dict+integralDict (TypeWord8   dict) = dict+integralDict (TypeWord16  dict) = dict+integralDict (TypeWord32  dict) = dict+integralDict (TypeWord64  dict) = dict+integralDict (TypeCShort  dict) = dict+integralDict (TypeCUShort dict) = dict+integralDict (TypeCInt    dict) = dict+integralDict (TypeCUInt   dict) = dict+integralDict (TypeCLong   dict) = dict+integralDict (TypeCULong  dict) = dict+integralDict (TypeCLLong  dict) = dict+integralDict (TypeCULLong dict) = dict++floatingDict :: FloatingType a -> FloatingDict a+floatingDict (TypeHalf    dict) = dict+floatingDict (TypeFloat   dict) = dict+floatingDict (TypeDouble  dict) = dict+floatingDict (TypeCFloat  dict) = dict+floatingDict (TypeCDouble dict) = dict++nonNumDict :: NonNumType a -> NonNumDict a+nonNumDict (TypeBool   dict) = dict+nonNumDict (TypeChar   dict) = dict+nonNumDict (TypeCChar  dict) = dict+nonNumDict (TypeCSChar dict) = dict+nonNumDict (TypeCUChar dict) = dict+++-- Type representation+-- -------------------+--+-- Representation of product types, consisting of:+--+--   * unit (void)+--+--   * scalar types: values which go in registers. These may be single value+--     types such as int and float, or SIMD vectors of single value types such+--     as <4 * float>. We do not allow vectors-of-vectors.+--+--   * pairs: representing compound values (i.e. tuples) where each component+--     will be stored in a separate array.+--+data TupleType a where+  TypeRunit   ::                               TupleType ()+  TypeRscalar :: ScalarType a               -> TupleType a+  TypeRpair   :: TupleType a -> TupleType b -> TupleType (a, b)++instance Show (TupleType a) where+  show TypeRunit        = "()"+  show (TypeRscalar t)  = show t+  show (TypeRpair a b)  = printf "(%s,%s)" (show a) (show b)+++-- Type-level bit sizes+-- --------------------++-- |Constraint that values of these two types have the same bit width+--+type BitSizeEq a b = (BitSize a == BitSize b) ~ 'True++type family BitSize a :: Nat+++-- SIMD vector types+-- -----------------++data V2 a  = V2 !a !a+  deriving (Typeable, Eq, Ord)++data V3 a  = V3 !a !a !a+  deriving (Typeable, Eq, Ord)++data V4 a  = V4 !a !a !a !a+  deriving (Typeable, Eq, Ord)++data V8 a  = V8 !a !a !a !a !a !a !a !a+  deriving (Typeable, Eq, Ord)++data V16 a = V16 !a !a !a !a !a !a !a !a !a !a !a !a !a !a !a !a+  deriving (Typeable, Eq, Ord)++instance Show a => Show (V2 a) where+  show (V2 a b) = printf "<%s,%s>" (show a) (show b)++instance Show a => Show (V3 a) where+  show (V3 a b c) = printf "<%s,%s,%s>" (show a) (show b) (show c)++instance Show a => Show (V4 a) where+  show (V4 a b c d) = printf "<%s,%s,%s,%s>" (show a) (show b) (show c) (show d)++instance Show a => Show (V8 a) where+  show (V8 a b c d e f g h) =+    printf "<%s,%s,%s,%s,%s,%s,%s,%s>"+      (show a) (show b) (show c) (show d) (show e) (show f) (show g) (show h)++instance Show a => Show (V16 a) where+  show (V16 a b c d e f g h i j k l m n o p) =+    printf "<%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s>"+      (show a) (show b) (show c) (show d) (show e) (show f) (show g) (show h)+      (show i) (show j) (show k) (show l) (show m) (show n) (show o) (show p)+++-- Instances+-- ---------+--+-- Generate instances for the IsX classes. It would be preferable to do this+-- automatically based on the members of the IntegralType (etc.) representations+-- (see for example FromIntegral.hs) but TH phase restrictions would require us+-- to split this into a separate module.+--++$( runQ $ do+  let+      bits :: FiniteBits b => b -> Integer+      bits = toInteger . finiteBitSize++      integralTypes :: [(Name, Integer)]+      integralTypes =+        [ (''Int,     bits (undefined::Int))+        , (''Int8,    8)+        , (''Int16,   16)+        , (''Int32,   32)+        , (''Int64,   64)+        , (''Word,    bits (undefined::Word))+        , (''Word8,   8)+        , (''Word16,  16)+        , (''Word32,  32)+        , (''Word64,  64)+        , (''CShort,  16)+        , (''CUShort, 16)+        , (''CInt,    32)+        , (''CUInt,   32)+        , (''CLong,   bits (undefined::CLong))+        , (''CULong,  bits (undefined::CULong))+        , (''CLLong,  64)+        , (''CULLong, 64)+        ]++      floatingTypes :: [(Name, Integer)]+      floatingTypes =+        [ (''Half,    16)+        , (''Float,   32)+        , (''Double,  64)+        , (''CFloat,  32)+        , (''CDouble, 64)+        ]++      nonNumTypes :: [(Name, Integer)]+      nonNumTypes =+        [ (''Bool,   8)    -- stored as Word8+        , (''Char,   32)+        , (''CChar,  8)+        , (''CSChar, 8)+        , (''CUChar, 8)+        ]++      mkIntegral :: Name -> Integer -> Q [Dec]+      mkIntegral t n =+        [d| instance IsIntegral $(conT t) where+              integralType = $(conE (mkName ("Type" ++ nameBase t))) IntegralDict++            instance IsNum $(conT t) where+              numType = IntegralNumType integralType++            instance IsBounded $(conT t) where+              boundedType = IntegralBoundedType integralType++            instance IsSingle $(conT t) where+              singleType = NumSingleType numType++            instance IsScalar $(conT t) where+              scalarType = SingleScalarType singleType++            type instance BitSize $(conT t) = $(litT (numTyLit n))+          |]++      mkFloating :: Name -> Integer -> Q [Dec]+      mkFloating t n =+        [d| instance IsFloating $(conT t) where+              floatingType = $(conE (mkName ("Type" ++ nameBase t))) FloatingDict++            instance IsNum $(conT t) where+              numType = FloatingNumType floatingType++            instance IsSingle $(conT t) where+              singleType = NumSingleType numType++            instance IsScalar $(conT t) where+              scalarType = SingleScalarType singleType++            type instance BitSize $(conT t) = $(litT (numTyLit n))+          |]++      mkNonNum :: Name -> Integer -> Q [Dec]+      mkNonNum t n =+        [d| instance IsNonNum $(conT t) where+              nonNumType = $(conE (mkName ("Type" ++ nameBase t))) NonNumDict++            instance IsBounded $(conT t) where+              boundedType = NonNumBoundedType nonNumType++            instance IsSingle $(conT t) where+              singleType = NonNumSingleType nonNumType++            instance IsScalar $(conT t) where+              scalarType = SingleScalarType singleType++            type instance BitSize $(conT t) = $(litT (numTyLit n))+          |]++      mkVector :: Name -> Integer -> Q [Dec]+      mkVector t n =+        [d| instance IsScalar (V2 $(conT t)) where+              scalarType = VectorScalarType (Vector2Type singleType)++            instance IsScalar (V3 $(conT t)) where+              scalarType = VectorScalarType (Vector3Type singleType)++            instance IsScalar (V4 $(conT t)) where+              scalarType = VectorScalarType (Vector4Type singleType)++            instance IsScalar (V8 $(conT t)) where+              scalarType = VectorScalarType (Vector8Type singleType)++            instance IsScalar (V16 $(conT t)) where+              scalarType = VectorScalarType (Vector16Type singleType)++            type instance BitSize (V2 $(conT t))  = $(litT (numTyLit (2*n)))+            type instance BitSize (V3 $(conT t))  = $(litT (numTyLit (3*n)))+            type instance BitSize (V4 $(conT t))  = $(litT (numTyLit (4*n)))+            type instance BitSize (V8 $(conT t))  = $(litT (numTyLit (8*n)))+            type instance BitSize (V16 $(conT t)) = $(litT (numTyLit (16*n)))+          |]+      --+  is <- mapM (uncurry mkIntegral) integralTypes+  fs <- mapM (uncurry mkFloating) floatingTypes+  ns <- mapM (uncurry mkNonNum)   nonNumTypes+  vs <- mapM (uncurry mkVector)  (integralTypes ++ floatingTypes ++ nonNumTypes)+  --+  return (concat is ++ concat fs ++ concat ns ++ concat vs)+ )+
+ src/Data/Array/Accelerate/Unsafe.hs view
@@ -0,0 +1,49 @@+-- |+-- Module      : Data.Array.Accelerate.Unsafe+-- Copyright   : [2009..2018] 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)+--+-- Operations which may be unsafe. Use with care.+--+-- @since 1.2.0.0+--++module Data.Array.Accelerate.Unsafe (++  -- ** Unsafe operations+  undef, coerce,++) where++import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Smart+++-- | The function 'coerce' allows you to convert a value between any two types+-- whose underlying representations have the same bit size at each component.+--+-- For example:+--+-- > coerce (x :: Exp Double)         :: Exp Word64+-- > coerce (x :: Exp (Int64,Float))  :: Exp (Complex Float, Word32)+--+-- Furthermore, as we typically declare newtype wrappers similarly to:+--+-- > type instance EltRepr (Sum a) = ((), EltRepr a)+--+-- This can be used instead of the newtype constructor, to go from the newtype's+-- abstract type to the concrete type by dropping the extra @()@ from the+-- representation, and vice-versa.+--+-- You will get a runtime error if it fails to find a coercion between the two+-- representations.+--+-- @since 1.2.0.0+--+coerce :: (Elt a, Elt b) => Exp a -> Exp b+coerce = mkUnsafeCoerce+
+ src/Data/Atomic.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash                #-}+{-# LANGUAGE NoImplicitPrelude        #-}+{-# LANGUAGE UnboxedTuples            #-}+-- |+-- Module      : Data.Atomic+-- Copyright   : [2016..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)+--+-- Atomic integer values. All operations are thread safe.+--++module Data.Atomic (++  Atomic(..),+  read, write, add, and, subtract,++) where++import Data.Int++import GHC.Ptr+import GHC.Base+++-- | A mutable atomic integer+--+newtype Atomic = Atomic ( Ptr Int64 )++-- -- | Create a new atomic variable initialised to the given value+-- --+-- -- TLM: This is not correct because we need to keep the MutableByteArray#+-- --      around so that it does not get GC'ed. This would have been stored as+-- --      the ForeignPtrContents. Since we don't use this function at the+-- --      moment (all of the atomics we care about are defined in C code) we+-- --      just drop this function for now.+-- --+-- new :: Int64 -> IO Atomic+-- new v = do+--   a <- IO $ \s -> case newPinnedByteArray# 8# s of+--                     (# s', mbarr# #) -> (# s', Atomic (Ptr (byteArrayContents# (unsafeCoerce# mbarr#))) #)+--   write a v+--   return a++-- | Get the current value.+--+foreign import ccall unsafe "atomic_read_64" read :: Atomic -> IO Int64++-- | Set the atomic to the given value.+--+foreign import ccall unsafe "atomic_write_64" write :: Atomic -> Int64 -> IO ()++-- | Increase the atomic by the given amount. Returns the old value.+--+foreign import ccall unsafe "atomic_fetch_and_add_64" add :: Atomic -> Int64 -> IO Int64++-- | Bitwise AND the atomic with the given value. Return the old value.+--+foreign import ccall unsafe "atomic_fetch_and_and_64" and :: Atomic -> Int64 -> IO Int64++-- | Decrement the atomic value by the given amount. Return the old value.+--+foreign import ccall unsafe "atomic_fetch_and_sub_64" subtract :: Atomic -> Int64 -> IO Int64+
+ test/doctest/Main.hs view
@@ -0,0 +1,23 @@+-- |+-- Module      : Main+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Main where++import Build_doctests                           ( flags, pkgs, module_sources )+import Data.Foldable                            ( traverse_ )+import Test.DocTest++main :: IO ()+main = do+  traverse_ putStrLn args+  doctest args+  where+    args = flags ++ pkgs ++ module_sources+
+ test/nofib/Main.hs view
@@ -0,0 +1,23 @@+-- |+-- Module      : nofib-interpreter+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Main where++import Data.Array.Accelerate.Test.NoFib+import Data.Array.Accelerate.Interpreter++import System.Environment++main :: IO ()+main = do+  setEnv "TASTY_INTERPRETER" "True"+  setEnv "TASTY_HEDGEHOG_TESTS" "50"+  nofib runN+