From c7b13b4a75991e4a7378a096806cb4f92a8822c3 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 15 Feb 2019 15:49:29 +0100 Subject: [PATCH 001/316] drop references to the Real class We need to keep it around to satisfy prelude superclass constraints, but there is no point refering to it --- src/Data/Array/Accelerate.hs | 1 - src/Data/Array/Accelerate/Classes.hs | 2 -- src/Data/Array/Accelerate/Classes/Integral.hs | 6 ++++-- src/Data/Array/Accelerate/Classes/RealFrac.hs | 11 +++++------ 4 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index e595cafed..6527a621d 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -313,7 +313,6 @@ module Data.Array.Accelerate ( -- *** 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, diff --git a/src/Data/Array/Accelerate/Classes.hs b/src/Data/Array/Accelerate/Classes.hs index bd16e7496..1414c98d6 100644 --- a/src/Data/Array/Accelerate/Classes.hs +++ b/src/Data/Array/Accelerate/Classes.hs @@ -23,7 +23,6 @@ module Data.Array.Accelerate.Classes ( -- *** Numeric type classes module Num, - module Real, module Integral, module Fractional, module Floating, @@ -45,7 +44,6 @@ import Data.Array.Accelerate.Classes.FromIntegral as FromInteg 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 diff --git a/src/Data/Array/Accelerate/Classes/Integral.hs b/src/Data/Array/Accelerate/Classes/Integral.hs index da3ca59af..43f54b2cd 100644 --- a/src/Data/Array/Accelerate/Classes/Integral.hs +++ b/src/Data/Array/Accelerate/Classes/Integral.hs @@ -31,7 +31,9 @@ import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Enum -import Data.Array.Accelerate.Classes.Real +import Data.Array.Accelerate.Classes.Num +import Data.Array.Accelerate.Classes.Ord +import Data.Array.Accelerate.Classes.Real () import Prelude ( error ) import qualified Prelude as P @@ -39,7 +41,7 @@ import qualified Prelude as P -- | Integral numbers, supporting integral division -- -type Integral a = (Enum a, Real a, P.Integral (Exp a)) +type Integral a = (Enum a, Ord a, Num a, P.Integral (Exp a)) instance P.Integral (Exp Int) where diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs b/src/Data/Array/Accelerate/Classes/RealFrac.hs index 432ad57ec..cc07cae08 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs @@ -34,7 +34,6 @@ import Data.Array.Accelerate.Classes.Fractional import Data.Array.Accelerate.Classes.FromIntegral import Data.Array.Accelerate.Classes.Integral import Data.Array.Accelerate.Classes.Num -import Data.Array.Accelerate.Classes.Real import Data.Array.Accelerate.Classes.ToFloating import {-# SOURCE #-} Data.Array.Accelerate.Classes.RealFloat -- defaultProperFraction @@ -72,7 +71,7 @@ divMod' n d = (f, n - (toFloating f) * d) -- | Extracting components of fractions. -- -class (Real a, Fractional a) => RealFrac a where +class (Ord 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: -- @@ -102,20 +101,20 @@ class (Real a, Fractional a) => RealFrac a where -- splitFraction / fraction are from numeric-prelude Algebra.RealRing -- | @truncate x@ returns the integer nearest @x@ between zero and @x@ - truncate :: (Integral b, FromIntegral Int64 b) => Exp a -> Exp b + truncate :: (Integral b, FromIntegral Int64 b) => Exp a -> Exp b truncate = defaultTruncate -- | @'round' x@ returns the nearest integer to @x@; the even integer if @x@ -- is equidistant between two integers - round :: (Integral b, FromIntegral Int64 b) => Exp a -> Exp b + round :: (Integral b, FromIntegral Int64 b) => Exp a -> Exp b round = defaultRound -- | @'ceiling' x@ returns the least integer not less than @x@ - ceiling :: (Integral b, FromIntegral Int64 b) => Exp a -> Exp b + ceiling :: (Integral b, FromIntegral Int64 b) => Exp a -> Exp b ceiling = defaultCeiling -- | @'floor' x@ returns the greatest integer not greater than @x@ - floor :: (Integral b, FromIntegral Int64 b) => Exp a -> Exp b + floor :: (Integral b, FromIntegral Int64 b) => Exp a -> Exp b floor = defaultFloor instance RealFrac Half where From dd89573ef097502da402d8d34ad554f38a43192c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 15 Feb 2019 17:58:06 +0100 Subject: [PATCH 002/316] simplify these identity instances --- src/Data/Array/Accelerate/Classes/FromIntegral.hs | 4 +++- src/Data/Array/Accelerate/Classes/ToFloating.hs | 7 ++++--- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/FromIntegral.hs b/src/Data/Array/Accelerate/Classes/FromIntegral.hs index 240338851..110e416a5 100644 --- a/src/Data/Array/Accelerate/Classes/FromIntegral.hs +++ b/src/Data/Array/Accelerate/Classes/FromIntegral.hs @@ -81,7 +81,9 @@ $(runQ $ do thFromIntegral a b = let ty = AppT (AppT (ConT (mkName "FromIntegral")) (ConT a)) (ConT b) - dec = ValD (VarP (mkName "fromIntegral")) (NormalB (VarE (mkName "mkFromIntegral"))) [] + dec = ValD (VarP (mkName "fromIntegral")) (NormalB (VarE (mkName f))) [] + f | a == b = "id" + | otherwise = "mkFromIntegral" in instanceD (return []) (return ty) [return dec] -- diff --git a/src/Data/Array/Accelerate/Classes/ToFloating.hs b/src/Data/Array/Accelerate/Classes/ToFloating.hs index dd2bbcf0a..f1162cc59 100644 --- a/src/Data/Array/Accelerate/Classes/ToFloating.hs +++ b/src/Data/Array/Accelerate/Classes/ToFloating.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.Classes.ToFloating @@ -29,7 +28,7 @@ import Data.Array.Accelerate.Classes.Num import Language.Haskell.TH hiding ( Exp ) import Control.Monad -import Prelude ( ($), error, concat ) +import Prelude hiding ( Num, Floating ) -- | Accelerate lacks an arbitrary-precision 'Prelude.Rational' type, which the @@ -77,7 +76,9 @@ $(runQ $ do thToFloating a b = let ty = AppT (AppT (ConT (mkName "ToFloating")) (ConT a)) (ConT b) - dec = ValD (VarP (mkName "toFloating")) (NormalB (VarE (mkName "mkToFloating"))) [] + dec = ValD (VarP (mkName "toFloating")) (NormalB (VarE (mkName f))) [] + f | a == b = "id" + | otherwise = "mkToFloating" in instanceD (return []) (return ty) [return dec] -- From 4cc5a75e76857cb56834a1306581fb7508a6eea0 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 15 Feb 2019 20:30:58 +0100 Subject: [PATCH 003/316] add class Rational --- accelerate.cabal | 1 + src/Data/Array/Accelerate.hs | 1 + src/Data/Array/Accelerate/Classes.hs | 2 + src/Data/Array/Accelerate/Classes/Rational.hs | 96 +++++++++++++++++++ 4 files changed, 100 insertions(+) create mode 100644 src/Data/Array/Accelerate/Classes/Rational.hs diff --git a/accelerate.cabal b/accelerate.cabal index 51b6094b3..e40d85818 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -352,6 +352,7 @@ Library Data.Array.Accelerate.Classes.Integral Data.Array.Accelerate.Classes.Num Data.Array.Accelerate.Classes.Ord + Data.Array.Accelerate.Classes.Rational Data.Array.Accelerate.Classes.Real Data.Array.Accelerate.Classes.RealFloat Data.Array.Accelerate.Classes.RealFrac diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 6527a621d..f2ddaf66f 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -314,6 +314,7 @@ module Data.Array.Accelerate ( -- *** Numeric type classes Num, (+), (-), (*), negate, abs, signum, fromInteger, Integral, quot, rem, div, mod, quotRem, divMod, + Rational(..), 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', diff --git a/src/Data/Array/Accelerate/Classes.hs b/src/Data/Array/Accelerate/Classes.hs index 1414c98d6..6a5f757b6 100644 --- a/src/Data/Array/Accelerate/Classes.hs +++ b/src/Data/Array/Accelerate/Classes.hs @@ -24,6 +24,7 @@ module Data.Array.Accelerate.Classes ( -- *** Numeric type classes module Num, module Integral, + module Rational, module Fractional, module Floating, module RealFrac, @@ -42,6 +43,7 @@ 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.Rational as Rational import Data.Array.Accelerate.Classes.Num as Num import Data.Array.Accelerate.Classes.Ord as Ord import Data.Array.Accelerate.Classes.RealFloat as RealFloat diff --git a/src/Data/Array/Accelerate/Classes/Rational.hs b/src/Data/Array/Accelerate/Classes/Rational.hs new file mode 100644 index 000000000..163be9bc0 --- /dev/null +++ b/src/Data/Array/Accelerate/Classes/Rational.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | +-- Module : Data.Array.Accelerate.Classes.Rational +-- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Classes.Rational ( + + Rational(..) + +) where + +import Data.Array.Accelerate.Data.Ratio +import Data.Array.Accelerate.Data.Bits + +import Data.Array.Accelerate.Language +import Data.Array.Accelerate.Pattern +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.Classes.RealFloat + +import Prelude ( ($) ) + + +-- | Numbers which can be expressed as the quotient of two integers. +-- +-- Accelerate does not have an arbitrary precision Integer type, however +-- fixed-length large integers are provide by the @accelerate-bignum@ +-- package. +-- +class (Num a, Ord a) => Rational a where + -- | Convert a number to the quotient of two integers + -- + toRational :: (FromIntegral Int64 b, Integral b) => Exp a -> Exp (Ratio b) + +instance Rational Int where toRational = integralToRational +instance Rational Int8 where toRational = integralToRational +instance Rational Int16 where toRational = integralToRational +instance Rational Int32 where toRational = integralToRational +instance Rational Int64 where toRational = integralToRational +instance Rational Word where toRational = integralToRational +instance Rational Word8 where toRational = integralToRational +instance Rational Word16 where toRational = integralToRational +instance Rational Word32 where toRational = integralToRational +instance Rational Word64 where toRational = integralToRational + +instance Rational Half where toRational = floatingToRational +instance Rational Float where toRational = floatingToRational +instance Rational Double where toRational = floatingToRational + + +integralToRational + :: (Integral a, Integral b, FromIntegral a Int64, FromIntegral Int64 b) + => Exp a + -> Exp (Ratio b) +integralToRational x = fromIntegral (fromIntegral x :: Exp Int64) :% 1 + +floatingToRational + :: (RealFloat a, Integral b, FromIntegral Int64 b) + => Exp a + -> Exp (Ratio b) +floatingToRational x = fromIntegral u :% fromIntegral v + where + (m, e) = decodeFloat x + (n, d) = elimZeros m (negate e) + u :% v = cond (e >= 0) ((m `shiftL` e) :% 1) $ + cond (m .&. 1 == 0) (n :% shiftL 1 d) $ + (m :% shiftL 1 (negate e)) + +-- Stolen from GHC.Float.ConversionUtils +-- +elimZeros :: Exp Int64 -> Exp Int -> (Exp Int64, Exp Int) -- Integer +elimZeros x y = (u, v) + where + T3 _ u v = while (\(T3 p _ _) -> p) elim (T3 moar x y) + kthxbai = constant False + moar = constant True + + elim :: Exp (Bool, Int64, Int) -> Exp (Bool, Int64, Int) + elim (T3 _ n e) = + let t = countTrailingZeros (fromIntegral n :: Exp Word8) + in + cond (e <= t) (T3 kthxbai (shiftR n e) 0) $ + cond (t < 8) (T3 kthxbai (shiftR n t) (e-t)) $ + (T3 moar (shiftR n 8) (e-8)) + From 4bc63d599cdd4a065d5b12321d109e83fbbe603e Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 16 Feb 2019 17:43:02 +0100 Subject: [PATCH 004/316] update README.md, file headers --- .mailmap | 2 +- HACKING.md | 41 --------------- LICENSE | 4 +- README.md | 51 ++++++++++++++----- accelerate.cabal | 10 +--- cbits/atomic.c | 4 +- cbits/clock.c | 4 +- cbits/flags.c | 4 +- cbits/flags_debug.c | 4 +- cbits/monitoring.c | 4 +- cbits/monitoring_debug.c | 4 +- icebox/FullList.hs | 5 +- icebox/Graphviz.hs | 8 +-- icebox/HTML.hs | 4 +- .../NoFib/Prelude => icebox}/Replicate.hs | 11 +++- .../NoFib/Prelude => icebox}/Sequences.hs | 13 ++++- icebox/Traverse.hs | 7 +-- src/Data/Array/Accelerate.hs | 12 ++--- src/Data/Array/Accelerate/AST.hs | 8 +-- src/Data/Array/Accelerate/Analysis/Hash.hs | 4 +- src/Data/Array/Accelerate/Analysis/Hash/TH.hs | 4 +- src/Data/Array/Accelerate/Analysis/Match.hs | 4 +- src/Data/Array/Accelerate/Analysis/Shape.hs | 5 +- src/Data/Array/Accelerate/Analysis/Stencil.hs | 5 +- src/Data/Array/Accelerate/Analysis/Type.hs | 5 +- src/Data/Array/Accelerate/Array/Data.hs | 5 +- src/Data/Array/Accelerate/Array/Lifted.hs | 4 +- src/Data/Array/Accelerate/Array/Remote.hs | 13 +++-- .../Array/Accelerate/Array/Remote/Class.hs | 5 +- src/Data/Array/Accelerate/Array/Remote/LRU.hs | 5 +- .../Array/Accelerate/Array/Remote/Nursery.hs | 6 +-- .../Array/Accelerate/Array/Remote/Table.hs | 6 +-- .../Array/Accelerate/Array/Representation.hs | 7 +-- src/Data/Array/Accelerate/Array/Sugar.hs | 7 +-- src/Data/Array/Accelerate/Array/Unique.hs | 4 +- src/Data/Array/Accelerate/Async.hs | 4 +- src/Data/Array/Accelerate/Classes.hs | 4 +- src/Data/Array/Accelerate/Classes/Bounded.hs | 4 +- src/Data/Array/Accelerate/Classes/Enum.hs | 4 +- src/Data/Array/Accelerate/Classes/Eq.hs | 4 +- src/Data/Array/Accelerate/Classes/Floating.hs | 4 +- .../Array/Accelerate/Classes/Fractional.hs | 4 +- .../Array/Accelerate/Classes/FromIntegral.hs | 4 +- src/Data/Array/Accelerate/Classes/Integral.hs | 4 +- src/Data/Array/Accelerate/Classes/Num.hs | 4 +- src/Data/Array/Accelerate/Classes/Ord.hs | 4 +- src/Data/Array/Accelerate/Classes/Rational.hs | 4 +- src/Data/Array/Accelerate/Classes/Real.hs | 4 +- .../Array/Accelerate/Classes/RealFloat.hs | 4 +- .../Accelerate/Classes/RealFloat.hs-boot | 4 +- src/Data/Array/Accelerate/Classes/RealFrac.hs | 4 +- .../Array/Accelerate/Classes/RealFrac.hs-boot | 4 +- .../Array/Accelerate/Classes/ToFloating.hs | 4 +- src/Data/Array/Accelerate/Data/Bits.hs | 4 +- src/Data/Array/Accelerate/Data/Complex.hs | 4 +- src/Data/Array/Accelerate/Data/Either.hs | 4 +- src/Data/Array/Accelerate/Data/Fold.hs | 4 +- src/Data/Array/Accelerate/Data/Functor.hs | 4 +- src/Data/Array/Accelerate/Data/Maybe.hs | 4 +- src/Data/Array/Accelerate/Data/Monoid.hs | 4 +- src/Data/Array/Accelerate/Data/Ratio.hs | 2 +- src/Data/Array/Accelerate/Data/Semigroup.hs | 4 +- src/Data/Array/Accelerate/Debug.hs | 5 +- src/Data/Array/Accelerate/Debug/Flags.hs | 5 +- src/Data/Array/Accelerate/Debug/Monitoring.hs | 4 +- src/Data/Array/Accelerate/Debug/Stats.hs | 5 +- src/Data/Array/Accelerate/Debug/Timed.hs | 4 +- src/Data/Array/Accelerate/Debug/Trace.hs | 5 +- src/Data/Array/Accelerate/Error.hs | 4 +- src/Data/Array/Accelerate/Interpreter.hs | 6 +-- src/Data/Array/Accelerate/Language.hs | 6 +-- src/Data/Array/Accelerate/Lifetime.hs | 4 +- src/Data/Array/Accelerate/Lift.hs | 4 +- src/Data/Array/Accelerate/Orphans.hs | 5 +- src/Data/Array/Accelerate/Pattern.hs | 4 +- src/Data/Array/Accelerate/Prelude.hs | 5 +- src/Data/Array/Accelerate/Pretty.hs | 5 +- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 4 +- .../Array/Accelerate/Pretty/Graphviz/Monad.hs | 4 +- .../Array/Accelerate/Pretty/Graphviz/Type.hs | 4 +- src/Data/Array/Accelerate/Pretty/Print.hs | 5 +- src/Data/Array/Accelerate/Product.hs | 6 +-- src/Data/Array/Accelerate/Smart.hs | 7 +-- src/Data/Array/Accelerate/Test/NoFib.hs | 4 +- src/Data/Array/Accelerate/Test/NoFib/Base.hs | 4 +- .../Array/Accelerate/Test/NoFib/Config.hs | 4 +- .../Array/Accelerate/Test/NoFib/Imaginary.hs | 4 +- .../Accelerate/Test/NoFib/Imaginary/DotP.hs | 4 +- .../Accelerate/Test/NoFib/Imaginary/SASUM.hs | 4 +- .../Accelerate/Test/NoFib/Imaginary/SAXPY.hs | 4 +- .../Array/Accelerate/Test/NoFib/Issues.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue102.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue114.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue119.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue123.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue137.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue168.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue184.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue185.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue187.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue228.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue255.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue264.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue286.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue287.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue288.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue362.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue407.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue409.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue93.hs | 4 +- .../Array/Accelerate/Test/NoFib/Prelude.hs | 4 +- .../Test/NoFib/Prelude/Backpermute.hs | 4 +- .../Accelerate/Test/NoFib/Prelude/Filter.hs | 4 +- .../Accelerate/Test/NoFib/Prelude/Fold.hs | 4 +- .../Accelerate/Test/NoFib/Prelude/Map.hs | 4 +- .../Accelerate/Test/NoFib/Prelude/Permute.hs | 4 +- .../Accelerate/Test/NoFib/Prelude/Scan.hs | 4 +- .../Accelerate/Test/NoFib/Prelude/Stencil.hs | 4 +- .../Accelerate/Test/NoFib/Prelude/ZipWith.hs | 4 +- .../Array/Accelerate/Test/NoFib/Sharing.hs | 4 +- .../Array/Accelerate/Test/NoFib/Spectral.hs | 4 +- .../Test/NoFib/Spectral/BlackScholes.hs | 4 +- .../Test/NoFib/Spectral/RadixSort.hs | 4 +- .../Accelerate/Test/NoFib/Spectral/SMVM.hs | 4 +- src/Data/Array/Accelerate/Test/Similar.hs | 4 +- src/Data/Array/Accelerate/Trafo.hs | 4 +- src/Data/Array/Accelerate/Trafo/Algebra.hs | 4 +- src/Data/Array/Accelerate/Trafo/Base.hs | 4 +- src/Data/Array/Accelerate/Trafo/Fusion.hs | 5 +- src/Data/Array/Accelerate/Trafo/Normalise.hs | 4 +- src/Data/Array/Accelerate/Trafo/Rewrite.hs | 4 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 6 +-- src/Data/Array/Accelerate/Trafo/Shrink.hs | 4 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 4 +- .../Array/Accelerate/Trafo/Substitution.hs | 4 +- src/Data/Array/Accelerate/Trafo/Vectorise.hs | 4 +- src/Data/Array/Accelerate/Type.hs | 5 +- src/Data/Array/Accelerate/Unsafe.hs | 4 +- src/Data/Atomic.hs | 4 +- test/doctest/Main.hs | 4 +- test/nofib/Main.hs | 4 +- 141 files changed, 342 insertions(+), 390 deletions(-) delete mode 100644 HACKING.md rename {src/Data/Array/Accelerate/Test/NoFib/Prelude => icebox}/Replicate.hs (93%) rename {src/Data/Array/Accelerate/Test/NoFib/Prelude => icebox}/Sequences.hs (97%) diff --git a/.mailmap b/.mailmap index 31af4331f..9002c5fb0 100644 --- a/.mailmap +++ b/.mailmap @@ -1,3 +1,3 @@ -Trevor L. McDonell +Trevor L. McDonell Ben Lever Frederik M. Madsen diff --git a/HACKING.md b/HACKING.md deleted file mode 100644 index 5559c5591..000000000 --- a/HACKING.md +++ /dev/null @@ -1,41 +0,0 @@ -Developer Notes -=============== - -If you like to hack Accelerate, and especially if you like to contribute changes back, please fork: - - https://github.com/AccelerateHS/accelerate - -and send pull request with your changes. In your pull request, please describe the testing that you have performed. - -In general, testing should involve both the interpreter and the CUDA backend (if you have got access to CUDA compatible hardware). A fairly comprehensive set of tests is available in the `accelerate-examples` package. This directory contains its own cabal-based build system. If you built Accelerate without the CUDA backend, you need to configure `accelerate-examples` with the additional option `-f-cuda` to disable testing of the CUDA backend. - - -Installing from source ----------------------- - -Requirements: - - * Glasgow Haskell Compiler (GHC), version 7.8.3 or later - * For the CUDA backend, CUDA version 5.0 or later - * Haskell libraries as specified in the relevant cabal files - -The recommended way to install from source is to use [`stack`](https://www.haskellstack.org), for example by including the following in the `stack.yaml` file for your project: - -```yaml -resolver: lts-9.0 -extra-deps: -- 'accelerate-llvm-1.1.0.0' -- 'accelerate-llvm-native-1.1.0.0' -- 'accelerate-llvm-ptx-1.1.0.0' -``` - - -New backends ------------- - -If you are considering writing a new backend, you can do so in a separate, standalone package. The Accelerate frontend is entirely independent of any backend, and package `accelerate` exports all the necessary internals. If you run into problems, please contact the [mailing list][Google-Group] or [github issues][Issues] page for assistance. - - - [Issues]: https://github.com/AccelerateHS/accelerate/issues - [Google-Group]: http://groups.google.com/group/accelerate-haskell - diff --git a/LICENSE b/LICENSE index f9a419d82..d06db852b 100644 --- a/LICENSE +++ b/LICENSE @@ -7,8 +7,8 @@ modification, are permitted provided that the following conditions are met: * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the names of the contributors nor of their affiliations may - be used to endorse or promote products derived from this software + * Neither the names of the contributors nor of their affiliations may + be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY diff --git a/README.md b/README.md index 3b12d211a..b1b23cbc0 100644 --- a/README.md +++ b/README.md @@ -17,6 +17,7 @@ For more details, see our papers: * [Optimising Purely Functional GPU Programs][MCKL13] ([slides][MCKL13-slides]) * [Embedding Foreign Code][CMCK14] * [Type-safe Runtime Code Generation: Accelerate to LLVM][MCGN15] ([slides][MCGN15-slides]) ([video][MCGN15-video]) + * [Streaming Irregular Arrays][CMCK17] ([video][CMCK17-video]) There are also slides from some fairly recent presentations: @@ -37,6 +38,7 @@ Chapter 6 of Simon Marlow's book [Parallel and Concurrent Programming in Haskell - [Requirements](#requirements) - [Documentation](#documentation) - [Examples](#examples) + - [Who are we?](#who-are-we) - [Mailing list and contacts](#mailing-list-and-contacts) - [Citing Accelerate](#citing-accelerate) - [What's missing?](#whats-missing) @@ -106,8 +108,8 @@ The [accelerate-examples][accelerate-examples] package provides a range of compu * A cellular automata simulation * A "password recovery" tool, for dictionary lookup of MD5 hashes -[![Mandelbrot](http://i.imgur.com/5Tbsp1j.jpg "accelerate-mandelbrot")](http://i.imgur.com/RgXRqsc.jpg) -[![Raytracer](http://i.imgur.com/7ohhKm9.jpg "accelerate-ray")](http://i.imgur.com/ZNEGEJK.jpg) +[![Mandelbrot](https://i.imgur.com/5Tbsp1j.jpg "accelerate-mandelbrot")](https://i.imgur.com/RgXRqsc.jpg) +[![Raytracer](https://i.imgur.com/7ohhKm9.jpg "accelerate-ray")](https://i.imgur.com/ZNEGEJK.jpg) + * Gabriele Keller (@gckeller) + * Trevor L. McDonell (@tmcdonell) + * Robert Clifton-Everest (@robeverest) + * Frederik M. Madsen (@fmma) + * Ryan R. Newton (@rrnewton) + * Joshua Meredith (@JoshMeredith) + * Ben Lever (@blever) + * Sean Seefried (@sseefried) + +The maintainer and principal developer developer of Accelerate is Trevor L. +McDonell . + + Mailing list and contacts ------------------------- @@ -146,14 +167,13 @@ Mailing list and contacts * Sign up for the mailing list at the [Accelerate Google Groups page][Google-Group]. * Bug reports and issues tracking: [GitHub project page][Issues]. -The maintainers of Accelerate are Manuel M T Chakravarty and Trevor L McDonell . - Citing Accelerate ----------------- If you use Accelerate for academic research, you are encouraged (though not -required) to cite the following papers ([BibTeX](http://www.cse.unsw.edu.au/~tmcdonell/papers/accelerate.bib)): +required) to cite the following papers: + * Manuel M. T. Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell, and Vinod Grover. [Accelerating Haskell Array Codes with Multicore GPUs][CKLM+11]. @@ -171,6 +191,11 @@ required) to cite the following papers ([BibTeX](http://www.cse.unsw.edu.au/~tmc [Type-safe Runtime Code Generation: Accelerate to LLVM][MCGN15]. In _Haskell '15: The 8th ACM SIGPLAN Symposium on Haskell_, ACM, 2015. + * Robert Clifton-Everest, Trevor L. McDonell, Manuel M. T. Chakravarty, and Gabriele Keller. + [Streaming Irregular Arrays][CMCK17]. + In Haskell '17: The 10th ACM SIGPLAN Symposium on Haskell, ACM, 2017. + + Accelerate is primarily developed by academics, so citations matter a lot to us. As an added benefit, you increase Accelerate's exposure and potential user (and developer!) base, which is a benefit to all users of Accelerate. Thanks in advance! @@ -182,17 +207,19 @@ What's missing? Here is a list of features that are currently missing: * Preliminary API (parts of the API may still change in subsequent releases) + * Many more features... contact us! - - [CKLM+11]: http://www.cse.unsw.edu.au/~chak/papers/CKLM+11.html - [MCKL13]: http://www.cse.unsw.edu.au/~chak/papers/MCKL13.html + [CKLM+11]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-cuda-damp2011.pdf + [MCKL13]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-optim-icfp2013.pdf [MCKL13-slides]: https://speakerdeck.com/tmcdonell/optimising-purely-functional-gpu-programs - [CMCK14]: http://www.cse.unsw.edu.au/~chak/papers/CMCK14.html - [MCGN15]: http://www.cse.unsw.edu.au/~chak/papers/MCGN15.html + [CMCK14]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-ffi-padl2014.pdf + [MCGN15]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-llvm-haskell2015.pdf [MCGN15-slides]: https://speakerdeck.com/tmcdonell/type-safe-runtime-code-generation-accelerate-to-llvm [MCGN15-video]: https://www.youtube.com/watch?v=snXhXA5noVc [HIW'09]: https://wiki.haskell.org/HaskellImplementorsWorkshop + [CMCK17]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-seq2-haskell2017.pdf + [CMCK17-video]: https://www.youtube.com/watch?v=QIWSqp7AaNo [Mar13]: http://chimera.labs.oreilly.com/books/1230000000929 [Embedded]: https://speakerdeck.com/mchakravarty/embedded-languages-for-high-performance-computing-in-haskell [Hackage]: http://hackage.haskell.org/package/accelerate @@ -226,7 +253,7 @@ Here is a list of features that are currently missing: [wiki-nbody]: https://en.wikipedia.org/wiki/N-body [wiki-raytracing]: https://en.wikipedia.org/wiki/Ray_tracing [wiki-pagerank]: https://en.wikipedia.org/wiki/Pagerank - [Trevor-thesis]: http://www.cse.unsw.edu.au/~tmcdonell/papers/TrevorMcDonell_PhD_submission.pdf + [Trevor-thesis]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/TrevorMcDonell_PhD_Thesis.pdf [colour-accelerate]: https://github.com/tmcdonell/colour-accelerate [gloss]: https://hackage.haskell.org/package/gloss [gloss-accelerate]: https://github.com/tmcdonell/gloss-accelerate diff --git a/accelerate.cabal b/accelerate.cabal index e40d85818..083e1fc32 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -112,14 +112,8 @@ Description: License: BSD3 License-file: LICENSE -Author: Manuel M T Chakravarty, - Robert Clifton-Everest, - Gabriele Keller, - Ben Lever, - Trevor L. McDonell, - Ryan Newtown, - Sean Seefried -Maintainer: Trevor L. McDonell +Author: The Accelerate Team +Maintainer: Trevor L. McDonell Homepage: https://github.com/AccelerateHS/accelerate/ Bug-reports: https://github.com/AccelerateHS/accelerate/issues diff --git a/cbits/atomic.c b/cbits/atomic.c index ca61523c6..157ac0eed 100644 --- a/cbits/atomic.c +++ b/cbits/atomic.c @@ -1,9 +1,9 @@ /* * Module : Data.Atomic - * Copyright : [2017] Trevor L. McDonell + * Copyright : [2017..2019] The Accelerate Team * License : BSD3 * - * Maintainer : Trevor L. McDonell + * Maintainer : Trevor L. McDonell * Stability : experimental * Portability : non-portable (GHC extensions) * diff --git a/cbits/clock.c b/cbits/clock.c index bbc8e25ed..ddfdaea27 100644 --- a/cbits/clock.c +++ b/cbits/clock.c @@ -1,9 +1,9 @@ /* * Module : Data.Array.Accelerate.Debug.Clock - * Copyright : [2017] Trevor L. McDonell + * Copyright : [2017..2019] The Accelerate Team * License : BSD3 * - * Maintainer : Trevor L. McDonell + * Maintainer : Trevor L. McDonell * Stability : experimental * Portability : non-portable (GHC extensions) * diff --git a/cbits/flags.c b/cbits/flags.c index e9da6e3d3..41aeda68d 100644 --- a/cbits/flags.c +++ b/cbits/flags.c @@ -1,9 +1,9 @@ /* * Module : Data.Array.Accelerate.Debug.Flags - * Copyright : [2017] Trevor L. McDonell + * Copyright : [2017..2019] The Accelerate Team * License : BSD3 * - * Maintainer : Trevor L. McDonell + * Maintainer : Trevor L. McDonell * Stability : experimental * Portability : non-portable (GHC extensions) * diff --git a/cbits/flags_debug.c b/cbits/flags_debug.c index 82d7e9769..7598b3475 100644 --- a/cbits/flags_debug.c +++ b/cbits/flags_debug.c @@ -1,9 +1,9 @@ /* * Module : Data.Array.Accelerate.Debug.Flags - * Copyright : [2017] Trevor L. McDonell + * Copyright : [2017..2019] The Accelerate Team * License : BSD3 * - * Maintainer : Trevor L. McDonell + * Maintainer : Trevor L. McDonell * Stability : experimental * Portability : non-portable (GHC extensions) */ diff --git a/cbits/monitoring.c b/cbits/monitoring.c index 8b723b86f..e4937ed72 100644 --- a/cbits/monitoring.c +++ b/cbits/monitoring.c @@ -1,9 +1,9 @@ /* * Module : Data.Array.Accelerate.Debug.Monitoring - * Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell + * Copyright : [2016..2019] The Accelerate Team * License : BSD3 * - * Maintainer : Trevor L. McDonell + * Maintainer : Trevor L. McDonell * Stability : experimental * Portability : non-portable (GHC extensions) * diff --git a/cbits/monitoring_debug.c b/cbits/monitoring_debug.c index 2940c4bd3..058817eac 100644 --- a/cbits/monitoring_debug.c +++ b/cbits/monitoring_debug.c @@ -1,9 +1,9 @@ /* * Module : Data.Array.Accelerate.Debug.Monitoring - * Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell + * Copyright : [2016..2019] The Accelerate Team * License : BSD3 * - * Maintainer : Trevor L. McDonell + * Maintainer : Trevor L. McDonell * Stability : experimental * Portability : non-portable (GHC extensions) */ diff --git a/icebox/FullList.hs b/icebox/FullList.hs index 20b55de11..d4c6d38f5 100644 --- a/icebox/FullList.hs +++ b/icebox/FullList.hs @@ -3,11 +3,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.FullList --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell +-- Copyright : [2008..2017] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/icebox/Graphviz.hs b/icebox/Graphviz.hs index 2dceb61c9..c5dc97ac5 100644 --- a/icebox/Graphviz.hs +++ b/icebox/Graphviz.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE GADTs, TypeOperators, ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Pretty.Graphviz --- Copyright : [2010..2011] Sean Seefried +-- Copyright : [2010..2011] The Accelerate Team -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/icebox/HTML.hs b/icebox/HTML.hs index 3cea65b2a..542f786c8 100644 --- a/icebox/HTML.hs +++ b/icebox/HTML.hs @@ -3,10 +3,10 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.Pretty.HTML --- Copyright : [2010..2011] Sean Seefried +-- Copyright : [2010..2011] The Accelerate Team -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Replicate.hs b/icebox/Replicate.hs similarity index 93% rename from src/Data/Array/Accelerate/Test/NoFib/Prelude/Replicate.hs rename to icebox/Replicate.hs index 4f83ea6ed..7f4ffe24a 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Replicate.hs +++ b/icebox/Replicate.hs @@ -2,8 +2,17 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Replicate +-- Copyright : [2009..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- -module Test.Prelude.Replicate ( +module Data.Array.Accelerate.Test.NoFib.Prelude.Replicate ( test_replicate, diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Sequences.hs b/icebox/Sequences.hs similarity index 97% rename from src/Data/Array/Accelerate/Test/NoFib/Prelude/Sequences.hs rename to icebox/Sequences.hs index 3b9ad9707..f37edd6db 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Sequences.hs +++ b/icebox/Sequences.hs @@ -6,8 +6,17 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} - -module Test.Prelude.Sequences ( +-- | +-- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Sequences +-- Copyright : [2009..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Test.NoFib.Prelude.Sequences ( test_sequences diff --git a/icebox/Traverse.hs b/icebox/Traverse.hs index 95a4ec042..98d74f223 100644 --- a/icebox/Traverse.hs +++ b/icebox/Traverse.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE GADTs, ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.Pretty.Traverse --- Copyright : [2010..2011] Sean Seefried +-- Copyright : [2010..2011] The Accelerate Team -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index f2ddaf66f..9afaca78c 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -3,13 +3,10 @@ {-# LANGUAGE TypeApplications #-} -- | -- 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -142,10 +139,7 @@ -- -- * Bug reports: https://github.com/AccelerateHS/accelerate/issues -- --- * Maintainers: --- --- * Trevor L. McDonell: --- * Manuel M T Chakravarty: +-- * Maintainer: Trevor L. McDonell: -- -- [/Tip:/] -- diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index c091c309a..17dc111c8 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -19,14 +19,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index fafcd9dca..c31789046 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -9,10 +9,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Analysis.Hash --- Copyright : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2017..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Analysis/Hash/TH.hs b/src/Data/Array/Accelerate/Analysis/Hash/TH.hs index 6b7e02c7a..06d97a318 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash/TH.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash/TH.hs @@ -1,9 +1,9 @@ -- | -- Module : Data.Array.Accelerate.Analysis.Hash.TH --- Copyright : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2017..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index 1a0054906..ab60f9a23 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -9,10 +9,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Analysis.Match --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Analysis/Shape.hs b/src/Data/Array/Accelerate/Analysis/Shape.hs index ade840be0..141d34cee 100644 --- a/src/Data/Array/Accelerate/Analysis/Shape.hs +++ b/src/Data/Array/Accelerate/Analysis/Shape.hs @@ -6,11 +6,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Analysis.Shape --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Analysis/Stencil.hs b/src/Data/Array/Accelerate/Analysis/Stencil.hs index a8122f3bc..283f7b2c1 100644 --- a/src/Data/Array/Accelerate/Analysis/Stencil.hs +++ b/src/Data/Array/Accelerate/Analysis/Stencil.hs @@ -4,11 +4,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Analysis.Stencil --- Copyright : [2010..2011] Ben Lever --- [2010..2017] Trevor L. McDonell +-- Copyright : [2010..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Analysis/Type.hs b/src/Data/Array/Accelerate/Analysis/Type.hs index 403282413..bbacc2674 100644 --- a/src/Data/Array/Accelerate/Analysis/Type.hs +++ b/src/Data/Array/Accelerate/Analysis/Type.hs @@ -8,11 +8,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Analysis.Type --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 40b625557..6c70275af 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -13,11 +13,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Data --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Array/Lifted.hs b/src/Data/Array/Accelerate/Array/Lifted.hs index 1a5b29215..4001ae5d8 100644 --- a/src/Data/Array/Accelerate/Array/Lifted.hs +++ b/src/Data/Array/Accelerate/Array/Lifted.hs @@ -9,10 +9,10 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Data.Array.Accelerate.Array.Lifted --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Robert Clifton-Everest +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Array/Remote.hs b/src/Data/Array/Accelerate/Array/Remote.hs index 04a824eb4..cc8c03ad4 100644 --- a/src/Data/Array/Accelerate/Array/Remote.hs +++ b/src/Data/Array/Accelerate/Array/Remote.hs @@ -1,18 +1,17 @@ {-# 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 +-- Copyright : [2015..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Robert Clifton-Everest +-- Maintainer : Trevor L. McDonell -- 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. +-- 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 ( diff --git a/src/Data/Array/Accelerate/Array/Remote/Class.hs b/src/Data/Array/Accelerate/Array/Remote/Class.hs index 78bcdcf50..59510f7c2 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Class.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Class.hs @@ -4,11 +4,10 @@ {-# 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 +-- Copyright : [2015..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Robert Clifton-Everest +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs index 38943678b..5f414c344 100644 --- a/src/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/src/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -12,11 +12,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Remote.LRU --- Copyright : [2015..2017] Manuel M T Chakravarty, Gabriele Keller, Robert Clifton-Everest --- [2016..2017] Trevor L. McDonell +-- Copyright : [2015..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Robert Clifton-Everest +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Array/Remote/Nursery.hs b/src/Data/Array/Accelerate/Array/Remote/Nursery.hs index 2bfe31cb3..007c685fc 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Nursery.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Nursery.hs @@ -3,12 +3,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Array/Remote/Table.hs b/src/Data/Array/Accelerate/Array/Remote/Table.hs index 62940ccfc..cf469cb3d 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Table.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Table.hs @@ -15,12 +15,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Robert Clifton-Everest +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index d1ee4cfe6..4a0d62b31 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -12,13 +12,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 16c57241c..518ad323f 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -22,13 +22,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Array/Unique.hs b/src/Data/Array/Accelerate/Array/Unique.hs index 913f440bf..bdaa87bab 100644 --- a/src/Data/Array/Accelerate/Array/Unique.hs +++ b/src/Data/Array/Accelerate/Array/Unique.hs @@ -1,10 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Unique --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Async.hs b/src/Data/Array/Accelerate/Async.hs index c4dd776cc..b227a5320 100644 --- a/src/Data/Array/Accelerate/Async.hs +++ b/src/Data/Array/Accelerate/Async.hs @@ -4,10 +4,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Async --- Copyright : [2009..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes.hs b/src/Data/Array/Accelerate/Classes.hs index 6a5f757b6..7e7d15092 100644 --- a/src/Data/Array/Accelerate/Classes.hs +++ b/src/Data/Array/Accelerate/Classes.hs @@ -1,10 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : Data.Array.Accelerate.Classes --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Bounded.hs b/src/Data/Array/Accelerate/Classes/Bounded.hs index 736ebfc98..efc511872 100644 --- a/src/Data/Array/Accelerate/Classes/Bounded.hs +++ b/src/Data/Array/Accelerate/Classes/Bounded.hs @@ -5,10 +5,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Bounded --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Enum.hs b/src/Data/Array/Accelerate/Classes/Enum.hs index eeb8a41ae..ae11bd347 100644 --- a/src/Data/Array/Accelerate/Classes/Enum.hs +++ b/src/Data/Array/Accelerate/Classes/Enum.hs @@ -5,10 +5,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Enum --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 8a5c9e903..5ff000dd8 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -4,10 +4,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Eq --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Floating.hs b/src/Data/Array/Accelerate/Classes/Floating.hs index 55bf5191c..344d3758b 100644 --- a/src/Data/Array/Accelerate/Classes/Floating.hs +++ b/src/Data/Array/Accelerate/Classes/Floating.hs @@ -6,10 +6,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Floating --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Fractional.hs b/src/Data/Array/Accelerate/Classes/Fractional.hs index ca84f92ae..cd081b767 100644 --- a/src/Data/Array/Accelerate/Classes/Fractional.hs +++ b/src/Data/Array/Accelerate/Classes/Fractional.hs @@ -5,10 +5,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Fractional --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/FromIntegral.hs b/src/Data/Array/Accelerate/Classes/FromIntegral.hs index 110e416a5..a4c68d8a2 100644 --- a/src/Data/Array/Accelerate/Classes/FromIntegral.hs +++ b/src/Data/Array/Accelerate/Classes/FromIntegral.hs @@ -6,10 +6,10 @@ {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.Classes.FromIntegral --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Integral.hs b/src/Data/Array/Accelerate/Classes/Integral.hs index 43f54b2cd..e03751a66 100644 --- a/src/Data/Array/Accelerate/Classes/Integral.hs +++ b/src/Data/Array/Accelerate/Classes/Integral.hs @@ -6,10 +6,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Integral --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Num.hs b/src/Data/Array/Accelerate/Classes/Num.hs index 00bc09b26..15203639a 100644 --- a/src/Data/Array/Accelerate/Classes/Num.hs +++ b/src/Data/Array/Accelerate/Classes/Num.hs @@ -5,10 +5,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Num --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index c48e7bc3f..4f1a4f4b9 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -5,10 +5,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Ord --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Rational.hs b/src/Data/Array/Accelerate/Classes/Rational.hs index 163be9bc0..3baadf364 100644 --- a/src/Data/Array/Accelerate/Classes/Rational.hs +++ b/src/Data/Array/Accelerate/Classes/Rational.hs @@ -1,10 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Data.Array.Accelerate.Classes.Rational --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/Real.hs b/src/Data/Array/Accelerate/Classes/Real.hs index 209b7f4d3..879f1f0e3 100644 --- a/src/Data/Array/Accelerate/Classes/Real.hs +++ b/src/Data/Array/Accelerate/Classes/Real.hs @@ -7,10 +7,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Real --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs b/src/Data/Array/Accelerate/Classes/RealFloat.hs index 84d7cb117..1ca0eae40 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs @@ -11,10 +11,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.RealFloat --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot b/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot index f86c8a49b..b2e83ed6a 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot @@ -2,10 +2,10 @@ {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Data.Array.Accelerate.Classes.RealFloat --- Copyright : [2019] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs b/src/Data/Array/Accelerate/Classes/RealFrac.hs index cc07cae08..ae517f69d 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs @@ -7,10 +7,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.RealFrac --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs-boot b/src/Data/Array/Accelerate/Classes/RealFrac.hs-boot index f34eb5b22..00a7f96c9 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs-boot +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs-boot @@ -1,10 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : Data.Array.Accelerate.Classes.RealFrac --- Copyright : [2019] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Classes/ToFloating.hs b/src/Data/Array/Accelerate/Classes/ToFloating.hs index f1162cc59..9f6ea8fa7 100644 --- a/src/Data/Array/Accelerate/Classes/ToFloating.hs +++ b/src/Data/Array/Accelerate/Classes/ToFloating.hs @@ -6,10 +6,10 @@ {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.Classes.ToFloating --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Data/Bits.hs b/src/Data/Array/Accelerate/Data/Bits.hs index 23cdc861e..013e20acd 100644 --- a/src/Data/Array/Accelerate/Data/Bits.hs +++ b/src/Data/Array/Accelerate/Data/Bits.hs @@ -7,10 +7,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Data.Bits --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index cedc93f7f..bb5a89b90 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -13,10 +13,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Complex --- Copyright : [2015..2017] Trevor L. McDonell +-- Copyright : [2015..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index 6e3c3203b..5881001fa 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -10,10 +10,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Either --- Copyright : [2018] Trevor L. McDonell +-- Copyright : [2018..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Data/Fold.hs b/src/Data/Array/Accelerate/Data/Fold.hs index f825f3d7a..3163d1df0 100644 --- a/src/Data/Array/Accelerate/Data/Fold.hs +++ b/src/Data/Array/Accelerate/Data/Fold.hs @@ -5,10 +5,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Data.Fold --- Copyright : [2016..2017] Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Data/Functor.hs b/src/Data/Array/Accelerate/Data/Functor.hs index dfbd18ed4..d6703f2ef 100644 --- a/src/Data/Array/Accelerate/Data/Functor.hs +++ b/src/Data/Array/Accelerate/Data/Functor.hs @@ -2,10 +2,10 @@ {-# LANGUAGE RebindableSyntax #-} -- | -- Module : Data.Array.Accelerate.Data.Functor --- Copyright : [2018] Trevor L. McDonell +-- Copyright : [2018..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index f7a2313d5..f3e3901e0 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -10,10 +10,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Maybe --- Copyright : [2018] Trevor L. McDonell +-- Copyright : [2018..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Data/Monoid.hs b/src/Data/Array/Accelerate/Data/Monoid.hs index 568591982..1948c942a 100644 --- a/src/Data/Array/Accelerate/Data/Monoid.hs +++ b/src/Data/Array/Accelerate/Data/Monoid.hs @@ -12,10 +12,10 @@ #endif -- | -- Module : Data.Array.Accelerate.Data.Monoid --- Copyright : [2016..2017] Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Data/Ratio.hs b/src/Data/Array/Accelerate/Data/Ratio.hs index 36ef6bc7b..10b8441a3 100644 --- a/src/Data/Array/Accelerate/Data/Ratio.hs +++ b/src/Data/Array/Accelerate/Data/Ratio.hs @@ -10,7 +10,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Ratio --- Copyright : [2019] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2019] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Semigroup.hs b/src/Data/Array/Accelerate/Data/Semigroup.hs index 888e02c79..369bdcac5 100644 --- a/src/Data/Array/Accelerate/Data/Semigroup.hs +++ b/src/Data/Array/Accelerate/Data/Semigroup.hs @@ -14,10 +14,10 @@ #endif -- | -- Module : Data.Array.Accelerate.Data.Semigroup --- Copyright : [2018] Trevor L. McDonell +-- Copyright : [2018..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Debug.hs b/src/Data/Array/Accelerate/Debug.hs index b13d12717..941f43f71 100644 --- a/src/Data/Array/Accelerate/Debug.hs +++ b/src/Data/Array/Accelerate/Debug.hs @@ -2,11 +2,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Debug --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index ac08e4208..4fbaaa790 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -7,11 +7,10 @@ #endif -- | -- Module : Data.Array.Accelerate.Debug.Flags --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Debug/Monitoring.hs b/src/Data/Array/Accelerate/Debug/Monitoring.hs index 0ad87452d..a0a1263f4 100644 --- a/src/Data/Array/Accelerate/Debug/Monitoring.hs +++ b/src/Data/Array/Accelerate/Debug/Monitoring.hs @@ -6,10 +6,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Debug.Monitoring --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Debug/Stats.hs b/src/Data/Array/Accelerate/Debug/Stats.hs index 3ff217406..dd3498ca6 100644 --- a/src/Data/Array/Accelerate/Debug/Stats.hs +++ b/src/Data/Array/Accelerate/Debug/Stats.hs @@ -3,11 +3,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Debug/Timed.hs b/src/Data/Array/Accelerate/Debug/Timed.hs index 416456e8c..18bb673df 100644 --- a/src/Data/Array/Accelerate/Debug/Timed.hs +++ b/src/Data/Array/Accelerate/Debug/Timed.hs @@ -3,10 +3,10 @@ {-# LANGUAGE MagicHash #-} -- | -- Module : Data.Array.Accelerate.Debug.Timed --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Debug/Trace.hs b/src/Data/Array/Accelerate/Debug/Trace.hs index 3f5564d1d..c33cbc0ed 100644 --- a/src/Data/Array/Accelerate/Debug/Trace.hs +++ b/src/Data/Array/Accelerate/Debug/Trace.hs @@ -3,11 +3,10 @@ {-# LANGUAGE ForeignFunctionInterface #-} -- | -- Module : Data.Array.Accelerate.Debug.Trace --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Error.hs b/src/Data/Array/Accelerate/Error.hs index 40cacde10..97cc7812f 100644 --- a/src/Data/Array/Accelerate/Error.hs +++ b/src/Data/Array/Accelerate/Error.hs @@ -5,10 +5,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Error --- Copyright : [2009..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 72c9a7b5a..6a582ce85 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -16,12 +16,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 1620b74f8..60241c2b1 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -6,12 +6,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Lifetime.hs b/src/Data/Array/Accelerate/Lifetime.hs index 6591e5b20..ed22f523b 100644 --- a/src/Data/Array/Accelerate/Lifetime.hs +++ b/src/Data/Array/Accelerate/Lifetime.hs @@ -5,10 +5,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Lifetime --- Copyright : [2015..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest +-- Copyright : [2015..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Robert Clifton-Everest +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 26c01dba8..902f6d22b 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -13,10 +13,10 @@ #endif -- | -- Module : Data.Array.Accelerate.Lift --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Orphans.hs b/src/Data/Array/Accelerate/Orphans.hs index 0e6937a8c..b8905fbec 100644 --- a/src/Data/Array/Accelerate/Orphans.hs +++ b/src/Data/Array/Accelerate/Orphans.hs @@ -6,11 +6,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Orphans --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2018] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 91e342568..46c079dc5 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -10,10 +10,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pattern --- Copyright : [2018..2018] Joshua Meredith, Trevor L. McDonell +-- Copyright : [2018..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index b78bc7014..ac0d8f795 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -13,11 +13,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Prelude --- Copyright : [2009..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- [2010..2011] Ben Lever +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index 8092a9f9d..e96348c31 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -6,11 +6,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Pretty --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index c9560f33b..763449d99 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -13,10 +13,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pretty.Graphviz --- Copyright : [2015..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2015..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs b/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs index 3b101516b..5b728d9be 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RecordWildCards #-} -- | -- Module : Data.Array.Accelerate.Pretty.Graphviz.Monad --- Copyright : [2015..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2015..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs b/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs index 29deb4a41..5cc2f8f6e 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs @@ -2,10 +2,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pretty.Graphviz.Type --- Copyright : [2015..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2015..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 3dc1bffd5..f988990a7 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -8,11 +8,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Pretty.Print --- Copyright : [2008..2017] Manuel M T Chakravarty, Gabriele Keller --- [2009..2017] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Product.hs b/src/Data/Array/Accelerate/Product.hs index 4501638c5..57b9de7fb 100644 --- a/src/Data/Array/Accelerate/Product.hs +++ b/src/Data/Array/Accelerate/Product.hs @@ -13,12 +13,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index e1499bd95..c418067c1 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -12,13 +12,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib.hs b/src/Data/Array/Accelerate/Test/NoFib.hs index 9aefb851a..a81d298e6 100644 --- a/src/Data/Array/Accelerate/Test/NoFib.hs +++ b/src/Data/Array/Accelerate/Test/NoFib.hs @@ -3,10 +3,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Base.hs b/src/Data/Array/Accelerate/Test/NoFib/Base.hs index 17d275e2f..e81bf0983 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Base.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Base.hs @@ -3,10 +3,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Base --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Config.hs b/src/Data/Array/Accelerate/Test/NoFib/Config.hs index f645a6379..657e00d9c 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Config.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Config.hs @@ -4,10 +4,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Config --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs index 605622ae8..992d11820 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Imaginary --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs index 0f13faaec..196541362 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs @@ -6,10 +6,10 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Imaginary.DotP --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs index 1f439a1a8..f87b791be 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs @@ -6,10 +6,10 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Imaginary.SASUM --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs index 4af970fdb..e0dd2cadc 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs @@ -6,10 +6,10 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Imaginary.SAXPY --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs index 9702e39c4..39fa060ec 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs index 29462f4cf..592e98523 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs @@ -2,10 +2,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue102 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs index 1d6f23244..7bf8df932 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue114 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs index 4fd1ad1fd..58d486d8e 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue119 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs index d5b7a9230..95972d3fe 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue123 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs index af0e47d2b..b61ed1850 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs @@ -3,10 +3,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue137 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs index 95a12b090..05a320ad7 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue168 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs index 1a64dd1af..eaa9c8f19 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs @@ -2,10 +2,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue184 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs index 514420aa3..cd9613807 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs @@ -6,10 +6,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue185 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs index 8ea0da17b..140f015eb 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs @@ -2,10 +2,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue187 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs index 2e7853ea8..ca31d3758 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs @@ -3,10 +3,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue228 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs index e40922e68..6235c34ae 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs @@ -5,10 +5,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue255 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs index 9b2db0ce6..b396f3a9e 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs @@ -7,10 +7,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue264 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue286.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue286.hs index 5dbd84849..c9d47f5f5 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue286.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue286.hs @@ -3,10 +3,10 @@ {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue286 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs index dd4ed2761..ac223e261 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs @@ -4,10 +4,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue287 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs index c7d0fc764..0d9e85033 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue288 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs index 51fdcb1e4..cb3440421 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue362 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs index 6ad001306..e431981f1 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs @@ -7,10 +7,10 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue407 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs index 4acc50b67..385e126fa 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs @@ -6,10 +6,10 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue409 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs index 7f1885e6e..5a32eac28 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue93 --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs index a8c166c40..2fe80e8a8 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs index 7f6f392e3..561d6553d 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs @@ -7,10 +7,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs index cace35c57..81c2fdc99 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs @@ -9,10 +9,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Filter --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs index 09c3c9301..d44c840cb 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs @@ -7,10 +7,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Fold --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs index 09739c570..747ffcafc 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs @@ -9,10 +9,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Map --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs index 7b1639f4d..31bf21931 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs @@ -7,10 +7,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Permute --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs index 4538188d6..22c06786d 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs @@ -7,10 +7,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Scan --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs index 034914ead..465fba69c 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs @@ -10,10 +10,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Stencil --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs index 0e0170bec..26b2b1455 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs @@ -8,10 +8,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.ZipWith --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs b/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs index 944c7b8e1..62a9a3030 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs @@ -5,10 +5,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Sharing --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral.hs index 8541f9047..9b0933433 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Spectral --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs index 49b2b6cae..adbfdaec5 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs @@ -8,10 +8,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Spectral.BlackScholes --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs index a27586109..c8be0ff1e 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs @@ -8,10 +8,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Spectral.RadixSort --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs index 089bfa778..b78714a01 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs @@ -7,10 +7,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Spectral.SMVM --- Copyright : [2009..2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Test/Similar.hs b/src/Data/Array/Accelerate/Test/Similar.hs index a0aad38a0..c70dba4cf 100644 --- a/src/Data/Array/Accelerate/Test/Similar.hs +++ b/src/Data/Array/Accelerate/Test/Similar.hs @@ -6,10 +6,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Test.Similar --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 2eae36b3e..0c55deec8 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -8,10 +8,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index 870338a07..c23908a7c 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -10,10 +10,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Trafo.Algebra --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index fe2ce4add..ea742b43c 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -17,10 +17,10 @@ #endif -- | -- Module : Data.Array.Accelerate.Trafo.Base --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index d979cf54a..9683bdcd0 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -16,11 +16,10 @@ {-# 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 +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Normalise.hs b/src/Data/Array/Accelerate/Trafo/Normalise.hs index 28659307c..69523917b 100644 --- a/src/Data/Array/Accelerate/Trafo/Normalise.hs +++ b/src/Data/Array/Accelerate/Trafo/Normalise.hs @@ -1,10 +1,10 @@ {-# LANGUAGE GADTs #-} -- | -- Module : Data.Array.Accelerate.Trafo.Normalise --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Rewrite.hs b/src/Data/Array/Accelerate/Trafo/Rewrite.hs index 101ebae79..94e08620b 100644 --- a/src/Data/Array/Accelerate/Trafo/Rewrite.hs +++ b/src/Data/Array/Accelerate/Trafo/Rewrite.hs @@ -2,10 +2,10 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Array.Accelerate.Trafo.Rewrite --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 93384faa2..a20432ade 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -15,12 +15,10 @@ {-# 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 +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 498fd8c89..c1bf15f2d 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -5,10 +5,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Trafo.Shrink --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index 06984206f..f647eee98 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -13,10 +13,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Trafo.Simplify --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index c72c0fbbc..a4cc56083 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -10,10 +10,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Substitution --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Trafo/Vectorise.hs b/src/Data/Array/Accelerate/Trafo/Vectorise.hs index 780d07a1c..4333c1735 100644 --- a/src/Data/Array/Accelerate/Trafo/Vectorise.hs +++ b/src/Data/Array/Accelerate/Trafo/Vectorise.hs @@ -19,10 +19,10 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | -- Module : Data.Array.Accelerate.Trafo.Vectorise --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell, Robert Clifton-Everest +-- Copyright : [2012..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Robert Clifton-Everest +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index 01545c560..cf4652540 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -20,11 +20,10 @@ #endif -- | -- Module : Data.Array.Accelerate.Type --- Copyright : [2008..2018] Manuel M T Chakravarty, Gabriele Keller --- [2009..2018] Trevor L. McDonell +-- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Unsafe.hs b/src/Data/Array/Accelerate/Unsafe.hs index 24cc09bd2..82824e28f 100644 --- a/src/Data/Array/Accelerate/Unsafe.hs +++ b/src/Data/Array/Accelerate/Unsafe.hs @@ -1,9 +1,9 @@ -- | -- Module : Data.Array.Accelerate.Unsafe --- Copyright : [2009..2018] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2009..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Atomic.hs b/src/Data/Atomic.hs index 4593b94f8..b83c1c249 100644 --- a/src/Data/Atomic.hs +++ b/src/Data/Atomic.hs @@ -4,10 +4,10 @@ {-# LANGUAGE UnboxedTuples #-} -- | -- Module : Data.Atomic --- Copyright : [2016..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2016..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/doctest/Main.hs b/test/doctest/Main.hs index 57d21dbf9..68e7106ef 100644 --- a/test/doctest/Main.hs +++ b/test/doctest/Main.hs @@ -1,9 +1,9 @@ -- | -- Module : Main --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/nofib/Main.hs b/test/nofib/Main.hs index 343e3f517..47ba1e1cd 100644 --- a/test/nofib/Main.hs +++ b/test/nofib/Main.hs @@ -1,9 +1,9 @@ -- | -- Module : nofib-interpreter --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2019] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- From d948d737683bc2f340b56319a4412505274502fc Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 16 Feb 2019 17:48:56 +0100 Subject: [PATCH 005/316] update README.md --- README.md | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index b1b23cbc0..cd9111512 100644 --- a/README.md +++ b/README.md @@ -146,17 +146,17 @@ Who are we? The Accelerate team (past and present) consists of: - * Manuel M T Chakravarty (@mchakravarty) - * Gabriele Keller (@gckeller) - * Trevor L. McDonell (@tmcdonell) - * Robert Clifton-Everest (@robeverest) - * Frederik M. Madsen (@fmma) - * Ryan R. Newton (@rrnewton) - * Joshua Meredith (@JoshMeredith) - * Ben Lever (@blever) - * Sean Seefried (@sseefried) - -The maintainer and principal developer developer of Accelerate is Trevor L. + * Manuel M T Chakravarty ([@mchakravarty]) + * Gabriele Keller ([@gckeller]) + * Trevor L. McDonell ([@tmcdonell]) + * Robert Clifton-Everest ([@robeverest]) + * Frederik M. Madsen ([@fmma]) + * Ryan R. Newton ([@rrnewton]) + * Joshua Meredith ([@JoshMeredith]) + * Ben Lever ([@blever]) + * Sean Seefried ([@sseefried]) + +The maintainer and principal developer of Accelerate is Trevor L. McDonell . @@ -209,6 +209,15 @@ Here is a list of features that are currently missing: * Preliminary API (parts of the API may still change in subsequent releases) * Many more features... contact us! + [@mchakravarty]: https://github.com/mchakravarty + [@gckeller]: https://github.com/gckeller + [@tmcdonell]: https://github.com/tmcdonell + [@robeverest]: https://github.com/robeverest + [@fmma]: https://github.com/fmma + [@rrnewton]: https://github.com/rrnewton + [@JoshMeredith]: https://github.com/JoshMeredith + [@blever]: https://github.com/blever + [@sseefried]: https://github.com/sseefried [CKLM+11]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-cuda-damp2011.pdf [MCKL13]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-optim-icfp2013.pdf From fe2d184982c33c4dc454fc0a58a8beb59dbdd786 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 24 Feb 2019 13:05:38 +0100 Subject: [PATCH 006/316] more useful reexports --- src/Data/Array/Accelerate/Interpreter.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 6a582ce85..f2d717d2a 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -41,8 +41,10 @@ module Data.Array.Accelerate.Interpreter ( + Smart.Acc, Arrays, + Afunction, AfunctionR, + -- * Interpret an array expression - Sugar.Acc, Arrays, run, run1, runN, -- Internal (hidden) @@ -79,7 +81,7 @@ import Data.Array.Accelerate.Trafo hiding ( Del 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.Smart as Smart import qualified Data.Array.Accelerate.Trafo as AST import qualified Data.Array.Accelerate.Debug as D @@ -90,7 +92,7 @@ import qualified Data.Array.Accelerate.Debug as D -- | Run a complete embedded array program using the reference interpreter. -- -run :: Arrays a => Sugar.Acc a -> a +run :: Arrays a => Smart.Acc a -> a run a = unsafePerformIO execute where !acc = convertAccWith config a @@ -101,7 +103,7 @@ run a = unsafePerformIO execute -- | 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 :: (Arrays a, Arrays b) => (Smart.Acc a -> Smart.Acc b) -> a -> b run1 = runN -- | Prepare and execute an embedded array program. From ae15f6531e74b32577d80ea29ebb54075926799a Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 24 Feb 2019 18:02:49 +0100 Subject: [PATCH 007/316] fix default implementation of round --- src/Data/Array/Accelerate/Classes/RealFrac.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs b/src/Data/Array/Accelerate/Classes/RealFrac.hs index ae517f69d..8bc4e0dbd 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs @@ -208,7 +208,9 @@ defaultRound x half_down = abs r - 0.5 p = compare half_down 0.0 in - cond (constant LT == p || even n) n m + cond (constant LT == p) n $ + cond (constant EQ == p) (cond (even n) n m) $ + {- otherwise -} m data IsFloatingDict a where From eb978e5ddee9ff6745b7bc38059ab4236987cfb7 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 15 Mar 2019 11:51:42 +0100 Subject: [PATCH 008/316] wibble show instance for (:.) --- src/Data/Array/Accelerate/Array/Sugar.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 518ad323f..121daa90b 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -125,7 +125,8 @@ data tail :. head = !tail :. !head -- etc. -- instance (Show sh, Show sz) => Show (sh :. sz) where - show (sh :. sz) = show sh ++ " :. " ++ show sz + showsPrec p (sh :. sz) = + showsPrec p sh . showString " :. " . showsPrec p sz -- | Marker for entire dimensions in 'Data.Array.Accelerate.Language.slice' and -- 'Data.Array.Accelerate.Language.replicate' descriptors. From 948dc74b23b3a4be02292b8b77765981b14d5e0a Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 15 Mar 2019 12:54:40 +0100 Subject: [PATCH 009/316] stack: update to ghc-8.6.4 --- stack-8.6.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-8.6.yaml b/stack-8.6.yaml index d55700865..493a18a93 100644 --- a/stack-8.6.yaml +++ b/stack-8.6.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-13.5 +resolver: lts-13.12 packages: - . From 95f3b4705d78d497690c3e466632100732a4947b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 15 Mar 2019 16:47:19 +0100 Subject: [PATCH 010/316] add options to the AST hashing function In particular, to not include in the hash features of the AST which are irrelevant from a code generation point of view, such as the shape parameter to generate. --- src/Data/Array/Accelerate/Analysis/Hash.hs | 202 +++++++++++++++------ src/Data/Array/Accelerate/Trafo.hs | 4 +- src/Data/Array/Accelerate/Trafo/Base.hs | 48 +++-- 3 files changed, 183 insertions(+), 71 deletions(-) diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index c31789046..ca60f2c0b 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -21,9 +21,10 @@ module Data.Array.Accelerate.Analysis.Hash ( -- hashing expressions Hash, - hashPreOpenAcc, - hashPreOpenFun, - hashPreOpenExp, + HashOptions(..), defaultHashOptions, + hashPreOpenAcc, hashPreOpenAccWith, + hashPreOpenFun, hashPreOpenFunWith, + hashPreOpenExp, hashPreOpenExpWith, -- auxiliary EncodeAcc, @@ -56,67 +57,132 @@ import Prelude hiding ( exp type Hash = Digest SHA3_256 +data HashOptions = HashOptions + { perfect :: Bool + -- ^ Should the hash function include _all_ substructure, recursively? + -- + -- Set to true (the default) if you want a truly unique fingerprint for + -- the entire expression: + -- + -- Example: + -- + -- xs, ys :: Acc (Vector Float) + -- xs = fill (constant (Z:.10)) 1.0 + -- ys = fill (constant (Z:.20)) 1.0 + -- + -- with perfect=True: + -- + -- hash xs = 2e1f91aca4c476d13b36f22462e73c15bbdd9fcacb0d4996280f6004058e9732 + -- hash ys = 2fce5c849b6c652192b09aaeafdc8029e57b9f006c1ecd79ccf9114f349aaf9e + -- + -- However, for a code generating backend the object code used to + -- evaluate both of these expressions is likely to be identical. + -- + -- Setting perfect=False results in: + -- + -- hash xs = hash ys = f97944b0ec64ab8aa989fd60c8b50e7ec3eff759d22d2b340039d837d74dfc3c + -- + -- Note that to be useful the provided 'EncodeAcc' function must also + -- understand this option, and the consumer of the hash value must be + -- agnostic to the elided details. + } + deriving Show + +defaultHashOptions :: HashOptions +defaultHashOptions = HashOptions True + + {-# INLINEABLE hashPreOpenAcc #-} hashPreOpenAcc :: EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash -hashPreOpenAcc encodeAcc = hashlazy . toLazyByteString . encodePreOpenAcc encodeAcc +hashPreOpenAcc = hashPreOpenAccWith defaultHashOptions {-# INLINEABLE hashPreOpenFun #-} hashPreOpenFun :: EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash -hashPreOpenFun encodeAcc = hashlazy . toLazyByteString . encodePreOpenFun encodeAcc +hashPreOpenFun = hashPreOpenFunWith defaultHashOptions {-# INLINEABLE hashPreOpenExp #-} hashPreOpenExp :: EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash -hashPreOpenExp encodeAcc = hashlazy . toLazyByteString . encodePreOpenExp encodeAcc +hashPreOpenExp = hashPreOpenExpWith defaultHashOptions + +{-# INLINEABLE hashPreOpenAccWith #-} +hashPreOpenAccWith :: HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash +hashPreOpenAccWith options encodeAcc + = hashlazy + . toLazyByteString + . encodePreOpenAcc options encodeAcc + +{-# INLINEABLE hashPreOpenFunWith #-} +hashPreOpenFunWith :: HashOptions -> EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash +hashPreOpenFunWith options encodeAcc + = hashlazy + . toLazyByteString + . encodePreOpenFun options encodeAcc + +{-# INLINEABLE hashPreOpenExpWith #-} +hashPreOpenExpWith :: HashOptions -> EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash +hashPreOpenExpWith options encodeAcc + = hashlazy + . toLazyByteString + . encodePreOpenExp options encodeAcc -- Array computations -- ------------------ -type EncodeAcc acc = forall aenv a. acc aenv a -> Builder +type EncodeAcc acc = forall aenv a. HashOptions -> acc aenv a -> Builder {-# INLINEABLE encodeOpenAcc #-} -encodeOpenAcc :: OpenAcc aenv arrs -> Builder -encodeOpenAcc (OpenAcc pacc) = encodePreOpenAcc encodeOpenAcc pacc +encodeOpenAcc :: HashOptions -> OpenAcc aenv arrs -> Builder +encodeOpenAcc options (OpenAcc pacc) = encodePreOpenAcc options encodeOpenAcc pacc {-# INLINEABLE encodePreOpenAcc #-} encodePreOpenAcc :: forall acc aenv arrs. - EncodeAcc acc + HashOptions + -> EncodeAcc acc -> PreOpenAcc acc aenv arrs -> Builder -encodePreOpenAcc encodeAcc pacc = +encodePreOpenAcc options encodeAcc pacc = let travA :: forall aenv' a. Arrays a => acc aenv' a -> Builder - travA a = encodeArraysType (arrays @a) <> encodeAcc a + travA a = encodeArraysType (arrays @a) <> encodeAcc options a + + travAF :: PreOpenAfun acc aenv' f -> Builder + travAF = encodePreOpenAfun options encodeAcc travE :: PreOpenExp acc env' aenv' e -> Builder - travE = encodePreOpenExp encodeAcc + travE = encodePreOpenExp options encodeAcc travF :: PreOpenFun acc env' aenv' f -> Builder - travF = encodePreOpenFun encodeAcc + travF = encodePreOpenFun options encodeAcc travB :: PreBoundary acc aenv' (Array sh e) -> Builder - travB = encodePreBoundary encodeAcc + travB = encodePreBoundary options encodeAcc nacl :: Arrays arrs => Builder nacl = encodeArraysType (arrays @arrs) + + deep :: Builder -> Builder + deep x | perfect options = x + | otherwise = mempty 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 + Avar v -> intHost $(hashQ "Avar") <> nacl <> deep (encodeIdx v) + Atuple t -> intHost $(hashQ "Atuple") <> nacl <> encodeAtuple options 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 @arrs) a - Awhile p f a -> intHost $(hashQ "Awhile") <> encodePreOpenAfun encodeAcc f <> encodePreOpenAfun encodeAcc p <> travA a + Apply f a -> intHost $(hashQ "Apply") <> nacl <> travAF f <> travA a + Aforeign _ f a -> intHost $(hashQ "Aforeign") <> nacl <> travAF f <> travA a + Use a -> intHost $(hashQ "Use") <> deep (encodeArrays (arrays @arrs) a) + Awhile p f a -> intHost $(hashQ "Awhile") <> travAF f <> travAF 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 + Generate e f -> intHost $(hashQ "Generate") <> deep (travE e) <> travF f + Acond e a1 a2 -> intHost $(hashQ "Acond") <> deep (travE e) <> travA a1 <> travA a2 + Reshape sh a -> intHost $(hashQ "Reshape") <> deep (travE sh) <> travA a + Backpermute sh f a -> intHost $(hashQ "Backpermute") <> deep (travE sh) <> travF f <> travA a + Transform sh f1 f2 a -> intHost $(hashQ "Transform") <> deep (travE sh) <> travF f1 <> travF f2 <> travA a + Replicate spec ix a -> intHost $(hashQ "Replicate") <> deep (travE ix) <> travA a <> encodeSliceIndex spec + Slice spec a ix -> intHost $(hashQ "Slice") <> deep (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 @@ -129,7 +195,6 @@ encodePreOpenAcc encodeAcc pacc = 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 @@ -199,30 +264,40 @@ encodeArraysType ArraysRarray = intHost $(hashQ "ArraysRarray") <> encode encodeArrayType :: forall array sh e. (array ~ Array sh e, Shape sh, Elt e) => Builder encodeArrayType = encodeTupleType (eltType @sh) <> encodeTupleType (eltType @e) -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 +encodeAtuple :: HashOptions -> EncodeAcc acc -> Atuple (acc aenv) a -> Builder +encodeAtuple _ _ NilAtup = intHost $(hashQ "NilAtup") +encodeAtuple o travA (SnocAtup t a) = intHost $(hashQ "SnocAtup") <> encodeAtuple o travA t <> travA o a -encodePreOpenAfun :: forall acc aenv f. EncodeAcc acc -> PreOpenAfun acc aenv f -> Builder -encodePreOpenAfun travA afun = +encodePreOpenAfun + :: forall acc aenv f. + HashOptions + -> EncodeAcc acc + -> PreOpenAfun acc aenv f + -> Builder +encodePreOpenAfun options travA afun = let travB :: forall aenv' a. Arrays a => acc aenv' a -> Builder - travB b = encodeArraysType (arrays @a) <> travA b + travB b = encodeArraysType (arrays @a) <> travA options b travL :: forall aenv' a b. Arrays a => PreOpenAfun acc (aenv',a) b -> Builder - travL l = encodeArraysType (arrays @a) <> encodePreOpenAfun travA l + travL l = encodeArraysType (arrays @a) <> encodePreOpenAfun options travA l in case afun of Abody b -> intHost $(hashQ "Abody") <> travB b Alam l -> intHost $(hashQ "Alam") <> travL l -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 @e) c -encodePreBoundary h (Function f) = intHost $(hashQ "Function") <> encodePreOpenFun h f +encodePreBoundary + :: forall acc aenv sh e. + HashOptions + -> 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 @e) c +encodePreBoundary o h (Function f) = intHost $(hashQ "Function") <> encodePreOpenFun o h f encodeSliceIndex :: SliceIndex slix sl co sh -> Builder encodeSliceIndex SliceNil = intHost $(hashQ "SliceNil") @@ -234,18 +309,26 @@ encodeSliceIndex (SliceFixed r) = intHost $(hashQ "sliceFixed") <> encodeSlice -- ------------------ {-# INLINEABLE encodeOpenExp #-} -encodeOpenExp :: OpenExp env aenv exp -> Builder -encodeOpenExp = encodePreOpenExp encodeOpenAcc +encodeOpenExp :: HashOptions -> OpenExp env aenv exp -> Builder +encodeOpenExp options = encodePreOpenExp options encodeOpenAcc {-# INLINEABLE encodePreOpenExp #-} -encodePreOpenExp :: forall acc env aenv exp. EncodeAcc acc -> PreOpenExp acc env aenv exp -> Builder -encodePreOpenExp travA exp = +encodePreOpenExp + :: forall acc env aenv exp. + HashOptions + -> EncodeAcc acc + -> PreOpenExp acc env aenv exp + -> Builder +encodePreOpenExp options encodeAcc exp = let + travA :: forall aenv' a. Arrays a => acc aenv' a -> Builder + travA a = encodeArraysType (arrays @a) <> encodeAcc options a + travE :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder - travE e = encodeTupleType (eltType @e) <> encodePreOpenExp travA e + travE e = encodeTupleType (eltType @e) <> encodePreOpenExp options encodeAcc e travF :: PreOpenFun acc env' aenv' f -> Builder - travF = encodePreOpenFun travA + travF = encodePreOpenFun options encodeAcc nacl :: Elt exp => Builder nacl = encodeTupleType (eltType @exp) @@ -253,7 +336,7 @@ encodePreOpenExp travA exp = 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 + Tuple t -> intHost $(hashQ "Tuple") <> nacl <> encodeTuple options encodeAcc 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 @exp) c Undef -> intHost $(hashQ "Undef") @@ -281,22 +364,31 @@ encodePreOpenExp travA exp = {-# INLINEABLE encodePreOpenFun #-} -encodePreOpenFun :: forall acc env aenv f. EncodeAcc acc -> PreOpenFun acc env aenv f -> Builder -encodePreOpenFun travA fun = +encodePreOpenFun + :: forall acc env aenv f. + HashOptions + -> EncodeAcc acc + -> PreOpenFun acc env aenv f + -> Builder +encodePreOpenFun options travA fun = let travB :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder - travB b = encodeTupleType (eltType @e) <> encodePreOpenExp travA b + travB b = encodeTupleType (eltType @e) <> encodePreOpenExp options travA b travL :: forall env' aenv' a b. Elt a => PreOpenFun acc (env',a) aenv' b -> Builder - travL l = encodeTupleType (eltType @a) <> encodePreOpenFun travA l + travL l = encodeTupleType (eltType @a) <> encodePreOpenFun options travA l in case fun of Body b -> intHost $(hashQ "Body") <> travB b Lam l -> intHost $(hashQ "Lam") <> travL l -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 +encodeTuple + :: HashOptions + -> EncodeAcc acc + -> Tuple (PreOpenExp acc env aenv) e + -> Builder +encodeTuple _ _ NilTup = intHost $(hashQ "NilTup") +encodeTuple o h (SnocTup t e) = intHost $(hashQ "SnocTup") <> encodeTuple o h t <> encodePreOpenExp o h e encodeConst :: TupleType t -> t -> Builder diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 0c55deec8..40d8294b8 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -41,7 +41,9 @@ module Data.Array.Accelerate.Trafo ( Match(..), (:~:)(..), -- ** Auxiliary - matchDelayedOpenAcc, encodeDelayedOpenAcc, hashDelayedOpenAcc, + matchDelayedOpenAcc, + encodeDelayedOpenAcc, + hashDelayedOpenAcc, hashDelayedOpenAccWith, ) where diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index ea742b43c..92bedb461 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -36,7 +36,9 @@ module Data.Array.Accelerate.Trafo.Base ( DelayedAfun, DelayedOpenAfun, DelayedExp, DelayedOpenExp, DelayedFun, DelayedOpenFun, - matchDelayedOpenAcc, encodeDelayedOpenAcc, hashDelayedOpenAcc, + matchDelayedOpenAcc, + encodeDelayedOpenAcc, + hashDelayedOpenAcc, hashDelayedOpenAccWith, -- Environments Gamma(..), incExp, prjExp, pushExp, @@ -92,9 +94,9 @@ instance Kit OpenAcc where {-# INLINEABLE encodeAcc #-} {-# INLINEABLE matchAcc #-} {-# INLINEABLE prettyAcc #-} - encodeAcc (OpenAcc pacc) = encodePreOpenAcc encodeAcc pacc - matchAcc (OpenAcc pacc1) (OpenAcc pacc2) = matchPreOpenAcc matchAcc encodeAcc pacc1 pacc2 - prettyAcc = prettyOpenAcc + encodeAcc options (OpenAcc pacc) = encodePreOpenAcc options 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 @@ -200,21 +202,37 @@ instance NFData (DelayedOpenAcc aenv t) where -- rnf = rnfDelayedSeq +{-# INLINEABLE hashDelayedOpenAcc #-} hashDelayedOpenAcc :: DelayedOpenAcc aenv a -> Hash -hashDelayedOpenAcc = hashlazy . toLazyByteString . encodeDelayedOpenAcc +hashDelayedOpenAcc = hashDelayedOpenAccWith defaultHashOptions + +{-# INLINEABLE hashDelayedOpenAccWith #-} +hashDelayedOpenAccWith :: HashOptions -> DelayedOpenAcc aenv a -> Hash +hashDelayedOpenAccWith options + = hashlazy + . toLazyByteString + . encodeDelayedOpenAcc options {-# 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 +encodeDelayedOpenAcc options acc = + let + travE :: DelayedExp aenv sh -> Builder + travE = encodePreOpenExp options encodeDelayedOpenAcc + + travF :: DelayedFun aenv f -> Builder + travF = encodePreOpenFun options encodeDelayedOpenAcc + + travA :: PreOpenAcc DelayedOpenAcc aenv a -> Builder + travA = encodePreOpenAcc options encodeDelayedOpenAcc + + deep :: Builder -> Builder + deep x | perfect options = x + | otherwise = mempty + in + case acc of + Manifest pacc -> intHost $(hashQ "Manifest") <> deep (travA pacc) + Delayed sh f g -> intHost $(hashQ "Delayed") <> travE sh <> travF f <> travF g {-# INLINEABLE matchDelayedOpenAcc #-} matchDelayedOpenAcc :: MatchAcc DelayedOpenAcc From 817c7ebcc7afb72c2c40c28a1cd6d9f341fa9ac5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 Mar 2019 02:06:49 +0100 Subject: [PATCH 011/316] a prettier printer Teach the pretty printer about about operator associativity and precedence; which allows us to correctly place parentheses. --- accelerate.cabal | 4 +- src/Data/Array/Accelerate.hs | 2 +- src/Data/Array/Accelerate/Analysis/Hash.hs | 12 +- src/Data/Array/Accelerate/Debug.hs | 17 - src/Data/Array/Accelerate/Debug/Stats.hs | 63 +- src/Data/Array/Accelerate/Pretty.hs | 217 ++-- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 146 +-- .../Array/Accelerate/Pretty/Graphviz/Monad.hs | 8 +- .../Array/Accelerate/Pretty/Graphviz/Type.hs | 96 +- src/Data/Array/Accelerate/Pretty/Print.hs | 1008 +++++++++-------- src/Data/Array/Accelerate/Trafo.hs | 47 +- src/Data/Array/Accelerate/Trafo/Algebra.hs | 31 +- src/Data/Array/Accelerate/Trafo/Base.hs | 109 +- src/Data/Array/Accelerate/Trafo/Fusion.hs | 13 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 3 +- src/Data/Array/Accelerate/Trafo/Shrink.hs | 3 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 9 +- .../Array/Accelerate/Trafo/Substitution.hs | 1 + src/Data/Array/Accelerate/Type.hs | 7 +- 19 files changed, 912 insertions(+), 884 deletions(-) diff --git a/accelerate.cabal b/accelerate.cabal index 083e1fc32..7b30cd647 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -262,7 +262,6 @@ Library Build-depends: base >= 4.9 && < 4.13 , ansi-terminal >= 0.6.2 - , ansi-wl-pprint >= 0.6 , base-orphans >= 0.3 , bytestring >= 0.10.2 , containers >= 0.3 @@ -278,10 +277,13 @@ Library , hedgehog >= 0.5 , lens >= 4.0 , mtl >= 2.0 + , prettyprinter >= 1.0 + , prettyprinter-ansi-terminal >= 1.0 , primitive >= 0.6.4 , tasty >= 0.11 , template-haskell , terminal-size >= 0.3 + , text >= 1.2 , transformers >= 0.3 , unique , unordered-containers >= 0.2 diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 9afaca78c..7befec2ae 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -410,7 +410,7 @@ import Data.Array.Accelerate.Language import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude import Data.Array.Accelerate.Product -import Data.Array.Accelerate.Trafo () -- show instances +import Data.Array.Accelerate.Pretty () -- show instances import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Array.Sugar as S diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index ca60f2c0b..40a941926 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -28,8 +28,8 @@ module Data.Array.Accelerate.Analysis.Hash ( -- auxiliary EncodeAcc, - encodePreOpenAcc, encodeOpenAcc, - encodePreOpenExp, encodeOpenExp, + encodePreOpenAcc, + encodePreOpenExp, encodePreOpenFun, hashQ, @@ -131,10 +131,6 @@ hashPreOpenExpWith options encodeAcc type EncodeAcc acc = forall aenv a. HashOptions -> acc aenv a -> Builder -{-# INLINEABLE encodeOpenAcc #-} -encodeOpenAcc :: HashOptions -> OpenAcc aenv arrs -> Builder -encodeOpenAcc options (OpenAcc pacc) = encodePreOpenAcc options encodeOpenAcc pacc - {-# INLINEABLE encodePreOpenAcc #-} encodePreOpenAcc :: forall acc aenv arrs. @@ -308,10 +304,6 @@ encodeSliceIndex (SliceFixed r) = intHost $(hashQ "sliceFixed") <> encodeSlice -- Scalar expressions -- ------------------ -{-# INLINEABLE encodeOpenExp #-} -encodeOpenExp :: HashOptions -> OpenExp env aenv exp -> Builder -encodeOpenExp options = encodePreOpenExp options encodeOpenAcc - {-# INLINEABLE encodePreOpenExp #-} encodePreOpenExp :: forall acc env aenv exp. diff --git a/src/Data/Array/Accelerate/Debug.hs b/src/Data/Array/Accelerate/Debug.hs index 941f43f71..3a47435e3 100644 --- a/src/Data/Array/Accelerate/Debug.hs +++ b/src/Data/Array/Accelerate/Debug.hs @@ -19,8 +19,6 @@ module Data.Array.Accelerate.Debug ( module Debug, dumpGraph, - dumpSimplStats, - debuggingIsEnabled, monitoringIsEnabled, boundsChecksAreEnabled, @@ -97,21 +95,6 @@ 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. -- diff --git a/src/Data/Array/Accelerate/Debug/Stats.hs b/src/Data/Array/Accelerate/Debug/Stats.hs index dd3498ca6..1cd284d99 100644 --- a/src/Data/Array/Accelerate/Debug/Stats.hs +++ b/src/Data/Array/Accelerate/Debug/Stats.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | @@ -16,28 +17,32 @@ module Data.Array.Accelerate.Debug.Stats ( - simplCount, resetSimplCount, + simplCount, resetSimplCount, dumpSimplStats, inline, ruleFired, knownBranch, betaReduce, substitution, simplifierDone, fusionDone, ) where import Data.Array.Accelerate.Debug.Flags +import Data.Array.Accelerate.Debug.Trace -import Data.Function ( on ) +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 Data.List ( groupBy, sortBy ) +import Data.Map ( Map ) +import Data.Ord ( comparing ) +import Data.Text ( Text ) +import Data.Text.Prettyprint.Doc hiding ( annotate, Doc ) +-- import Data.Text.Prettyprint.Doc.Render.Terminal +import Data.Text.Prettyprint.Doc.Render.String import System.IO.Unsafe - -import qualified Data.Map as Map +import qualified Data.Map as Map +import qualified Data.Text.Prettyprint.Doc as Pretty -- Recording statistics -- -------------------- -ruleFired, inline, knownBranch, betaReduce, substitution :: String -> a -> a +ruleFired, inline, knownBranch, betaReduce, substitution :: Text -> a -> a inline = annotate Inline ruleFired = annotate RuleFired knownBranch = annotate KnownBranch @@ -63,7 +68,7 @@ tick _ expr = expr -- Add an entry to the statistics counters with an annotation -- -annotate :: (Id -> Tick) -> String -> a -> a +annotate :: (Id -> Tick) -> Text -> a -> a annotate name ctx = tick (name (Id ctx)) @@ -112,6 +117,21 @@ resetSimplCount = writeIORef statistics =<< initSimplCount resetSimplCount = return () #endif +-- Display simplifier statistics. The counts are reset afterwards. +-- +{-# INLINEABLE dumpSimplStats #-} +dumpSimplStats :: IO () +#ifdef ACCELERATE_DEBUG +dumpSimplStats = do + when dump_simpl_stats $ do + stats <- simplCount + putTraceMsg (renderString (layoutPretty defaultLayoutOptions stats)) + resetSimplCount +#else +dumpSimplStats = return () +#endif + + -- Tick a counter -- @@ -122,10 +142,10 @@ 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 (Simple n) = "Total ticks:" <+> pretty n pprSimplCount (Detail n dts) - = vcat [ text "Total ticks:" <+> int n - , text "" + = vcat [ "Total ticks:" <+> pretty n + , mempty , pprTickCount dts ] @@ -136,9 +156,10 @@ simplCount = pprSimplCount `fmap` readIORef statistics -- Ticks -- ----- +type Doc = Pretty.Doc () type TickCount = Map Tick Int -data Id = Id String +data Id = Id Text deriving (Eq, Ord) data Tick @@ -171,8 +192,8 @@ pprTickCount counts = 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 ]) + hang 2 (vcat $ (pretty groupTotal <+> groupName) + : [ pretty n <+> pprTickCtx t | (t,n) <- sortBy (flip (comparing snd)) grp ]) where groupName = tickToStr (fst (head grp)) groupTotal = sum [n | (_,n) <- grp] @@ -186,7 +207,7 @@ tickToTag Substitution{} = 4 tickToTag SimplifierDone = 99 tickToTag FusionDone = 100 -tickToStr :: Tick -> String +tickToStr :: Tick -> Doc tickToStr Inline{} = "Inline" tickToStr RuleFired{} = "RuleFired" tickToStr KnownBranch{} = "KnownBranch" @@ -201,9 +222,9 @@ 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 +pprTickCtx SimplifierDone = mempty +pprTickCtx FusionDone = mempty pprId :: Id -> Doc -pprId (Id s) = text s +pprId (Id s) = pretty s diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index e96348c31..3fc224cd2 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -16,93 +20,178 @@ module Data.Array.Accelerate.Pretty ( - -- * Pretty printing functions - module Data.Array.Accelerate.Pretty.Print, - module Data.Array.Accelerate.Pretty.Graphviz, + -- ** Pretty printing + PrettyAcc, ExtractAcc, + prettyPreOpenAcc, + prettyPreOpenAfun, + prettyPreOpenExp, + prettyPreOpenFun, - -- * Instances of Show + -- ** Graphviz + Graph, + PrettyGraph(..), Detail(..), + graphDelayedAcc, graphDelayedAfun, ) where -- libraries +import Control.DeepSeq +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.String +import Data.Text.Prettyprint.Doc.Render.Terminal import System.IO import System.IO.Unsafe -import Text.PrettyPrint.ANSI.Leijen +import qualified Data.Text.Lazy as T 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.Smart ( Acc, Exp ) +import Data.Array.Accelerate.AST hiding ( Acc, Exp, Val(..) ) +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Pretty.Print hiding ( Keyword(..) ) +import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.Pretty.Graphviz +import Data.Array.Accelerate.Debug.Flags +import Data.Array.Accelerate.Debug.Stats --- Show --- ---- --- Explicitly enumerate Show instances for the Accelerate array AST types. If we --- instead use a generic instance of the form: +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 + + +-- Note: [Show instances] +-- +-- 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 + show = renderForTerminal . prettyOpenAcc context0 (prettyEnv (pretty 'a')) -instance PrettyEnv aenv => Show (DelayedOpenAcc aenv a) where - showsPrec _ = renderForTerminal . pretty +instance PrettyEnv aenv => Show (OpenAfun aenv f) where + show = renderForTerminal . prettyPreOpenAfun prettyOpenAcc (prettyEnv (pretty 'a')) --- These parameterised instances are fine because there is a concrete kind +instance PrettyEnv aenv => Show (DelayedOpenAcc aenv a) where + show = renderForTerminal . prettyDelayedOpenAcc context0 (prettyEnv (pretty 'a')) + +instance PrettyEnv aenv => Show (DelayedOpenAfun aenv f) where + show = renderForTerminal . prettyPreOpenAfun prettyDelayedOpenAcc (prettyEnv (pretty 'a')) + +instance (PrettyEnv env, PrettyEnv aenv) => Show (PreOpenExp OpenAcc env aenv e) where + show = renderForTerminal . prettyPreOpenExp context0 prettyOpenAcc extractOpenAcc (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) + +instance (PrettyEnv env, PrettyEnv aenv) => Show (PreOpenExp DelayedOpenAcc env aenv e) where + show = renderForTerminal . prettyPreOpenExp context0 prettyDelayedOpenAcc extractDelayedOpenAcc (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) + +instance (PrettyEnv env, PrettyEnv aenv) => Show (PreOpenFun OpenAcc env aenv e) where + show = renderForTerminal . prettyPreOpenFun prettyOpenAcc extractOpenAcc (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) + +instance (PrettyEnv env, PrettyEnv aenv) => Show (PreOpenFun DelayedOpenAcc env aenv e) where + show = renderForTerminal . prettyPreOpenFun prettyDelayedOpenAcc extractDelayedOpenAcc (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) + + +-- Internals +-- --------- + +renderForTerminal :: Adoc -> String +renderForTerminal = render . layoutSmart terminalLayoutOptions + where + render | terminalSupportsANSI = T.unpack . renderLazy . reAnnotateS ansiKeyword + | otherwise = renderString + +{-# NOINLINE terminalSupportsANSI #-} +terminalSupportsANSI :: Bool +terminalSupportsANSI = unsafePerformIO $ Term.hSupportsANSI stdout + +{-# NOINLINE terminalLayoutOptions #-} +terminalLayoutOptions :: LayoutOptions +terminalLayoutOptions + = unsafePerformIO + $ do term <- Term.size + return $ case term of + Nothing -> defaultLayoutOptions + Just t -> LayoutOptions { layoutPageWidth = AvailablePerLine (min w 120) f } + where + w = Term.width t + f | w <= 80 = 1 + | w <= 100 = 0.8 + | otherwise = 0.6 + +prettyOpenAcc :: PrettyAcc OpenAcc +prettyOpenAcc context aenv (OpenAcc pacc) = + prettyPreOpenAcc context prettyOpenAcc extractOpenAcc aenv pacc + +extractOpenAcc :: OpenAcc aenv a -> PreOpenAcc OpenAcc aenv a +extractOpenAcc (OpenAcc pacc) = pacc + + +prettyDelayedOpenAcc :: PrettyAcc DelayedOpenAcc +prettyDelayedOpenAcc context aenv (Manifest pacc) + = prettyPreOpenAcc context prettyDelayedOpenAcc extractDelayedOpenAcc aenv pacc +prettyDelayedOpenAcc context aenv (Delayed sh f _) + | Shape a <- sh + , Just Refl <- match f (Lam (Body (Index a (Var ZeroIdx)))) + = prettyDelayedOpenAcc context aenv a + -- + -- 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 + -- + | otherwise + = parens + $ nest shiftwidth + $ sep [ delayed "delayed" + , prettyPreOpenExp app prettyDelayedOpenAcc extractDelayedOpenAcc Empty aenv sh + , parens $ prettyPreOpenFun prettyDelayedOpenAcc extractDelayedOpenAcc Empty aenv f + ] + +extractDelayedOpenAcc :: DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv a +extractDelayedOpenAcc (Manifest pacc) = pacc +extractDelayedOpenAcc Delayed{} = $internalError "extractDelayedOpenAcc" "expected manifest array" + + +-- 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. -- --- 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. +-- 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. -- -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 +withSimplStats :: String -> String +#ifdef ACCELERATE_DEBUG +withSimplStats x = unsafePerformIO $ do + when dump_simpl_stats $ x `deepseq` dumpSimplStats + return x +#else +withSimplStats x = x +#endif diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 763449d99..ba50486c3 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -36,21 +36,21 @@ import Control.Monad.State ( modify, gets, state ) import Data.HashSet ( HashSet ) import Data.List import Data.Maybe +import Data.String +import Data.Text.Prettyprint.Doc 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 +import qualified Data.Sequence as Seq -- friends -import Data.Array.Accelerate.AST ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), PreBoundary(..), Idx(..) ) +import Data.Array.Accelerate.AST ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), PreBoundary(..), Idx(..), tupleIdxToInt ) import Data.Array.Accelerate.Array.Sugar ( Array, 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 +import Data.Array.Accelerate.Pretty.Print hiding ( Keyword(..) ) +import Data.Array.Accelerate.Trafo.Base -- Configuration options @@ -77,7 +77,7 @@ data Aval env where -- avalToVal :: Aval aenv -> Val aenv avalToVal Aempty = Empty -avalToVal (Apush aenv _ v) = Push (avalToVal aenv) (text v) +avalToVal (Apush aenv _ v) = Push (avalToVal aenv) (pretty v) aprj :: Idx aenv t -> Aval aenv -> (NodeId, Label) -- TLM: (Vertex, Label) ?? aprj ZeroIdx (Apush _ n v) = (n,v) @@ -107,7 +107,7 @@ mkNode (PNode ident tree deps) label = -- Add [T|F] ports underneath the given tree. -- -mkTF :: Tree (Maybe Port, Doc) -> Tree (Maybe Port, Doc) +mkTF :: Tree (Maybe Port, Adoc) -> Tree (Maybe Port, Adoc) mkTF this = Forest [ this , Forest [ Leaf (Just "T", "T") @@ -165,8 +165,8 @@ graphDelayedAfun detail afun = unsafePerformIO . evalDot $! do -- 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)] +data PDoc = PDoc Adoc [Vertex] +data PNode = PNode NodeId (Tree (Maybe Port, Adoc)) [(Vertex, Maybe Port)] graphDelayedOpenAcc :: Detail @@ -174,7 +174,7 @@ graphDelayedOpenAcc -> DelayedOpenAcc aenv a -> Dot Graph graphDelayedOpenAcc detail aenv acc = do - r <- prettyDelayedOpenAcc detail noParens aenv acc + r <- prettyDelayedOpenAcc detail context0 aenv acc i <- mkNodeId r v <- mkNode r Nothing _ <- mkNode (PNode i (Leaf (Nothing,"result")) [(Vertex v Nothing, Nothing)]) Nothing @@ -185,19 +185,19 @@ graphDelayedOpenAcc detail aenv acc = do prettyDelayedOpenAcc :: forall aenv arrs. Detail -- simplified output: only print operator name - -> (Doc -> Doc) + -> Context -> Aval aenv -> DelayedOpenAcc aenv arrs -> Dot PNode -prettyDelayedOpenAcc _ _ _ Delayed{} = $internalError "prettyDelayedOpenAcc" "expected manifest array" -prettyDelayedOpenAcc detail wrap aenv atop@(Manifest pacc) = +prettyDelayedOpenAcc _ _ _ Delayed{} = $internalError "prettyDelayedOpenAcc" "expected manifest array" +prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = case pacc of Avar ix -> pnode (avar ix) Alet bnd body -> do - bnd' <- prettyDelayedOpenAcc detail noParens aenv bnd + bnd' <- prettyDelayedOpenAcc detail context0 aenv bnd a <- mkLabel ident <- mkNode bnd' (Just a) - body' <- prettyDelayedOpenAcc detail noParens (Apush aenv ident a) body + body' <- prettyDelayedOpenAcc detail context0 (Apush aenv ident a) body return body' Acond p t e -> do @@ -210,32 +210,33 @@ prettyDelayedOpenAcc detail wrap aenv atop@(Manifest pacc) = 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 + Apply afun acc -> apply <$> prettyDelayedAfun detail aenv afun + <*> prettyDelayedOpenAcc detail ctx aenv acc Awhile p f x -> do ident <- mkNodeId atop - x' <- replant =<< prettyDelayedOpenAcc detail parens aenv x + x' <- replant =<< prettyDelayedOpenAcc detail app 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 ]) + loop = nest 2 (sep ["awhile", pretty p', pretty f', xb ]) return $ PNode ident (Leaf (Nothing,loop)) fvs - Atuple atup -> prettyDelayedAtuple detail wrap aenv atup + Atuple atup -> prettyDelayedAtuple detail 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 + PNode _ (Leaf (p,d)) deps <- replant =<< prettyDelayedOpenAcc detail context0 aenv atup + return $ PNode ident (Leaf (p, d <+> pretty '#' <+> pretty (tupleIdxToInt ix))) deps Use arrs -> "use" .$ [ return $ PDoc (prettyArrays (arrays @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 ] + Generate sh f -> "generate" .$ [ ppE sh, ppF f ] + Transform sh ix f xs -> "transform" .$ [ ppE sh, ppF ix, ppF f, ppA xs ] + Reshape sh xs -> "reshape" .$ [ ppE sh, ppA xs ] + Replicate _ty ix xs -> "replicate" .$ [ ppE ix, ppA xs ] + Slice _ty xs ix -> "slice" .$ [ ppA xs, ppE 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 ] @@ -249,24 +250,28 @@ prettyDelayedOpenAcc detail wrap aenv atop@(Manifest pacc) = 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 ] + Backpermute sh p xs -> "backpermute" .$ [ ppE 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 ] + Aforeign ff _afun xs -> "aforeign" .$ [ return (PDoc (pretty (strForeign ff)) []), {- ppAf afun, -} ppA xs ] -- Collect{} -> error "Collect" where - (.$) :: String -> [Dot PDoc] -> Dot PNode + (.$) :: Operator -> [Dot PDoc] -> Dot PNode name .$ docs = pnode =<< fmt name docs - fmt :: String -> [Dot PDoc] -> Dot PDoc + fmt :: Operator -> [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) + doc = if simple detail + then manifest name + else parensIf (needsParens ctx name) + $ nest shiftwidth + $ sep ( manifest name : args ) + return $ PDoc doc (concat fvs) pnode :: PDoc -> Dot PNode pnode (PDoc doc vs) = do @@ -290,7 +295,7 @@ prettyDelayedOpenAcc detail wrap aenv atop@(Manifest pacc) = -- avar :: Idx aenv t -> PDoc avar ix = let (ident, v) = aprj ix aenv - in PDoc (text v) [Vertex ident Nothing] + in PDoc (pretty v) [Vertex ident Nothing] aenv' :: Val aenv aenv' = avalToVal aenv @@ -300,16 +305,16 @@ prettyDelayedOpenAcc detail wrap aenv atop@(Manifest pacc) = 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 + acc' <- prettyDelayedOpenAcc detail app aenv acc v <- mkLabel ident <- mkNode acc' (Just v) - return $ PDoc (text v) [Vertex ident Nothing] + return $ PDoc (pretty 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 ] + PDoc d v <- "Delayed" `fmt` [ ppE sh, ppF f ] return $ PDoc (parens d) v ppB :: forall sh e. Elt e @@ -318,37 +323,31 @@ prettyDelayedOpenAcc detail wrap aenv atop@(Manifest pacc) = 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 (Constant e) = return (PDoc (prettyConst (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) + ppE = return . uncurry PDoc . (prettyDelayedExp 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 + acc' <- prettyDelayedOpenAcc detail context0 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) + Leaf (p,d) -> Leaf (p, pretty f <+> d) + Forest ts -> Forest (Leaf (Nothing,pretty 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 @@ -369,7 +368,7 @@ prettyDelayedAfun prettyDelayedAfun detail aenv afun = do Graph _ ss <- mkSubgraph (go aenv afun) n <- Seq.length <$> gets dotGraph - let label = "afun" ++ show (n+1) + let label = "afun" <> fromString (show (n+1)) outer = collect aenv (lifted,ss') = flip partition ss $ \s -> @@ -387,7 +386,7 @@ prettyDelayedAfun detail aenv afun = do go aenv' (Alam f) = do a <- mkLabel ident <- mkNodeId f - _ <- mkNode (PNode ident (Leaf (Nothing, text a)) []) Nothing + _ <- mkNode (PNode ident (Leaf (Nothing, pretty a)) []) Nothing go (Apush aenv' ident a) f collect :: Aval aenv' -> HashSet NodeId @@ -400,11 +399,10 @@ prettyDelayedAfun detail aenv afun = do prettyDelayedAtuple :: forall aenv atup. Detail - -> (Doc -> Doc) -> Aval aenv -> Atuple (DelayedOpenAcc aenv) atup -> Dot PNode -prettyDelayedAtuple detail wrap aenv atup = do +prettyDelayedAtuple detail 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) } @@ -413,7 +411,7 @@ prettyDelayedAtuple detail wrap aenv atup = do 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 + a' <- replant =<< prettyDelayedOpenAcc detail context0 aenv a tup' <- collect (a':acc) tup return tup' @@ -428,7 +426,7 @@ prettyDelayedAtuple detail wrap aenv atup = do -- 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 :: [Tree (Maybe Port, Adoc)] -> Tree (Maybe Port, Adoc) forest leaves = Leaf (Nothing, tupled [ align d | Leaf (Nothing,d) <- leaves ]) @@ -443,7 +441,7 @@ replant pnode@(PNode ident tree _) = vacuous <- mkNodeId pnode a <- mkLabel _ <- mkNode pnode (Just a) - return $ PNode vacuous (Leaf (Nothing, text a)) [(Vertex ident Nothing, Nothing)] + return $ PNode vacuous (Leaf (Nothing, pretty a)) [(Vertex ident Nothing, Nothing)] -- Pretty printing scalar functions and expressions @@ -455,11 +453,11 @@ replant pnode@(PNode ident tree _) = -- nodes. -- -prettyDelayedFun :: Val aenv -> DelayedFun aenv f -> Doc +prettyDelayedFun :: Val aenv -> DelayedFun aenv f -> Adoc prettyDelayedFun = prettyDelayedOpenFun Empty -prettyDelayedExp :: (Doc -> Doc) -> Val aenv -> DelayedExp aenv t -> Doc -prettyDelayedExp wrap = prettyDelayedOpenExp wrap Empty +prettyDelayedExp :: Val aenv -> DelayedExp aenv t -> Adoc +prettyDelayedExp = prettyDelayedOpenExp context0 Empty prettyDelayedOpenFun @@ -467,30 +465,36 @@ prettyDelayedOpenFun Val env -> Val aenv -> DelayedOpenFun env aenv f - -> Doc -prettyDelayedOpenFun env aenv fun = "\\\\" <> next env fun + -> Adoc +prettyDelayedOpenFun env0 aenv = next "\\\\" env0 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) = "→" <+> prettyDelayedOpenExp noParens env' aenv body - next env' (Lam fun') = - let x = char 'x' <> int (sizeEnv env') - in x <+> next (env' `Push` x) fun' + next :: Adoc -> Val env' -> PreOpenFun DelayedOpenAcc env' aenv f' -> Adoc + next vs env (Body body) = + nest shiftwidth (sep [ vs <> "→" + , prettyDelayedOpenExp context0 env aenv body ]) + next vs env (Lam lam) = + let x = pretty 'x' <> pretty (sizeEnv env) + in next (vs <> x <> space) (env `Push` x) lam prettyDelayedOpenExp - :: (Doc -> Doc) + :: Context -> Val env -> Val aenv -> DelayedOpenExp env aenv t - -> Doc -prettyDelayedOpenExp = prettyPreOpenExp pp + -> Adoc +prettyDelayedOpenExp context = prettyPreOpenExp context pp ex where pp :: PrettyAcc DelayedOpenAcc pp _ aenv (Manifest (Avar ix)) = prj ix aenv pp _ _ _ = $internalError "prettyDelayedOpenExp" "expected array variable" + ex :: ExtractAcc DelayedOpenAcc + ex (Manifest pacc) = pacc + ex Delayed{} = $internalError "prettyDelayedOpenExp" "expected manifest array" + -- Data dependencies -- ----------------- @@ -510,7 +514,7 @@ fvPreOpenFun -> 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 +fvPreOpenFun fvA env aenv (Lam f) = fvPreOpenFun fvA (env `Push` (pretty 'x' <> pretty (sizeEnv env))) aenv f fvPreOpenExp :: forall acc env aenv exp. @@ -533,7 +537,7 @@ fvPreOpenExp fvA env aenv = fv 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 (Let e1 e2) = concat [ fv e1, fvPreOpenExp fvA (env `Push` (pretty 'x' <> pretty (sizeEnv env))) aenv e2 ] fv Var{} = [] fv Undef = [] fv Const{} = [] diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs b/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs index 5b728d9be..09cabcc47 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Module : Data.Array.Accelerate.Pretty.Graphviz.Monad -- Copyright : [2015..2019] The Accelerate Team @@ -18,6 +19,7 @@ import Data.Sequence ( Seq ) import System.Mem.StableName import Prelude import qualified Data.Sequence as Seq +import qualified Data.Text as Text import Data.Array.Accelerate.Pretty.Graphviz.Type @@ -50,7 +52,7 @@ execDot dot = snd <$> runDot dot mkLabel :: Dot Label mkLabel = state $ \s -> let n = fresh s - in ( 'a' : show n, s { fresh = n + 1 } ) + in ( Text.pack ('a' : show n), s { fresh = n + 1 } ) mkNodeId :: a -> Dot NodeId mkNodeId node = do @@ -60,7 +62,7 @@ mkNodeId node = do mkGraph :: Dot Graph mkGraph = state $ \DotState{..} -> - ( Graph [] (toList $ fmap N dotNodes Seq.>< fmap E dotEdges Seq.>< fmap G dotGraph) + ( Graph mempty (toList $ fmap N dotNodes Seq.>< fmap E dotEdges Seq.>< fmap G dotGraph) , emptyState { fresh = fresh } ) diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs b/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs index 5cc2f8f6e..3f3f2de22 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} -- | @@ -15,10 +16,14 @@ module Data.Array.Accelerate.Pretty.Graphviz.Type where -import Data.Maybe import Data.Hashable +import Data.Maybe +import Data.Text ( Text ) +import Data.Text.Prettyprint.Doc import Text.Printf -import Text.PrettyPrint.ANSI.Leijen +import qualified Data.Text as Text + +import Data.Array.Accelerate.Pretty.Print ( Adoc, Keyword ) -- Rose tree, with all information at the leaves. @@ -36,17 +41,11 @@ instance Functor Tree where data Graph = Graph Label [Statement] data Statement = N Node | E Edge | G Graph -data Node = Node (Maybe Label) NodeId (Tree (Maybe Port, Doc)) +data Node = Node (Maybe Label) NodeId (Tree (Maybe Port, Adoc)) 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 +type Label = Text +type Port = Text data Vertex = Vertex NodeId (Maybe Port) data Edge = Edge {- from -} Vertex @@ -61,55 +60,54 @@ instance Hashable NodeId where instance Show Graph where show = show . ppGraph - -- Pretty print a (directed) graph to dot format -- -ppGraph :: Graph -> Doc +ppGraph :: Graph -> Adoc ppGraph (Graph l ss) = - vcat [ text "digraph" <+> text l <+> lbrace + vcat [ "digraph" <+> pretty l <+> lbrace , nest 4 $ vcat $ punctuate semi - $ text "graph [compound=true]" - : text "node [shape=record,fontsize=10]" + $ "graph [compound=true]" + : "node [shape=record,fontsize=10]" : map ppStatement ss , rbrace ] -ppSubgraph :: Graph -> Doc +ppSubgraph :: Graph -> Adoc ppSubgraph (Graph l ss) = - vcat [ text "subgraph cluster_" <> text l <+> lbrace + vcat [ "subgraph cluster_" <> pretty l <+> lbrace , nest 4 $ vcat $ punctuate semi - $ text "label" <> equals <> text l + $ "label" <> equals <> pretty l : map ppStatement ss , rbrace ] -ppStatement :: Statement -> Doc +ppStatement :: Statement -> Adoc 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 +ppEdge :: Edge -> Adoc +ppEdge (Edge from to) = ppVertex from <+> "->" <+> ppVertex to -ppVertex :: Vertex -> Doc -ppVertex (Vertex n p) = ppNodeId n <> maybe empty (colon<>) (fmap text p) +ppVertex :: Vertex -> Adoc +ppVertex (Vertex n p) = ppNodeId n <> maybe mempty (colon<>) (fmap pretty p) -ppNode :: Node -> Doc +ppNode :: Node -> Adoc 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)) + $ catMaybes [ fmap ((\x -> "xlabel" <> equals <> x) . dquotes . pretty) label + , Just ( "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 +ppNodeTree :: Tree (Maybe Port, Adoc) -> Adoc +ppNodeTree (Forest trees) = braces $ hcat (punctuate (pretty '|') (map ppNodeTree trees)) +ppNodeTree (Leaf (port, body)) = maybe mempty (\p -> pretty '<' <> p <> pretty '>') (fmap pretty 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, @@ -118,37 +116,39 @@ ppNodeTree (Leaf (port, body)) = maybe empty (\p -> char '<' <> p <> char '>') ( -- '\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 + pp :: Adoc -> Adoc + pp = encode . layoutSmart defaultLayoutOptions + -- pp = encode . renderSmart 0.7 120 - encode :: SimpleDoc -> Doc + encode :: SimpleDocStream Keyword -> Adoc 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 + go SFail = error "unexpected failure rendering SimpleDoc" + go SEmpty = (mempty, False) + go (SChar c x) = let (x',m) = go x in (pretty (escape c) <> x', m) + go (SText _ t x) = let (x',m) = go x in (pretty (Text.concatMap escape t) <> x', m) + go (SLine i x) = let (x',_) = go x in ("\\l" <> spaces i <> x', True) -- [1] left justify + go (SAnnPush a x) = let (x',m) = go x in (annotate a x', m) + go (SAnnPop x) = let (x',m) = go x in (unAnnotate x', m) (doc',multiline) = go doc in doc' <> if multiline - then text "\\l" - else empty + then "\\l" + else mempty - spaces :: Int -> Doc - spaces i | i <= 0 = empty - | otherwise = text (concat (replicate i "\\ ")) + spaces :: Int -> Doc ann + spaces i | i <= 0 = mempty + | otherwise = pretty (Text.replicate i "\\ ") - escape :: Char -> String + escape :: Char -> Text escape ' ' = "\\ " -- don't collapse multiple spaces escape '>' = "\\>" escape '<' = "\\<" escape '|' = "\\|" -- escape '\n' = "\\l" -- handled at [1] instead - escape c = [c] + escape c = Text.singleton c -ppNodeId :: NodeId -> Doc -ppNodeId (NodeId nid) = text (printf "Node_%#0x" nid) +ppNodeId :: NodeId -> Adoc +ppNodeId (NodeId nid) = pretty (printf "Node_%#0x" nid :: String) diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index f988990a7..cd4578774 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -1,11 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pretty.Print -- Copyright : [2008..2019] The Accelerate Team @@ -18,584 +22,587 @@ module Data.Array.Accelerate.Pretty.Print ( - -- * Pretty printing - -- ** 'OpenAcc' - -- - prettyOpenAcc, - prettyOpenAfun, - prettyOpenExp, - prettyOpenFun, - - -- ** 'PreOpenAcc' - PrettyAcc, + PrettyAcc, ExtractAcc, prettyPreOpenAcc, prettyPreOpenAfun, - -- prettyPreOpenSeq, - prettyPreExp, prettyPreOpenExp, - prettyPreFun, prettyPreOpenFun, - prettyPrim, + prettyPreOpenExp, + prettyPreOpenFun, prettyArrays, - prettyTupleIdx, - - -- ** Utilities - Val(..), PrettyEnv(..), prj, sizeEnv, - noParens, + prettyConst, + + -- ** Internals + Adoc, + Val(..), + PrettyEnv(..), + Context(..), + Keyword(..), + Operator(..), + parensIf, needsParens, + ansiKeyword, + shiftwidth, + context0, + app, + manifest, delayed, + primOperator, + isInfix, + prj, sizeEnv, ) 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 +import Data.Char +import Data.String +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Terminal +import Data.Typeable ( Typeable, typeOf, showsTypeRep ) +import Prelude hiding ( exp ) --- friends -import Data.Array.Accelerate.AST hiding ( Val(..), prj ) +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 --- =============== +-- Implementation +-- -------------- --- Pretty printing for the knot-tied 'OpenAcc' --- ------------------------------------------- +type PrettyAcc acc = forall aenv a. Context -> Val aenv -> acc aenv a -> Adoc +type ExtractAcc acc = forall aenv a. acc aenv a -> PreOpenAcc acc aenv a --- Pretty print an array expression --- -prettyOpenAcc :: PrettyAcc OpenAcc -prettyOpenAcc wrap aenv (OpenAcc acc) = prettyPreOpenAcc prettyOpenAcc wrap aenv acc +type Adoc = Doc Keyword -prettyOpenAfun :: Val aenv -> OpenAfun aenv t -> Doc -prettyOpenAfun = prettyPreOpenAfun prettyOpenAcc +data Keyword + = Statement -- do | case of | let in + | Conditional -- if then else + | Manifest -- collective operations (kernel functions) + | Delayed -- fused operators + deriving (Eq, Show) +let_, in_ :: Adoc +let_ = annotate Statement "let" +in_ = annotate Statement "in" --- Pretty print scalar expressions --- -prettyOpenFun :: Val env -> Val aenv -> OpenFun env aenv fun -> Doc -prettyOpenFun = prettyPreOpenFun prettyOpenAcc +if_, then_, else_ :: Adoc +if_ = annotate Statement "if" +then_ = annotate Statement "then" +else_ = annotate Statement "else" -prettyOpenExp :: (Doc -> Doc) -> Val env -> Val aenv -> OpenExp env aenv t -> Doc -prettyOpenExp = prettyPreOpenExp prettyOpenAcc +manifest :: Operator -> Adoc +manifest = annotate Manifest . opName +delayed :: Operator -> Adoc +delayed = annotate Delayed . opName --- Pretty printing for open 'PreOpenAcc' --- ------------------------------------- +ansiKeyword :: Keyword -> AnsiStyle +ansiKeyword Statement = colorDull Yellow +ansiKeyword Conditional = colorDull Yellow +ansiKeyword Manifest = color Blue +ansiKeyword Delayed = color Green --- The type of pretty printing functions for array computations. --- -type PrettyAcc acc = forall aenv t. - (Doc -> Doc) + +-- Array computations +-- ------------------ + +prettyPreOpenAfun + :: forall acc aenv f. + PrettyAcc acc -> Val aenv - -> acc aenv t - -> Doc + -> PreOpenAfun acc aenv f + -> Adoc +prettyPreOpenAfun prettyAcc aenv0 = next (pretty '\\') aenv0 + where + next :: Adoc -> Val aenv' -> PreOpenAfun acc aenv' f' -> Adoc + next vs aenv (Abody body) = hang shiftwidth (sep [vs <> "->", prettyAcc context0 aenv body]) + next vs aenv (Alam lam) = + let a = pretty 'a' <> pretty (sizeEnv aenv) + in next (vs <> a <> space) (aenv `Push` a) lam prettyPreOpenAcc :: forall acc aenv arrs. - PrettyAcc acc - -> (Doc -> Doc) -- apply to compound expressions - -> Val aenv -- environment of array variables + Context + -> PrettyAcc acc + -> ExtractAcc acc + -> Val aenv -> PreOpenAcc acc aenv arrs - -> Doc -prettyPreOpenAcc prettyAcc wrap aenv = pp - where - ppE :: PreExp acc aenv e -> Doc - ppE = prettyPreExp prettyAcc parens aenv + -> Adoc +prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = + case pacc of + Avar idx -> prj idx aenv + Alet{} -> prettyAlet prettyAcc extractAcc aenv pacc + Atuple tup -> prettyAtuple prettyAcc aenv tup + Apply f a -> apply + where + op = Operator ">->" Infix L 1 + apply = sep [ ppAF f, group (sep [opName op, ppA a]) ] - ppSh :: PreExp acc aenv sh -> Doc - ppSh x = encase (prettyPreExp prettyAcc noParens aenv x) + Aprj tix a -> parensIf (needsParens ctx op) aprj where - encase = case x of - Var{} -> id - IndexNil -> id - IndexAny -> id - Const{} -> id - _ -> parens + op = Operator "#" Infix L 8 + aprj = sep [ prettyAcc (arg op L) aenv a, group (sep [opName op, pretty (tupleIdxToInt tix)])] - ppF :: PreFun acc aenv f -> Doc - ppF = parens . prettyPreFun prettyAcc aenv + Acond p t e -> flatAlt multi single + where + p' = ppE p + t' = ppA t + e' = ppA e + -- + single = parensIf (needsParens ctx (Operator "?|:" Infix N 0)) + $ sep [ p', "?|", t', pretty ':', e' ] + multi = hang 3 + $ vsep [ if_ <+> p' + , hang shiftwidth (sep [ then_, t' ]) + , hang shiftwidth (sep [ else_, e' ]) ] + + Aforeign ff _f a -> "aforeign" .$ [ pretty (strForeign ff), ppA a ] + Awhile p f a -> "awhile" .$ [ ppAF p, ppAF f, ppA a ] + Use arrs -> "use" .$ [ prettyArrays (arrays @arrs) arrs ] + Unit e -> "unit" .$ [ ppE e ] + Reshape sh a -> "reshape" .$ [ ppE sh, ppA a ] + Generate sh f -> "generate" .$ [ ppE sh, ppF f ] + Transform sh p f a -> "transform" .$ [ ppE sh, ppF p, ppF f, ppA a ] + Replicate _ ix a -> "replicate" .$ [ ppE ix, ppA a ] + Slice _ a ix -> "slice" .$ [ ppE ix, ppA a ] + Map f a -> "map" .$ [ ppF f, ppA a ] + ZipWith f a b -> "zipWith" .$ [ ppF f, ppA a, ppA b ] + Fold f z a -> "fold" .$ [ ppF f, ppE z, ppA a ] + Fold1 f a -> "fold1" .$ [ ppF f, ppA a ] + FoldSeg f z a s -> "foldSeg" .$ [ ppF f, ppE z, ppA a, ppA s ] + Fold1Seg f a s -> "fold1Seg" .$ [ ppF f, ppA a, ppA s ] + Scanl f z a -> "scanl" .$ [ ppF f, ppE z, ppA a ] + Scanl' f z a -> "scanl'" .$ [ ppF f, ppE z, ppA a ] + Scanl1 f a -> "scanl1" .$ [ ppF f, ppA a ] + Scanr f z a -> "scanr" .$ [ ppF f, ppE z, ppA a ] + Scanr' f z a -> "scanr'" .$ [ ppF f, ppE z, ppA a ] + Scanr1 f a -> "scanr1" .$ [ ppF f, ppA a ] + Permute f d p s -> "permute" .$ [ ppF f, ppA d, ppF p, ppA s ] + Backpermute sh f a -> "backpermute" .$ [ ppE sh, ppF f, ppA a ] + Stencil f b a -> "stencil" .$ [ ppF f, ppB b, ppA a ] + Stencil2 f b1 a1 b2 a2 -> "stencil2" .$ [ ppF f, ppB b1, ppA a1, ppB b2, ppA a2 ] + where + infixr 0 .$ + f .$ xs + = parensIf (needsParens ctx f) + $ hang shiftwidth (sep (manifest f : xs)) - ppA :: acc aenv a -> Doc - ppA = prettyAcc parens aenv + ppA :: acc aenv a -> Adoc + ppA = prettyAcc app aenv - ppAF :: PreOpenAfun acc aenv f -> Doc + ppAF :: PreOpenAfun acc aenv f -> Adoc ppAF = parens . prettyPreOpenAfun prettyAcc aenv + ppE :: PreExp acc aenv t -> Adoc + ppE = prettyPreOpenExp app prettyAcc extractAcc Empty aenv + + ppF :: PreFun acc aenv t -> Adoc + ppF = parens . prettyPreOpenFun prettyAcc extractAcc Empty aenv + ppB :: forall sh e. 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)) + -> Adoc + ppB Clamp = "clamp" + ppB Mirror = "mirror" + ppB Wrap = "wrap" + ppB (Constant e) = prettyConst (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 @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. +prettyAlet + :: forall acc aenv 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)] + -> ExtractAcc acc + -> Val aenv + -> PreOpenAcc acc aenv arrs + -> Adoc +prettyAlet prettyAcc extractAcc aenv0 = wrap . collect aenv0 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 + collect :: Val aenv' -> PreOpenAcc acc aenv' a -> ([Adoc], Adoc) + collect aenv = + \case + Alet a1 a2 -> + let aenv' = aenv `Push` v + v = pretty 'a' <> pretty (sizeEnv aenv) + a1' = ppA aenv a1 + bnd | isAlet a1 = nest shiftwidth (vsep [v <+> equals, a1']) + | otherwise = v <+> align (equals <+> a1') + (bnds, body) = collect aenv' (extractAcc a2) + in + (bnd:bnds, body) + -- + next -> ([], prettyPreOpenAcc context0 prettyAcc extractAcc aenv next) + + isAlet :: acc aenv' a -> Bool + isAlet (extractAcc -> Alet{}) = True + isAlet _ = False + + ppA :: Val aenv' -> acc aenv' a -> Adoc + ppA = prettyAcc context0 + + wrap :: ([Adoc], Adoc) -> Adoc + wrap ([], body) = body -- shouldn't happen! + wrap ([b], body) + = sep [ nest shiftwidth (sep [let_, b]), in_, body ] + wrap (bnds, body) + = align + $ vsep [ nest shiftwidth (vsep (let_:bnds)) + , in_ + , body + ] - 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. +prettyAtuple + :: forall acc aenv t. PrettyAcc acc -> Val aenv - -> PreOpenAfun acc aenv f - -> Doc -prettyPreOpenAfun pp aenv afun = char '\\' <> next aenv afun + -> Atuple (acc aenv) t + -> Adoc +prettyAtuple prettyAcc aenv = tupled . collect [] + where + collect :: [Adoc] -> Atuple (acc aenv) s -> [Adoc] + collect acc = + \case + NilAtup -> acc + SnocAtup atup a -> collect (prettyAcc context0 aenv a : acc) atup + +prettyArrays :: ArraysR arrs -> arrs -> Adoc +prettyArrays arrs = tupled . collect arrs 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' + collect :: ArraysR arrs -> arrs -> [Adoc] + collect ArraysRunit _ = [] + collect ArraysRarray arr = [prettyArray arr] + collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2 +prettyArray :: (Shape sh, Elt e) => Array sh e -> Adoc +prettyArray = viaShow --- Pretty print a scalar function. --- -prettyPreFun :: PrettyAcc acc -> Val aenv -> PreFun acc aenv fun -> Doc -prettyPreFun pp = prettyPreOpenFun pp Empty + +-- Scalar expressions +-- ------------------ prettyPreOpenFun :: forall acc env aenv f. PrettyAcc acc - -> Val env -- environment of scalar variables - -> Val aenv -- environment of array variables + -> ExtractAcc acc + -> Val env + -> Val aenv -> PreOpenFun acc env aenv f - -> Doc -prettyPreOpenFun pp env aenv fun = char '\\' <> next env fun + -> Adoc +prettyPreOpenFun prettyAcc extractAcc env0 aenv = next (pretty '\\') env0 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 + next :: Adoc -> Val env' -> PreOpenFun acc env' aenv f' -> Adoc + next vs env (Body body) = + hang shiftwidth (sep [ vs <> "->" + , prettyPreOpenExp context0 prettyAcc extractAcc env aenv body]) + next vs env (Lam lam) = + let x = pretty 'x' <> pretty (sizeEnv env) + in next (vs <> x <> space) (env `Push` x) lam 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 + :: forall acc env aenv t. + Context + -> PrettyAcc acc + -> ExtractAcc acc + -> Val env + -> Val aenv -> PreOpenExp acc env aenv t - -> Doc -prettyPreOpenExp prettyAcc wrap env aenv = pp + -> Adoc +prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = + case exp of + Var idx -> prj idx env + Let{} -> prettyLet ctx prettyAcc extractAcc env aenv exp + PrimApp f x + | Tuple (NilTup `SnocTup` a `SnocTup` b) <- x -> ppF2 op (ppE a) (ppE b) + | otherwise -> ppF1 op' (ppE x) + where + op = primOperator f + op' = isInfix op ? (Operator (parens (opName op)) App L 10, op) + -- + PrimConst c -> prettyPrimConst c + Const c -> prettyConst (toElt c :: t) + Tuple t -> prettyTuple (eltType @t) prettyAcc extractAcc env aenv t + Prj tix e -> ppF2 (Operator "#" Infix L 8) (ppE e) (\_ -> pretty (tupleIdxToInt tix)) + Cond p t e -> flatAlt multi single + where + p' = ppE p context0 + t' = ppE t context0 + e' = ppE e context0 + -- + single = parensIf (needsParens ctx (Operator "?:" Infix N 0)) + $ sep [ p', pretty '?', t', pretty ':', e' ] + multi = hang 3 + $ vsep [ if_ <+> p' + , hang shiftwidth (sep [ then_, t' ]) + , hang shiftwidth (sep [ else_, e' ]) ] + -- + IndexAny -> "Any" + IndexNil -> pretty 'Z' + IndexCons sh sz -> ppF2 (Operator ":." Infix L 3) (ppE sh) (ppE sz) + IndexHead sh -> ppF1 "indexHead" (ppE sh) + IndexTail sh -> ppF1 "indexTail" (ppE sh) + IndexSlice _ slix sh -> ppF2 "indexSlice" (ppE slix) (ppE sh) + IndexFull _ slix sl -> ppF2 "indexFull" (ppE slix) (ppE sl) + ToIndex sh ix -> ppF2 "toIndex" (ppE sh) (ppE ix) + FromIndex sh ix -> ppF2 "fromIndex" (ppE sh) (ppE ix) + While p f x -> ppF3 "while" (ppF p) (ppF f) (ppE x) + Foreign ff _f e -> ppF2 "foreign" (\_ -> pretty (strForeign ff)) (ppE e) + Shape arr -> ppF1 "shape" (ppA arr) + ShapeSize sh -> ppF1 "shapeSize" (ppE sh) + Intersect sh1 sh2 -> ppF2 "intersect" (ppE sh1) (ppE sh2) + Union sh1 sh2 -> ppF2 "union" (ppE sh1) (ppE sh2) + Index arr ix -> ppF2 (Operator (pretty '!') Infix L 9) (ppA arr) (ppE ix) + LinearIndex arr ix -> ppF2 (Operator "!!" Infix L 9) (ppA arr) (ppE ix) + Coerce x -> ppF1 (Operator (withTypeRep "coerce") App L 10) (ppE x) + Undef -> withTypeRep "undef" + 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 e -> Context -> Adoc + ppE e c = prettyPreOpenExp c prettyAcc extractAcc env aenv e + + ppA :: acc aenv a -> Context -> Adoc + ppA acc _ = prettyAcc app aenv acc + + ppF :: PreOpenFun acc env aenv f -> Context -> Adoc + ppF f _ = parens $ prettyPreOpenFun prettyAcc extractAcc env aenv f - ppSh :: PreOpenExp acc env aenv sh -> Doc - ppSh x = encase (ppE' x) + ppF1 :: Operator -> (Context -> Adoc) -> Adoc + ppF1 op x + = parensIf (needsParens ctx op) + $ combine [ opName op, x ctx' ] where - encase = case x of - Var{} -> id - IndexNil -> id - IndexAny -> id - Const{} -> id - _ -> parens + ctx' = isPrefix op ? (arg op R, app) + combine = isPrefix op ? (cat, hang 2 . sep) - ppF :: PreOpenFun acc env aenv f -> Doc - ppF = parens . prettyPreOpenFun prettyAcc env aenv + ppF2 :: Operator -> (Context -> Adoc) -> (Context -> Adoc) -> Adoc + ppF2 op x y + = parensIf (needsParens ctx op) + $ if isInfix op + then sep [ x (arg op L), group (sep [opName op, y (arg op R)]) ] + else hang 2 $ sep [ opName op, x app, y app ] - ppA :: acc aenv a -> Doc - ppA = prettyAcc parens aenv + ppF3 :: Operator -> (Context -> Adoc) -> (Context -> Adoc) -> (Context -> Adoc) -> Adoc + ppF3 op x y z + = parensIf (needsParens ctx op) + $ hang 2 + $ sep [ opName op, x app, y app, z app ] - -- pretty print a named array operation with its arguments - infixr 0 .$ - name .$ docs = wrap $ hang 2 (sep (text name : docs)) + withTypeRep :: Typeable t => Adoc -> Adoc + withTypeRep op = op <> enclose langle rangle (pretty (showsTypeRep (typeOf (undefined::t)) "")) - -- 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 @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 + +prettyLet + :: forall acc env aenv t. + Context + -> PrettyAcc acc + -> ExtractAcc acc + -> Val env -> Val aenv - -> Atuple (acc aenv) t - -> Doc -prettyAtuple pp aenv = tupled False . collect + -> PreOpenExp acc env aenv t + -> Adoc +prettyLet ctx prettyAcc extractAcc env0 aenv + = parensIf (needsParens ctx "let") + . wrap . collect env0 where - collect :: Atuple (acc aenv) t' -> [Doc] - collect NilAtup = [] - collect (SnocAtup tup a) = collect tup ++ [pp noParens aenv a] + collect :: Val env' -> PreOpenExp acc env' aenv e -> ([Adoc], Adoc) + collect env = + \case + Let e1 e2 -> + let env' = env `Push` v + v = pretty 'x' <> pretty (sizeEnv env) + e1' = ppE env e1 + bnd | isLet e1 = nest shiftwidth (vsep [v <+> equals, e1']) + | otherwise = v <+> align (equals <+> e1') + (bnds, body) = collect env' e2 + in + (bnd:bnds, body) + -- + next -> ([], ppE env next) + + isLet :: PreOpenExp acc env' aenv t' -> Bool + isLet Let{} = True + isLet _ = False + + ppE :: Val env' -> PreOpenExp acc env' aenv t' -> Adoc + ppE env = prettyPreOpenExp context0 prettyAcc extractAcc env aenv + + wrap :: ([Adoc], Adoc) -> Adoc + wrap ([], body) = body -- shouldn't happen! + wrap ([b], body) + = sep [ nest shiftwidth (sep [let_, b]), in_, body ] + wrap (bnds, body) + = align + $ vsep [ nest shiftwidth (vsep (let_ : bnds)) + , in_ + , body + ] prettyTuple :: forall acc env aenv t p. TupleType t -> PrettyAcc acc + -> ExtractAcc 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) + -> Adoc +prettyTuple tt prettyAcc extractAcc env aenv = wrap . collect [] where - toInt :: TupleIdx t e -> Int - toInt ZeroTupIdx = 0 - toInt (SuccTupIdx tup) = toInt tup + 1 + collect :: [Adoc] -> Tuple (PreOpenExp acc env aenv) s -> [Adoc] + collect acc = + \case + NilTup -> acc + SnocTup tup e -> collect (prettyPreOpenExp context0 prettyAcc extractAcc env aenv e : acc) tup + -- + wrap + | TypeRscalar VectorScalarType{} <- tt = group . encloseSep (flatAlt "< " "<") (flatAlt " >" ">") ", " + | otherwise = tupled -- as above, with parenthesis --- 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 --} +prettyConst :: Elt e => e -> Adoc +prettyConst x = + let y = show x + in parensIf (any isSpace y) (pretty y) --- 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 +prettyPrimConst :: PrimConst a -> Adoc +prettyPrimConst PrimMinBound{} = "minBound" +prettyPrimConst PrimMaxBound{} = "maxBound" +prettyPrimConst PrimPi{} = "pi" -prettyArray :: (Shape sh, Elt e) => Array sh e -> Doc -prettyArray arr - = hang 2 $ sep [ text "Array" - , parens . text $ showShape (shape arr) - , 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 +-- Primitive operators +-- ------------------- -- - -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 +-- The core of the pretty printer is how to correctly handle precedence, +-- associativity, and fixity of the primitive scalar operators. -- -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") +data Direction = L | N | R + deriving Eq + +data Fixity = App | Infix | Prefix + deriving Eq + +type Precedence = Int +type Associativity = Direction + +data Context = Context + { ctxAssociativity :: Associativity + , ctxPosition :: Direction + , ctxPrecedence :: Precedence + } + +data Operator = Operator + { opName :: Adoc + , opFixity :: Fixity + , opAssociativity :: Associativity + , opPrecedence :: Precedence + } + +instance IsString Operator where + fromString s = Operator (fromString s) App L 10 + +needsParens :: Context -> Operator -> Bool +needsParens Context{..} Operator{..} + | ctxPrecedence < opPrecedence = False + | ctxPrecedence > opPrecedence = True + | ctxAssociativity /= opAssociativity = True + | otherwise = ctxPosition /= opAssociativity + +context0 :: Context +context0 = Context N N 0 + +app :: Context +app = Context L N 10 + +arg :: Operator -> Direction -> Context +arg Operator{..} side = Context opAssociativity side opPrecedence + +isPrefix :: Operator -> Bool +isPrefix Operator{..} = opFixity == Prefix + +isInfix :: Operator -> Bool +isInfix Operator{..} = opFixity == Infix + +primOperator :: PrimFun a -> Operator +primOperator PrimAdd{} = Operator (pretty '+') Infix L 6 +primOperator PrimSub{} = Operator (pretty '-') Infix L 6 +primOperator PrimMul{} = Operator (pretty '*') Infix L 7 +primOperator PrimNeg{} = Operator (pretty '-') Prefix L 6 -- Haskell's only prefix operator +primOperator PrimAbs{} = Operator "abs" App L 10 +primOperator PrimSig{} = Operator "signum" App L 10 +primOperator PrimQuot{} = Operator "quot" App L 10 +primOperator PrimRem{} = Operator "rem" App L 10 +primOperator PrimQuotRem{} = Operator "quotRem" App L 10 +primOperator PrimIDiv{} = Operator "div" App L 10 +primOperator PrimMod{} = Operator "mod" App L 10 +primOperator PrimDivMod{} = Operator "divMod" App L 10 +primOperator PrimBAnd{} = Operator ".&." Infix L 7 +primOperator PrimBOr{} = Operator ".|." Infix L 5 +primOperator PrimBXor{} = Operator "xor" App L 10 +primOperator PrimBNot{} = Operator "complement" App L 10 +primOperator PrimBShiftL{} = Operator "shiftL" App L 10 +primOperator PrimBShiftR{} = Operator "shiftR" App L 10 +primOperator PrimBRotateL{} = Operator "rotateL" App L 10 +primOperator PrimBRotateR{} = Operator "rotateR" App L 10 +primOperator PrimPopCount{} = Operator "popCount" App L 10 +primOperator PrimCountLeadingZeros{} = Operator "countLeadingZeros" App L 10 +primOperator PrimCountTrailingZeros{} = Operator "countTrailingZeros" App L 10 +primOperator PrimFDiv{} = Operator (pretty '/') Infix L 7 +primOperator PrimRecip{} = Operator "recip" App L 10 +primOperator PrimSin{} = Operator "sin" App L 10 +primOperator PrimCos{} = Operator "cos" App L 10 +primOperator PrimTan{} = Operator "tan" App L 10 +primOperator PrimAsin{} = Operator "asin" App L 10 +primOperator PrimAcos{} = Operator "acos" App L 10 +primOperator PrimAtan{} = Operator "atan" App L 10 +primOperator PrimSinh{} = Operator "sinh" App L 10 +primOperator PrimCosh{} = Operator "cosh" App L 10 +primOperator PrimTanh{} = Operator "tanh" App L 10 +primOperator PrimAsinh{} = Operator "asinh" App L 10 +primOperator PrimAcosh{} = Operator "acosh" App L 10 +primOperator PrimAtanh{} = Operator "atanh" App L 10 +primOperator PrimExpFloating{} = Operator "exp" App L 10 +primOperator PrimSqrt{} = Operator "sqrt" App L 10 +primOperator PrimLog{} = Operator "log" App L 10 +primOperator PrimFPow{} = Operator "**" Infix R 8 +primOperator PrimLogBase{} = Operator "logBase" App L 10 +primOperator PrimTruncate{} = Operator "truncate" App L 10 +primOperator PrimRound{} = Operator "round" App L 10 +primOperator PrimFloor{} = Operator "floor" App L 10 +primOperator PrimCeiling{} = Operator "ceiling" App L 10 +primOperator PrimAtan2{} = Operator "atan2" App L 10 +primOperator PrimIsNaN{} = Operator "isNaN" App L 10 +primOperator PrimIsInfinite{} = Operator "isInfinite" App L 10 +primOperator PrimLt{} = Operator "<" Infix N 4 +primOperator PrimGt{} = Operator ">" Infix N 4 +primOperator PrimLtEq{} = Operator "<=" Infix N 4 +primOperator PrimGtEq{} = Operator ">=" Infix N 4 +primOperator PrimEq{} = Operator "==" Infix N 4 +primOperator PrimNEq{} = Operator "/=" Infix N 4 +primOperator PrimMax{} = Operator "max" App L 10 +primOperator PrimMin{} = Operator "min" App L 10 +primOperator PrimLAnd = Operator "&&" Infix R 3 +primOperator PrimLOr = Operator "||" Infix R 2 +primOperator PrimLNot = Operator "not" App L 10 +primOperator PrimOrd = Operator "ord" App L 10 +primOperator PrimChr = Operator "chr" App L 10 +primOperator PrimBoolToInt = Operator "boolToInt" App L 10 +primOperator PrimFromIntegral{} = Operator "fromIntegral" App L 10 +primOperator PrimToFloating{} = Operator "toFloating" App L 10 -- Environments -- ------------ data Val env where - Empty :: Val () - Push :: Val env -> Doc -> Val (env, t) + Empty :: Val () + Push :: Val env -> Adoc -> Val (env, t) class PrettyEnv env where - prettyEnv :: Val env + prettyEnv :: Adoc -> Val env instance PrettyEnv () where - prettyEnv = Empty + prettyEnv _ = Empty instance PrettyEnv env => PrettyEnv (env, t) where - prettyEnv = - let env = prettyEnv :: Val env - x = char 'a' <> int (sizeEnv env) + prettyEnv v = + let env = prettyEnv v :: Val env + x = v <> pretty (sizeEnv env) in env `Push` x @@ -603,7 +610,7 @@ sizeEnv :: Val env -> Int sizeEnv Empty = 0 sizeEnv (Push env _) = 1 + sizeEnv env -prj :: Idx env t -> Val env -> Doc +prj :: Idx env t -> Val env -> Adoc prj ZeroIdx (Push _ v) = v prj (SuccIdx ix) (Push env _) = prj ix env #if __GLASGOW_HASKELL__ < 800 @@ -611,21 +618,18 @@ prj _ _ = error "inconsistent valuation" #endif --- Auxiliary operations --- -------------------- +-- Utilities +-- --------- --- Auxiliary dictionary operations --- +shiftwidth :: Int +shiftwidth = 2 -{- --- 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 --} +infix 0 ? +(?) :: Bool -> (a, a) -> a +True ? (t,_) = t +False ? (_,f) = f + +parensIf :: Bool -> Doc ann -> Doc ann +parensIf True = group . parens . align +parensIf False = id diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 40d8294b8..f5c3f5696 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -31,6 +30,10 @@ module Data.Array.Accelerate.Trafo ( -- ** Sequence computations -- convertSeq, convertSeqWith, + -- ** Scalar expressions + Function, FunctionR, + convertExp, convertFun, + -- * Fusion module Data.Array.Accelerate.Trafo.Fusion, @@ -43,7 +46,6 @@ module Data.Array.Accelerate.Trafo ( -- ** Auxiliary matchDelayedOpenAcc, encodeDelayedOpenAcc, - hashDelayedOpenAcc, hashDelayedOpenAccWith, ) where @@ -51,7 +53,6 @@ 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 @@ -67,8 +68,8 @@ import qualified Data.Array.Accelerate.Trafo.Sharing as Sharing #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 +import Data.Array.Accelerate.Debug.Flags hiding ( when ) +import Data.Array.Accelerate.Debug.Timed #endif @@ -188,45 +189,9 @@ convertSeqWith Phase{..} s $ 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. -- diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index c23908a7c..87370661a 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -30,8 +31,10 @@ module Data.Array.Accelerate.Trafo.Algebra ( import Data.Bits import Data.Char import Data.Monoid +import Data.Text ( Text ) +import Data.Text.Prettyprint.Doc +import Data.Text.Prettyprint.Doc.Render.Text import GHC.Float ( float2Double, double2Float ) -import Text.PrettyPrint.ANSI.Leijen import Prelude hiding ( exp ) import qualified Prelude as P @@ -39,12 +42,12 @@ import qualified Prelude as P 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.Pretty.Print ( primOperator, isInfix, opName ) import Data.Array.Accelerate.Product import Data.Array.Accelerate.Trafo.Base import Data.Array.Accelerate.Type -import qualified Data.Array.Accelerate.Debug as Stats +import qualified Data.Array.Accelerate.Debug.Stats as Stats -- Propagate constant expressions, which are either constant valued expressions @@ -292,8 +295,16 @@ untup2 exp | otherwise = Nothing -pprFun :: String -> PrimFun f -> String -pprFun rule f = show $ text rule <+> snd (prettyPrim f) +pprFun :: Text -> PrimFun f -> Text +pprFun rule f + = renderStrict + . layoutCompact + $ pretty rule <+> f' + where + op = primOperator f + f' = if isInfix op + then parens (opName op) + else opName op -- Methods of Num @@ -438,7 +449,15 @@ 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 (.|.) +evalBOr ty | IntegralDict <- integralDict ty = evalBOr' + +evalBOr' :: (Elt a, Eq a, Num a, Bits a) => (a,a) :-> a +evalBOr' (untup2 -> Just (x,y)) env + | Just 0 <- propagate env x + = Stats.ruleFired "x .|. 0" $ Just y + +evalBOr' arg env + = eval2 (.|.) arg env evalBXor :: Elt a => IntegralType a -> (a,a) :-> a evalBXor ty | IntegralDict <- integralDict ty = eval2 xor diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index 92bedb461..31de0ff79 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -29,7 +30,7 @@ module Data.Array.Accelerate.Trafo.Base ( -- Toolkit Kit(..), Match(..), (:~:)(..), - avarIn, kmap, fromOpenAfun, + avarIn, kmap, -- Delayed Arrays DelayedAcc, DelayedOpenAcc(..), @@ -38,7 +39,6 @@ module Data.Array.Accelerate.Trafo.Base ( DelayedFun, DelayedOpenFun, matchDelayedOpenAcc, encodeDelayedOpenAcc, - hashDelayedOpenAcc, hashDelayedOpenAccWith, -- Environments Gamma(..), incExp, prjExp, pushExp, @@ -51,12 +51,11 @@ module Data.Array.Accelerate.Trafo.Base ( -- standard library import Control.Applicative import Control.DeepSeq -import Crypto.Hash import Data.ByteString.Builder import Data.ByteString.Builder.Extra +import Data.Maybe import Data.Monoid import Data.Type.Equality -import Text.PrettyPrint.ANSI.Leijen hiding ( (<$>), (<>) ) import Prelude hiding ( until ) -- friends @@ -65,7 +64,6 @@ 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 @@ -79,34 +77,34 @@ import Data.Array.Accelerate.Debug.Stats as Stats -- 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 + extract :: acc aenv a -> Maybe (PreOpenAcc 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 options (OpenAcc pacc) = encodePreOpenAcc options encodeAcc pacc - matchAcc (OpenAcc pacc1) (OpenAcc pacc2) = matchPreOpenAcc matchAcc encodeAcc pacc1 pacc2 - prettyAcc = prettyOpenAcc + inject = OpenAcc + extract (OpenAcc pacc) = Just pacc + encodeAcc = encodeOpenAcc + matchAcc = matchOpenAcc + +encodeOpenAcc :: EncodeAcc OpenAcc +encodeOpenAcc options (OpenAcc pacc) = encodePreOpenAcc options encodeAcc pacc + +matchOpenAcc :: MatchAcc OpenAcc +matchOpenAcc (OpenAcc pacc1) (OpenAcc pacc2) = matchPreOpenAcc matchAcc encodeAcc pacc1 pacc2 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 +kmap f = inject . f . fromJust . extract -fromOpenAfun :: Kit acc => OpenAfun aenv f -> PreOpenAfun acc aenv f -fromOpenAfun (Abody a) = Abody $ fromOpenAcc a -fromOpenAfun (Alam f) = Alam $ fromOpenAfun f +-- 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. @@ -180,17 +178,13 @@ 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 #-} + inject = Manifest + extract (Manifest pacc) = Just pacc + extract Delayed{} = Nothing encodeAcc = encodeDelayedOpenAcc matchAcc = matchDelayedOpenAcc - prettyAcc = prettyDelayedOpenAcc instance NFData (DelayedOpenAfun aenv t) where rnf = rnfPreOpenAfun rnfDelayedOpenAcc @@ -201,18 +195,6 @@ instance NFData (DelayedOpenAcc aenv t) where -- instance NFData (DelayedSeq t) where -- rnf = rnfDelayedSeq - -{-# INLINEABLE hashDelayedOpenAcc #-} -hashDelayedOpenAcc :: DelayedOpenAcc aenv a -> Hash -hashDelayedOpenAcc = hashDelayedOpenAccWith defaultHashOptions - -{-# INLINEABLE hashDelayedOpenAccWith #-} -hashDelayedOpenAccWith :: HashOptions -> DelayedOpenAcc aenv a -> Hash -hashDelayedOpenAccWith options - = hashlazy - . toLazyByteString - . encodeDelayedOpenAcc options - {-# INLINEABLE encodeDelayedOpenAcc #-} encodeDelayedOpenAcc :: EncodeAcc DelayedOpenAcc encodeDelayedOpenAcc options acc = @@ -231,8 +213,8 @@ encodeDelayedOpenAcc options acc = | otherwise = mempty in case acc of - Manifest pacc -> intHost $(hashQ "Manifest") <> deep (travA pacc) - Delayed sh f g -> intHost $(hashQ "Delayed") <> travE sh <> travF f <> travF g + Manifest pacc -> intHost $(hashQ ("Manifest" :: String)) <> deep (travA pacc) + Delayed sh f g -> intHost $(hashQ ("Delayed" :: String)) <> travE sh <> travF f <> travF g {-# INLINEABLE matchDelayedOpenAcc #-} matchDelayedOpenAcc :: MatchAcc DelayedOpenAcc @@ -265,51 +247,6 @@ 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 -- ============ diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 9683bdcd0..f8b1b5e62 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -3,8 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -61,7 +61,7 @@ import Data.Array.Accelerate.Array.Sugar ( Array, Arrays(..), Arr import Data.Array.Accelerate.Product import Data.Array.Accelerate.Type -import qualified Data.Array.Accelerate.Debug as Stats +import qualified Data.Array.Accelerate.Debug.Stats as Stats #ifdef ACCELERATE_DEBUG import System.IO.Unsafe -- for debugging #endif @@ -1450,9 +1450,10 @@ applyD :: (Kit acc, Arrays as, Arrays bs) -> Embed acc aenv bs applyD afun x | Alam (Abody body) <- afun - , Avar ZeroIdx <- extract body + , Just (Avar ZeroIdx) <- extract body + , Just x' <- extract x = Stats.ruleFired "applyD/identity" - $ done $ extract x + $ done x' | otherwise = done $ Apply afun x @@ -1491,8 +1492,8 @@ aprjD :: forall acc aenv arrs a. (Kit acc, IsAtuple arrs, Arrays arrs, Arrays 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) + | Just (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 diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index a20432ade..205e93471 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -60,7 +60,8 @@ import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), , PreBoundary(..), Boundary, Stencil(..) , showPreAccOp, showPreExpOp ) import qualified Data.Array.Accelerate.AST as AST -import qualified Data.Array.Accelerate.Debug as Debug +import qualified Data.Array.Accelerate.Debug.Trace as Debug +import qualified Data.Array.Accelerate.Debug.Flags as Debug -- Configuration diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index c1bf15f2d..346e8566a 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -47,7 +48,7 @@ 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 +import qualified Data.Array.Accelerate.Debug.Stats as Stats class Shrink f where diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index f647eee98..dee10f711 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -49,7 +50,9 @@ import Data.Array.Accelerate.Trafo.Shrink import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt(..), Z(..), (:.)(..) , Tuple(..), IsTuple, fromTuple, TupleRepr, shapeToList ) -import qualified Data.Array.Accelerate.Debug as Stats +import qualified Data.Array.Accelerate.Debug.Stats as Stats +import qualified Data.Array.Accelerate.Debug.Flags as Debug +import qualified Data.Array.Accelerate.Debug.Trace as Debug class Simplify f where @@ -483,7 +486,7 @@ iterate summarise f = fix 1 . setup lIMIT = 25 simplify' = Stats.simplifierDone . f - setup x = Stats.trace Stats.dump_simpl_iterations (msg 0 "init" x) + setup x = Debug.trace Debug.dump_simpl_iterations (msg 0 "init" x) $ snd (trace 1 "simplify" (simplify' x)) fix :: Int -> f a -> f a @@ -501,7 +504,7 @@ iterate summarise f = fix 1 . setup u ==^ (_,v) = isJust (match u v) trace i s v@(changed,x) - | changed = Stats.trace Stats.dump_simpl_iterations (msg i s x) v + | changed = Debug.trace Debug.dump_simpl_iterations (msg i s x) v | otherwise = v msg :: Int -> String -> f a -> String diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index a4cc56083..dd768b5d9 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index cf4652540..f7d09c80d 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -79,6 +80,7 @@ import Data.Bits import Data.Int import Data.Primitive.ByteArray import Data.Primitive.Types +import Data.Text.Prettyprint.Doc import Data.Type.Equality import Data.Typeable import Data.Word @@ -86,7 +88,6 @@ import Foreign.C.Types import Foreign.Storable ( Storable ) import Language.Haskell.TH import Numeric.Half -import Text.PrettyPrint.ANSI.Leijen import Text.Printf import GHC.Base ( isTrue# ) @@ -359,7 +360,9 @@ instance (Show a, Prim a, KnownNat n) => Show (Vec n a) where show (Vec ba#) = vec (go 0#) where vec :: [a] -> String - vec = show . encloseSep langle rangle comma . map (text . show) + vec = show + . group . encloseSep (flatAlt "< " "<") (flatAlt " >" ">") ", " + . map viaShow -- go :: Int# -> [a] go i# | isTrue# (i# <# n#) = indexByteArray# ba# i# : go (i# +# 1#) From 8868a43d20fcbfff8bab3559b65fba131a4fec98 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 Mar 2019 11:24:42 +0100 Subject: [PATCH 012/316] cabal: bump lower bound on prettyprinter --- accelerate.cabal | 2 +- stack-8.0.yaml | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/accelerate.cabal b/accelerate.cabal index 7b30cd647..d5db25ba7 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -277,7 +277,7 @@ Library , hedgehog >= 0.5 , lens >= 4.0 , mtl >= 2.0 - , prettyprinter >= 1.0 + , prettyprinter >= 1.2 , prettyprinter-ansi-terminal >= 1.0 , primitive >= 0.6.4 , tasty >= 0.11 diff --git a/stack-8.0.yaml b/stack-8.0.yaml index f934e4d02..5aed69f5d 100644 --- a/stack-8.0.yaml +++ b/stack-8.0.yaml @@ -9,6 +9,7 @@ packages: extra-deps: - half-0.3 - hashtables-1.2.3.0 +- prettyprinter-1.2.1 - primitive-0.6.4.0 - tasty-hedgehog-0.2.0.0 From 4f2916fc8671a16a5b8658cf904d2444a6c72634 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 Mar 2019 11:59:04 +0100 Subject: [PATCH 013/316] travis: wibble --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index a46de4cdc..7364388d8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -27,7 +27,7 @@ addons: matrix: fast_finish: true include: - - env: GHC=8.6.3 + - env: GHC=8.6.4 compiler: "GHC 8.6" - env: GHC=8.4.3 From cfa1f48bef0e8d5bf2bec60a11ade2cac2153a9d Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 21 Mar 2019 13:30:37 +0100 Subject: [PATCH 014/316] update README.md --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index cd9111512..728b8ca7a 100644 --- a/README.md +++ b/README.md @@ -90,7 +90,7 @@ Documentation * Haddock documentation is included and linked with the individual package releases on [Hackage][Hackage]. * Haddock documentation for in-development components can be found [here](http://tmcdonell-bot.github.io/accelerate-travis-buildbot/). - * The idea behind the HOAS (higher-order abstract syntax) to de-Bruijn conversion used in the library is [described separately][HOAS-conv]. + * The idea behind the HOAS (higher-order abstract syntax) to de-Bruijn conversion used in the library is [~~described separately~~][HOAS-conv]. Examples -------- @@ -146,7 +146,7 @@ Who are we? The Accelerate team (past and present) consists of: - * Manuel M T Chakravarty ([@mchakravarty]) + * Manuel M T Chakravarty ([@mchakravarty]) * Gabriele Keller ([@gckeller]) * Trevor L. McDonell ([@tmcdonell]) * Robert Clifton-Everest ([@robeverest]) From e7febfe62b92e6895599a793142678d59ff7980b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 21 Mar 2019 22:13:31 +0100 Subject: [PATCH 015/316] travis: wibble --- .travis.yml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 7364388d8..7a7469e49 100644 --- a/.travis.yml +++ b/.travis.yml @@ -55,13 +55,16 @@ before_install: * ) export HADDOCK="--haddock --no-haddock-deps" ;; esac -install: + # build environment - echo "$(stack exec ghc -- --version) [$(stack exec ghc -- --print-project-git-commit-id 2> /dev/null || echo '?')]" - stack --version - - travis_retry stack build --fast --jobs=2 --test --only-dependencies --no-terminal --no-copy-bins --flag accelerate:nofib + +install: + - export FLAGS="--jobs=2 --no-terminal --no-copy-bins --flag accelerate:nofib" + - travis_retry stack build $FLAGS --only-dependencies --test script: - - stack build --fast --jobs=2 --test --no-terminal --no-copy-bins --no-run-tests ${HADDOCK} --flag accelerate:nofib + - stack build $FLAGS $HADDOCK --test --no-run-tests - stack test accelerate:doctest --flag accelerate:nofib - stack test accelerate:nofib-interpreter --test-arguments='--hedgehog-tests 25' --flag accelerate:nofib From 238f6bf64012bc3639f1c0a75e3b039ff23fd4fe Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 26 Mar 2019 22:03:04 +0100 Subject: [PATCH 016/316] pp: more alignment --- src/Data/Array/Accelerate/Pretty/Print.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index cd4578774..97c8ca37b 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -211,7 +211,7 @@ prettyAlet -> Val aenv -> PreOpenAcc acc aenv arrs -> Adoc -prettyAlet prettyAcc extractAcc aenv0 = wrap . collect aenv0 +prettyAlet prettyAcc extractAcc aenv0 = align . wrap . collect aenv0 where collect :: Val aenv' -> PreOpenAcc acc aenv' a -> ([Adoc], Adoc) collect aenv = @@ -240,8 +240,7 @@ prettyAlet prettyAcc extractAcc aenv0 = wrap . collect aenv0 wrap ([b], body) = sep [ nest shiftwidth (sep [let_, b]), in_, body ] wrap (bnds, body) - = align - $ vsep [ nest shiftwidth (vsep (let_:bnds)) + = vsep [ nest shiftwidth (vsep (let_:bnds)) , in_ , body ] @@ -396,7 +395,7 @@ prettyLet -> Adoc prettyLet ctx prettyAcc extractAcc env0 aenv = parensIf (needsParens ctx "let") - . wrap . collect env0 + . align . wrap . collect env0 where collect :: Val env' -> PreOpenExp acc env' aenv e -> ([Adoc], Adoc) collect env = @@ -425,8 +424,7 @@ prettyLet ctx prettyAcc extractAcc env0 aenv wrap ([b], body) = sep [ nest shiftwidth (sep [let_, b]), in_, body ] wrap (bnds, body) - = align - $ vsep [ nest shiftwidth (vsep (let_ : bnds)) + = vsep [ nest shiftwidth (vsep (let_ : bnds)) , in_ , body ] @@ -446,7 +444,7 @@ prettyTuple tt prettyAcc extractAcc env aenv = wrap . collect [] collect acc = \case NilTup -> acc - SnocTup tup e -> collect (prettyPreOpenExp context0 prettyAcc extractAcc env aenv e : acc) tup + SnocTup tup e -> collect (align (prettyPreOpenExp context0 prettyAcc extractAcc env aenv e) : acc) tup -- wrap | TypeRscalar VectorScalarType{} <- tt = group . encloseSep (flatAlt "< " "<") (flatAlt " >" ">") ", " From e80e05ee096dca5986f943a917601c876f6cb88b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 29 Mar 2019 16:01:22 +0100 Subject: [PATCH 017/316] note to self --- src/Data/Array/Accelerate/Array/Sugar.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 121daa90b..8f77f46d7 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -303,6 +303,8 @@ instance (GElt a, GElt b) => GElt (a :*: b) where -- -- Instances for basic types are generated at the end of this module. -- +-- TLM 2019-03-22: I think this is fixed now +-- instance Elt () where type EltRepr () = () From d73f3dcf5ce27a03d19e7394711f33e88254cd26 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 29 Mar 2019 16:02:03 +0100 Subject: [PATCH 018/316] pp: simplify some pretty printed functions --- src/Data/Array/Accelerate/Pretty/Print.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 97c8ca37b..0bde48093 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -285,9 +285,18 @@ prettyPreOpenFun prettyPreOpenFun prettyAcc extractAcc env0 aenv = next (pretty '\\') env0 where next :: Adoc -> Val env' -> PreOpenFun acc env' aenv f' -> Adoc - next vs env (Body body) = - hang shiftwidth (sep [ vs <> "->" - , prettyPreOpenExp context0 prettyAcc extractAcc env aenv body]) + next vs env (Body body) + -- | PrimApp f x <- body + -- , op <- primOperator f + -- , isInfix op + -- , Tuple (NilTup `SnocTup` a `SnocTup` b) <- x + -- , Var (SuccIdx ZeroIdx) <- a + -- , Var ZeroIdx <- b + -- = opName op -- surrounding context will add parens + -- + -- | otherwise + = hang shiftwidth (sep [ vs <> "->" + , prettyPreOpenExp context0 prettyAcc extractAcc env aenv body]) next vs env (Lam lam) = let x = pretty 'x' <> pretty (sizeEnv env) in next (vs <> x <> space) (env `Push` x) lam From c71473878ee916b78fa34eb01825506d94cf08f1 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 10 Apr 2019 08:56:49 +0200 Subject: [PATCH 019/316] warning police --- src/Data/Array/Accelerate/Pretty.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index 3fc224cd2..0122dfa2a 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -35,7 +35,6 @@ module Data.Array.Accelerate.Pretty ( ) where -- libraries -import Control.DeepSeq import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String import Data.Text.Prettyprint.Doc.Render.Terminal @@ -53,9 +52,12 @@ import Data.Array.Accelerate.Error import Data.Array.Accelerate.Pretty.Print hiding ( Keyword(..) ) import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.Pretty.Graphviz + +#if ACCELERATE_DEBUG +import Control.DeepSeq import Data.Array.Accelerate.Debug.Flags import Data.Array.Accelerate.Debug.Stats - +#endif instance Arrays arrs => Show (Acc arrs) where From 2276b12544c9ef40c3d9795cae7ea2b56211b9be Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 10 Apr 2019 08:56:54 +0200 Subject: [PATCH 020/316] haddock fix --- src/Data/Array/Accelerate/Pretty/Print.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 0bde48093..d94eddcbb 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -286,7 +286,7 @@ prettyPreOpenFun prettyAcc extractAcc env0 aenv = next (pretty '\\') env0 where next :: Adoc -> Val env' -> PreOpenFun acc env' aenv f' -> Adoc next vs env (Body body) - -- | PrimApp f x <- body + -- PrimApp f x <- body -- , op <- primOperator f -- , isInfix op -- , Tuple (NilTup `SnocTup` a `SnocTup` b) <- x @@ -294,7 +294,6 @@ prettyPreOpenFun prettyAcc extractAcc env0 aenv = next (pretty '\\') env0 -- , Var ZeroIdx <- b -- = opName op -- surrounding context will add parens -- - -- | otherwise = hang shiftwidth (sep [ vs <> "->" , prettyPreOpenExp context0 prettyAcc extractAcc env aenv body]) next vs env (Lam lam) = From 8b3b5ad12f25ab2875c9835166e2c5917a6ede06 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 26 Apr 2019 18:58:04 +0200 Subject: [PATCH 021/316] add pattern synonyms for indices --- src/Data/Array/Accelerate.hs | 4 ++ src/Data/Array/Accelerate/Pattern.hs | 100 +++++++++++++++++++++++++-- 2 files changed, 100 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 7befec2ae..347b2b8ab 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -333,6 +333,10 @@ module Data.Array.Accelerate ( pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, + pattern Z_, pattern Ix, + pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, + pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, + -- ** Scalar operations -- *** Introduction constant, diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 46c079dc5..5f2de4678 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -25,6 +26,10 @@ module Data.Array.Accelerate.Pattern ( pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, + pattern Z_, pattern Ix, + pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, + pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, + ) where import Data.Array.Accelerate.Array.Sugar @@ -45,6 +50,81 @@ class IsPattern con a t where construct :: t -> con a destruct :: con a -> t + +-- | Pattern synonyms for indices, which may be more convenient to use than +-- 'Data.Array.Accelerate.Lift.lift' and +-- 'Data.Array.Accelerate.Lift.unlift'. +-- +pattern Z_ :: Exp DIM0 +pattern Z_ = Pattern Z +{-# COMPLETE Z_ #-} + +pattern Ix :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) +pattern a `Ix` b = Pattern (a :. b) +{-# COMPLETE Ix #-} + +pattern I0 :: Exp DIM0 +pattern I0 = Z_ +{-# COMPLETE I0 #-} + +pattern I1 :: Elt a => Exp a -> Exp (Z :. a) +pattern I1 a = Z_ `Ix` a +{-# COMPLETE I1 #-} + +pattern I2 :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (Z :. a :. b) +pattern I2 a b = Z_ `Ix` a `Ix` b +{-# COMPLETE I2 #-} + +pattern I3 + :: (Elt a, Elt b, Elt c) + => Exp a -> Exp b -> Exp c + -> Exp (Z :. a :. b :. c) +pattern I3 a b c = Z_ `Ix` a `Ix` b `Ix` c +{-# COMPLETE I3 #-} + +pattern I4 + :: (Elt a, Elt b, Elt c, Elt d) + => Exp a -> Exp b -> Exp c -> Exp d + -> Exp (Z :. a :. b :. c :. d) +pattern I4 a b c d = Z_ `Ix` a `Ix` b `Ix` c `Ix` d +{-# COMPLETE I4 #-} + +pattern I5 + :: (Elt a, Elt b, Elt c, Elt d, Elt e) + => Exp a -> Exp b -> Exp c -> Exp d -> Exp e + -> Exp (Z :. a :. b :. c :. d :. e) +pattern I5 a b c d e = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e +{-# COMPLETE I5 #-} + +pattern I6 + :: (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 (Z :. a :. b :. c :. d :. e :. f) +pattern I6 a b c d e f = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e `Ix` f +{-# COMPLETE I6 #-} + +pattern I7 + :: (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 (Z :. a :. b :. c :. d :. e :. f :. g) +pattern I7 a b c d e f g = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e `Ix` f `Ix` g +{-# COMPLETE I7 #-} + +pattern I8 + :: (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 (Z :. a :. b :. c :. d :. e :. f :. g :. h) +pattern I8 a b c d e f g h = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e `Ix` f `Ix` g `Ix` h +{-# COMPLETE I8 #-} + +pattern I9 + :: (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 (Z :. a :. b :. c :. d :. e :. f :. g :. h :. i) +pattern I9 a b c d e f g h i = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e `Ix` f `Ix` g `Ix` h `Ix` i +{-# COMPLETE I9 #-} + + -- | Specialised pattern synonyms for tuples, which may be more convenient to -- use than 'Data.Array.Accelerate.Lift.lift' and -- 'Data.Array.Accelerate.Lift.unlift'. For example, to construct a pair: @@ -173,6 +253,16 @@ pattern T16 a b c d e f g h i j k l m n o p = Pattern (a, b, c, d, e, f, g, h, i {-# COMPLETE T16 :: Exp #-} {-# COMPLETE T16 :: Acc #-} +-- IsPattern instances for Shape nil and cons +-- +instance IsPattern Exp Z Z where + construct _ = Exp IndexNil + destruct _ = Z + +instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where + construct (a :. b) = Exp (a `IndexCons` b) + destruct t = Exp (IndexTail t) :. Exp (IndexHead t) + -- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of the -- (unremarkable) boilerplate for us, but since the implementation is a little -- tricky it is debatable whether or not this is a good idea... @@ -201,12 +291,14 @@ $(runQ $ do destruct _x = $(tupE (map (get [|_x|]) [(n-1), (n-2) .. 0])) |] - mkAccPatern = mkIsPattern (mkName "Acc") [t| Arrays |] [| Atuple |] [| Aprj |] [| NilAtup |] [| SnocAtup |] - mkExpPatern = mkIsPattern (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] + -- mkShapePattern :: Name -> + + mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [| Atuple |] [| Aprj |] [| NilAtup |] [| SnocAtup |] + mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] -- -- - as <- mapM mkAccPatern [0..16] - es <- mapM mkExpPatern [0..16] + as <- mapM mkAccPattern [0..16] + es <- mapM mkExpPattern [0..16] return (concat as ++ concat es) ) From 48f2e367f4a3fca7adb5d5b2f8f4f3466852f899 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 26 Apr 2019 18:58:50 +0200 Subject: [PATCH 022/316] wibble --- src/Data/Array/Accelerate/Pattern.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 5f2de4678..c97180b13 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -291,8 +291,6 @@ $(runQ $ do destruct _x = $(tupE (map (get [|_x|]) [(n-1), (n-2) .. 0])) |] - -- mkShapePattern :: Name -> - mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [| Atuple |] [| Aprj |] [| NilAtup |] [| SnocAtup |] mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] -- From feaa9b8240034b3b9c8a3ac3b8ceee391fe5d68f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 30 Apr 2019 16:59:11 +0200 Subject: [PATCH 023/316] typo --- src/Data/Array/Accelerate/Classes/ToFloating.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Classes/ToFloating.hs b/src/Data/Array/Accelerate/Classes/ToFloating.hs index 9f6ea8fa7..bcba995e4 100644 --- a/src/Data/Array/Accelerate/Classes/ToFloating.hs +++ b/src/Data/Array/Accelerate/Classes/ToFloating.hs @@ -34,7 +34,7 @@ import Prelude hiding ( Num -- | 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. +-- coercion between two types. -- class ToFloating a b where -- | General coercion to floating types From 5c173791c4daaed870284dfe58fe242e11115aab Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 4 May 2019 10:25:35 +0200 Subject: [PATCH 024/316] add link to nofib build times problem --- accelerate.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/accelerate.cabal b/accelerate.cabal index d5db25ba7..2ddf149c3 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -254,6 +254,7 @@ Flag internal-checks Default: False -- Enabling this drastically increases build times +-- See: https://gitlab.haskell.org/ghc/ghc/issues/15751 Flag nofib Default: False Description: Build the nofib test suite (required for backend testing) From 6b8b1c028ba95d5f4adf9843ce460c8b292743bb Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 10 May 2019 13:39:46 +0200 Subject: [PATCH 025/316] stack: update to ghc-8.6.5 --- .travis.yml | 4 ++-- stack-8.6.yaml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 7a7469e49..b70cb1608 100644 --- a/.travis.yml +++ b/.travis.yml @@ -27,10 +27,10 @@ addons: matrix: fast_finish: true include: - - env: GHC=8.6.4 + - env: GHC=8.6.5 compiler: "GHC 8.6" - - env: GHC=8.4.3 + - env: GHC=8.4.4 compiler: "GHC 8.4" - env: GHC=8.2.2 diff --git a/stack-8.6.yaml b/stack-8.6.yaml index 493a18a93..46881ab93 100644 --- a/stack-8.6.yaml +++ b/stack-8.6.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-13.12 +resolver: lts-13.20 packages: - . From ddfa7f9215fd5c188be1200b293d5947fd087f66 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 10 May 2019 13:57:18 +0200 Subject: [PATCH 026/316] add pattern synonynm (::.) --- src/Data/Array/Accelerate.hs | 2 +- src/Data/Array/Accelerate/Pattern.hs | 9 +++++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 347b2b8ab..7a3cf5f01 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -333,7 +333,7 @@ module Data.Array.Accelerate ( pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, - pattern Z_, pattern Ix, + pattern Z_, pattern Ix, pattern (::.), pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index c97180b13..e6f1f1cec 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -26,7 +26,7 @@ module Data.Array.Accelerate.Pattern ( pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, - pattern Z_, pattern Ix, + pattern Z_, pattern Ix, pattern (::.), pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, @@ -59,8 +59,13 @@ pattern Z_ :: Exp DIM0 pattern Z_ = Pattern Z {-# COMPLETE Z_ #-} +infixl 3 ::. +pattern (::.) :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) +pattern a ::. b = Pattern (a :. b) +{-# COMPLETE (::.) #-} + pattern Ix :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) -pattern a `Ix` b = Pattern (a :. b) +pattern a `Ix` b = a ::. b {-# COMPLETE Ix #-} pattern I0 :: Exp DIM0 From cbb8c4720d9512ff6347c370392e3d48e90fed1d Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 May 2019 11:09:39 +0200 Subject: [PATCH 027/316] =?UTF-8?q?don=E2=80=99t=20export=20these=20intern?= =?UTF-8?q?al=20type=20constraints?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit These should not be necessary from user code anymore, but can still be accessed by importing D.A.A.Type module directly. --- src/Data/Array/Accelerate.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 7a3cf5f01..2f3b6f37f 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -402,9 +402,6 @@ module Data.Array.Accelerate ( 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 From 39fbe3a9731109ebd072b9ba9036da035a19f3a5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 21 May 2019 18:34:02 +0200 Subject: [PATCH 028/316] documentation wibble --- cbits/flags.c | 2 -- cbits/flags_debug.c | 2 ++ 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cbits/flags.c b/cbits/flags.c index 41aeda68d..eb0c37e00 100644 --- a/cbits/flags.c +++ b/cbits/flags.c @@ -15,8 +15,6 @@ * 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 */ #include diff --git a/cbits/flags_debug.c b/cbits/flags_debug.c index 7598b3475..8a551900c 100644 --- a/cbits/flags_debug.c +++ b/cbits/flags_debug.c @@ -6,6 +6,8 @@ * Maintainer : Trevor L. McDonell * Stability : experimental * Portability : non-portable (GHC extensions) + * + * This is a hack to (try to) work around */ #define ACCELERATE_DEBUG From fa34cad59d68a8d4f61cd3e1fbd5c04c9c9c7915 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 21 May 2019 19:46:17 +0200 Subject: [PATCH 029/316] use a bitfield to store debug flags --- cbits/flags.c | 129 ++++++++++++----------- cbits/flags.h | 43 ++++++++ cbits/monitoring.c | 7 +- src/Data/Array/Accelerate/Debug/Flags.hs | 75 +++++++------ 4 files changed, 155 insertions(+), 99 deletions(-) create mode 100644 cbits/flags.h diff --git a/cbits/flags.c b/cbits/flags.c index eb0c37e00..e89057e7c 100644 --- a/cbits/flags.c +++ b/cbits/flags.c @@ -25,77 +25,70 @@ #include #include +#include "flags.h" +#include "HsFFI.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; + +__flags_t __cmd_line_flags = { 0b111111 }; +HsInt __unfolding_use_threshold = 1; + #if defined(ACCELERATE_DEBUG) +enum { + OPT_ENABLE = 1, + OPT_DISABLE, + OPT_UNFOLDING_USE_THRESHOLD +}; + +/* NOTE: [adding new command line options] + * + * When adding new options, make sure the offset value in the OPT_DISABLE branch + * is updated, and that the flags are kept in order. + */ 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 } + { { "fseq-sharing", no_argument, NULL, OPT_ENABLE } + , { "facc-sharing", no_argument, NULL, OPT_ENABLE } + , { "fexp-sharing", no_argument, NULL, OPT_ENABLE } + , { "ffusion", no_argument, NULL, OPT_ENABLE } + , { "fsimplify", no_argument, NULL, OPT_ENABLE } + , { "ffast-math", no_argument, NULL, OPT_ENABLE } + , { "fflush-cache", no_argument, NULL, OPT_ENABLE } + , { "fforce-recomp", no_argument, NULL, OPT_ENABLE } + + , { "ddebug", no_argument, NULL, OPT_ENABLE } + , { "dverbose", no_argument, NULL, OPT_ENABLE } + , { "ddump-phases", no_argument, NULL, OPT_ENABLE } + , { "ddump-sharing", no_argument, NULL, OPT_ENABLE } + , { "ddump-fusion", no_argument, NULL, OPT_ENABLE } + , { "ddump-simpl-stats", no_argument, NULL, OPT_ENABLE } + , { "ddump-simpl-iterations", no_argument, NULL, OPT_ENABLE } + , { "ddump-vectorisation", no_argument, NULL, OPT_ENABLE } + , { "ddump-dot", no_argument, NULL, OPT_ENABLE } + , { "ddump-simpl-dot", no_argument, NULL, OPT_ENABLE } + , { "ddump-gc", no_argument, NULL, OPT_ENABLE } + , { "ddump-gc-stats", no_argument, NULL, OPT_ENABLE } + , { "ddump-cc", no_argument, NULL, OPT_ENABLE } + , { "ddump-ld", no_argument, NULL, OPT_ENABLE } + , { "ddump-asm", no_argument, NULL, OPT_ENABLE } + , { "ddump-exec", no_argument, NULL, OPT_ENABLE } + , { "ddump-sched", no_argument, NULL, OPT_ENABLE } + + , { "fno-seq-sharing", no_argument, NULL, OPT_DISABLE } + , { "fno-acc-sharing", no_argument, NULL, OPT_DISABLE } + , { "fno-exp-sharing", no_argument, NULL, OPT_DISABLE } + , { "fno-fusion", no_argument, NULL, OPT_DISABLE } + , { "fno-simplify", no_argument, NULL, OPT_DISABLE } + , { "fno-fast-math", no_argument, NULL, OPT_DISABLE } + , { "fno-flush-cache", no_argument, NULL, OPT_DISABLE } + , { "fno-force-recomp", no_argument, NULL, OPT_DISABLE } + + , { "funfolding-use-threshold=INT", required_argument, NULL, OPT_UNFOLDING_USE_THRESHOLD } /* required sentinel */ , { NULL, 0, NULL, 0 } @@ -127,9 +120,17 @@ static void parse_options(int argc, char *argv[]) case 0: break; + case OPT_ENABLE: + __cmd_line_flags.bitfield |= 1 << longindex; + break; + + case OPT_DISABLE: + __cmd_line_flags.bitfield &= ~(1 << (longindex - 25)); // SEE: [adding new command line options] + break; + /* attempt to decode the argument to flags which require them */ - case 1000: - if (1 != sscanf(optarg, "%d", &__unfolding_use_threshold)) { + case OPT_UNFOLDING_USE_THRESHOLD: + if (1 != sscanf(optarg, "%lld", &__unfolding_use_threshold)) { fprintf(stderr, "%s: option `-%s' requires an integer argument, but got: %s\n" , basename(argv[0]) , longopts[longindex].name diff --git a/cbits/flags.h b/cbits/flags.h new file mode 100644 index 000000000..9ab50c879 --- /dev/null +++ b/cbits/flags.h @@ -0,0 +1,43 @@ +/* + * Module : Data.Array.Accelerate.Debug.Flags + * Copyright : [2017..2019] The Accelerate Team + * License : BSD3 + * + * Maintainer : Trevor L. McDonell + * Stability : experimental + * Portability : non-portable (GHC extensions) + */ + +typedef union { + uint32_t bitfield; + + struct { + uint32_t seq_sharing : 1; + uint32_t acc_sharing : 1; + uint32_t exp_sharing : 1; + uint32_t fusion : 1; + uint32_t simplify : 1; + uint32_t fast_math : 1; + uint32_t flush_cache : 1; + uint32_t force_recomp : 1; + + uint32_t debug : 1; + uint32_t verbose : 1; + uint32_t dump_phases : 1; + uint32_t dump_sharing : 1; + uint32_t dump_fusion : 1; + uint32_t dump_simpl_stats : 1; + uint32_t dump_simpl_iterations : 1; + uint32_t dump_vectorisation : 1; + uint32_t dump_dot : 1; + uint32_t dump_simpl_dot : 1; + uint32_t dump_gc : 1; + uint32_t dump_gc_stats : 1; + uint32_t dump_cc : 1; + uint32_t dump_ld : 1; + uint32_t dump_asm : 1; + uint32_t dump_exec : 1; + uint32_t dump_sched : 1; + }; +} __flags_t; + diff --git a/cbits/monitoring.c b/cbits/monitoring.c index e4937ed72..57cdbe2d8 100644 --- a/cbits/monitoring.c +++ b/cbits/monitoring.c @@ -15,6 +15,8 @@ #include #include +#include "flags.h" + /* These monitoring counters are globals which will be accessed from the * Haskell side. @@ -33,8 +35,7 @@ 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; +extern __flags_t __cmd_line_flags; #if defined(ACCELERATE_DEBUG) @@ -117,7 +118,7 @@ static char* format_int64(char *buffer, int64_t x) */ __attribute__((destructor)) void dump_gc_stats(void) { - if (__dump_gc_stats) { + if (__cmd_line_flags.dump_gc_stats) { /* * int64 ranges from -9223372036854775807..9223372036854775807, so we need a * buffer size of at least 27 characters (including the terminating \0) to diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index 4fbaaa790..d6296b775 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} #endif @@ -25,7 +26,7 @@ module Data.Array.Accelerate.Debug.Flags ( setValue, Flag, - acc_sharing, exp_sharing, fusion, simplify, flush_cache, force_recomp, + acc_sharing, exp_sharing, array_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, @@ -41,14 +42,16 @@ module Data.Array.Accelerate.Debug.Flags ( ) where +import Data.Bits import Data.Int +import Data.Word 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 Flag = Flag Int -- can switch to an Enum now if we wished newtype Value = Value (Ptr Int32) @@ -98,21 +101,27 @@ getValue _ = notEnabled getFlag :: Flag -> IO Bool #ifdef ACCELERATE_DEBUG -getFlag (Flag f) = toBool `fmap` peek f +getFlag (Flag i) = do + flags <- peek cmd_line_flags + return $! testBit flags i #else getFlag _ = notEnabled #endif setFlag :: Flag -> IO () #ifdef ACCELERATE_DEBUG -setFlag (Flag f) = poke f (fromBool True) +setFlag (Flag i) = do + flags <- peek cmd_line_flags + poke cmd_line_flags (setBit flags i) #else setFlag _ = notEnabled #endif clearFlag :: Flag -> IO () #ifdef ACCELERATE_DEBUG -clearFlag (Flag f) = poke f (fromBool False) +clearFlag (Flag i) = do + flags <- peek cmd_line_flags + poke cmd_line_flags (clearBit flags i) #else clearFlag _ = notEnabled #endif @@ -135,9 +144,10 @@ 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. +-- cbits/flags.c as a bitfield and initialised at program initialisation. +-- +foreign import ccall "&__cmd_line_flags" cmd_line_flags :: Ptr Word32 -- These @-f=INT@ values are used by the compiler -- @@ -145,31 +155,32 @@ foreign import ccall "&__unfolding_use_threshold" unfolding_use_threshold :: Val -- These @-f@ flags can be reversed with @-fno-@ -- -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) +seq_sharing = Flag 0 -- ^ recover sharing of sequence expressions +acc_sharing = Flag 1 -- ^ recover sharing of array computations +exp_sharing = Flag 2 -- ^ recover sharing of scalar expressions +array_fusion = Flag 3 -- ^ fuse array expressions +simplify = Flag 4 -- ^ simplify scalar expressions +fast_math = Flag 5 -- ^ delete persistent compilation cache(s) +flush_cache = Flag 6 -- ^ force recompilation of array programs +force_recomp = Flag 7 -- ^ use faster, less precise math library operations -- These debugging flags are disable by default and are enabled with @-d@ -- -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 +debug = Flag 8 -- ^ compile code with debugging symbols (-g) +verbose = Flag 9 -- ^ be very chatty +dump_phases = Flag 10 -- ^ print information about each phase of the compiler +dump_sharing = Flag 11 -- ^ sharing recovery phase +dump_fusion = Flag 12 -- ^ array fusion phase +dump_simpl_stats = Flag 13 -- ^ statistics form fusion/simplification +dump_simpl_iterations = Flag 14 -- ^ output from each simplifier iteration +dump_vectorisation = Flag 15 -- ^ output from the vectoriser +dump_dot = Flag 16 -- ^ generate dot output of the program +dump_simpl_dot = Flag 17 -- ^ generate simplified dot output +dump_gc = Flag 18 -- ^ trace garbage collector +dump_gc_stats = Flag 19 -- ^ print final GC statistics +dump_cc = Flag 20 -- ^ trace code generation & compilation +dump_ld = Flag 21 -- ^ trace runtime linker +dump_asm = Flag 22 -- ^ trace assembler +dump_exec = Flag 23 -- ^ trace execution +dump_sched = Flag 24 -- ^ trace scheduler From 9de97098317196043f4c976c296bf9769dc7d1fa Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 22 May 2019 09:51:24 +0200 Subject: [PATCH 030/316] cabal: update extra-source-files --- accelerate.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/accelerate.cabal b/accelerate.cabal index 2ddf149c3..3f9963549 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -123,6 +123,8 @@ Stability: Experimental Extra-source-files: README.md CHANGELOG.md + cbits/*.c + cbits/*.h Extra-doc-files: images/*.png From f3d9a3980f89332419f89d09462a4fcb0e8c0106 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 22 May 2019 09:51:30 +0200 Subject: [PATCH 031/316] haddock fix --- src/Data/Array/Accelerate/Debug/Flags.hs | 50 ++++++++++++------------ 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index d6296b775..100da9a96 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -155,32 +155,32 @@ foreign import ccall "&__unfolding_use_threshold" unfolding_use_threshold :: Val -- These @-f@ flags can be reversed with @-fno-@ -- -seq_sharing = Flag 0 -- ^ recover sharing of sequence expressions -acc_sharing = Flag 1 -- ^ recover sharing of array computations -exp_sharing = Flag 2 -- ^ recover sharing of scalar expressions -array_fusion = Flag 3 -- ^ fuse array expressions -simplify = Flag 4 -- ^ simplify scalar expressions -fast_math = Flag 5 -- ^ delete persistent compilation cache(s) -flush_cache = Flag 6 -- ^ force recompilation of array programs -force_recomp = Flag 7 -- ^ use faster, less precise math library operations +seq_sharing = Flag 0 -- recover sharing of sequence expressions +acc_sharing = Flag 1 -- recover sharing of array computations +exp_sharing = Flag 2 -- recover sharing of scalar expressions +array_fusion = Flag 3 -- fuse array expressions +simplify = Flag 4 -- simplify scalar expressions +fast_math = Flag 5 -- delete persistent compilation cache(s) +flush_cache = Flag 6 -- force recompilation of array programs +force_recomp = Flag 7 -- use faster, less precise math library operations -- These debugging flags are disable by default and are enabled with @-d@ -- -debug = Flag 8 -- ^ compile code with debugging symbols (-g) -verbose = Flag 9 -- ^ be very chatty -dump_phases = Flag 10 -- ^ print information about each phase of the compiler -dump_sharing = Flag 11 -- ^ sharing recovery phase -dump_fusion = Flag 12 -- ^ array fusion phase -dump_simpl_stats = Flag 13 -- ^ statistics form fusion/simplification -dump_simpl_iterations = Flag 14 -- ^ output from each simplifier iteration -dump_vectorisation = Flag 15 -- ^ output from the vectoriser -dump_dot = Flag 16 -- ^ generate dot output of the program -dump_simpl_dot = Flag 17 -- ^ generate simplified dot output -dump_gc = Flag 18 -- ^ trace garbage collector -dump_gc_stats = Flag 19 -- ^ print final GC statistics -dump_cc = Flag 20 -- ^ trace code generation & compilation -dump_ld = Flag 21 -- ^ trace runtime linker -dump_asm = Flag 22 -- ^ trace assembler -dump_exec = Flag 23 -- ^ trace execution -dump_sched = Flag 24 -- ^ trace scheduler +debug = Flag 8 -- compile code with debugging symbols (-g) +verbose = Flag 9 -- be very chatty +dump_phases = Flag 10 -- print information about each phase of the compiler +dump_sharing = Flag 11 -- sharing recovery phase +dump_fusion = Flag 12 -- array fusion phase +dump_simpl_stats = Flag 13 -- statistics form fusion/simplification +dump_simpl_iterations = Flag 14 -- output from each simplifier iteration +dump_vectorisation = Flag 15 -- output from the vectoriser +dump_dot = Flag 16 -- generate dot output of the program +dump_simpl_dot = Flag 17 -- generate simplified dot output +dump_gc = Flag 18 -- trace garbage collector +dump_gc_stats = Flag 19 -- print final GC statistics +dump_cc = Flag 20 -- trace code generation & compilation +dump_ld = Flag 21 -- trace runtime linker +dump_asm = Flag 22 -- trace assembler +dump_exec = Flag 23 -- trace execution +dump_sched = Flag 24 -- trace scheduler From 839c0b67b9ac661b4b34ea975f8dcbdd2a19e68c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 22 May 2019 13:15:41 +0200 Subject: [PATCH 032/316] nofib: add test for AccelerateHS/accelerate#364 --- accelerate.cabal | 1 + .../Array/Accelerate/Test/NoFib/Issues.hs | 3 + .../Accelerate/Test/NoFib/Issues/Issue364.hs | 97 +++++++++++++++++++ 3 files changed, 101 insertions(+) create mode 100644 src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs diff --git a/accelerate.cabal b/accelerate.cabal index 3f9963549..0ee643579 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -430,6 +430,7 @@ Library 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.Issue364 Data.Array.Accelerate.Test.NoFib.Issues.Issue407 Data.Array.Accelerate.Test.NoFib.Issues.Issue409 else diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs index 39fa060ec..3a5e05730 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs @@ -30,6 +30,7 @@ module Data.Array.Accelerate.Test.NoFib.Issues ( 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.Issue364, module Data.Array.Accelerate.Test.NoFib.Issues.Issue407, module Data.Array.Accelerate.Test.NoFib.Issues.Issue409, @@ -55,6 +56,7 @@ import Data.Array.Accelerate.Test.NoFib.Issues.Issue264 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.Issue364 import Data.Array.Accelerate.Test.NoFib.Issues.Issue407 import Data.Array.Accelerate.Test.NoFib.Issues.Issue409 @@ -79,6 +81,7 @@ test_issues runN = , test_issue287 runN , test_issue288 runN , test_issue362 runN + , test_issue364 runN , test_issue407 runN , test_issue409 runN ] diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs new file mode 100644 index 000000000..928ad1e66 --- /dev/null +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue364 +-- Copyright : [2009..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Test.NoFib.Issues.Issue364 ( + + test_issue364 + +) where + +import Data.Typeable +import Prelude ( fromInteger, show ) +import qualified Prelude as P + +import Data.Array.Accelerate hiding ( fromInteger ) +import Data.Array.Accelerate.Array.Sugar as Sugar +import Data.Array.Accelerate.Test.NoFib.Base +import Data.Array.Accelerate.Test.NoFib.Config + +import Hedgehog + +import Test.Tasty +import Test.Tasty.HUnit + + +test_issue364 :: RunN -> TestTree +test_issue364 runN = + testGroup "issue364" + [ at @TestInt8 $ testElt i8 + , at @TestInt16 $ testElt i16 + , at @TestInt32 $ testElt i32 + , at @TestInt64 $ testElt i64 + -- , at @TestHalf $ testElt f16 + , at @TestFloat $ testElt f32 + , at @TestDouble $ testElt f64 + ] + where + testElt :: forall e. (Num e, Eq e, P.Num e, P.Enum e, P.Eq e) + => Gen e + -> TestTree + testElt _ = + testGroup (show (typeOf (undefined :: e))) + [ testCase "A" $ expectedArray @_ @e Z 64 @=? runN (scanl iappend one) (intervalArray Z 64) + , testCase "B" $ expectedArray @_ @e Z 65 @=? runN (scanl iappend one) (intervalArray Z 65) -- failed for integral types + ] + + +-- interval of summations monoid +-- +one,top :: Num e => Exp (e, e) +one = T2 (-1) (-1) +top = T2 (-2) (-2) + +iappend :: (Num e, Eq e) => Exp (e,e) -> Exp (e,e) -> Exp (e,e) +iappend x y = + if x == one then y else + if y == one then x else + if x == top || y == top then top + else + let T2 x1 x2 = x + T2 y1 y2 = y + in + if x2 + 1 == y1 + then T2 x1 y2 + else top + +intervalArray :: (Shape sh, Elt e, P.Num e, P.Enum e) + => sh + -> Int + -> Array (sh:.Int) (e,e) +intervalArray sh n + = fromList (sh:.n) + . P.concat + $ P.replicate (Sugar.size sh) [ (i,i) | i <- [0.. (P.fromIntegral n-1)] ] + +expectedArray :: (Shape sh, Elt e, P.Num e, P.Enum e) + => sh + -> Int + -> Array (sh:.Int) (e,e) +expectedArray sh n + = fromList (sh:.n+1) + $ P.concat + $ P.replicate (Sugar.size sh) $ (-1,-1) : [ (0,i) | i <- [0 .. P.fromIntegral n - 1] ] + From 8f39f46f85705f69ee7ad757694eabd4e87a7403 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 22 May 2019 14:50:59 +0200 Subject: [PATCH 033/316] nofib: add test for AccelerateHS/accelerate#436 --- accelerate.cabal | 2 + .../Array/Accelerate/Test/NoFib/Issues.hs | 2 + .../Accelerate/Test/NoFib/Issues/Issue436.hs | 57 +++++++++++++++++++ 3 files changed, 61 insertions(+) create mode 100644 src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs diff --git a/accelerate.cabal b/accelerate.cabal index 0ee643579..bbfb27d12 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -433,6 +433,8 @@ Library Data.Array.Accelerate.Test.NoFib.Issues.Issue364 Data.Array.Accelerate.Test.NoFib.Issues.Issue407 Data.Array.Accelerate.Test.NoFib.Issues.Issue409 + Data.Array.Accelerate.Test.NoFib.Issues.Issue436 + else cpp-options: -DACCELERATE_DISABLE_NOFIB diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs index 3a5e05730..87b980626 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs @@ -59,6 +59,7 @@ import Data.Array.Accelerate.Test.NoFib.Issues.Issue362 import Data.Array.Accelerate.Test.NoFib.Issues.Issue364 import Data.Array.Accelerate.Test.NoFib.Issues.Issue407 import Data.Array.Accelerate.Test.NoFib.Issues.Issue409 +import Data.Array.Accelerate.Test.NoFib.Issues.Issue436 test_issues :: RunN -> TestTree @@ -84,5 +85,6 @@ test_issues runN = , test_issue364 runN , test_issue407 runN , test_issue409 runN + , test_issue436 runN ] diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs new file mode 100644 index 000000000..abb018390 --- /dev/null +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue436 +-- Copyright : [2009..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Test.NoFib.Issues.Issue436 ( + + test_issue436 + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Test.NoFib.Base + +import Test.Tasty +import Test.Tasty.HUnit + + +test_issue436 :: RunN -> TestTree +test_issue436 runN = + testGroup "436" + [ testCase "A" $ e1 @=? runN t1 + , testCase "B" $ e2 @=? runN t2 + ] + + +t1 :: Acc (Vector Bool, Scalar Int) +t1 = test 3 (bools (Z :. 5)) + +e1 :: (Vector Bool, Scalar Int) +e1 = ( fromList (Z :. 3) [True,False,True] + , fromList Z [3]) + +t2 :: Acc (Vector Bool, Vector Int) +t2 = test 3 (bools (Z :. 5 :. 5)) + +e2 :: (Vector Bool, Vector Int) +e2 = ( fromList (Z :. 15) [True,False,True,False,True,False,True,False,True,False,True,False,True,False,True] + , fromList (Z :. 5) [3,3,3,3,3] + ) + +test :: (Shape sh, Elt e) + => Int + -> Acc (Array (sh:.Int) e) + -> Acc (Vector e, Array sh Int) +test n xs = A.filter (const (constant True)) (A.take (constant n) xs) + +bools :: Shape sh => sh -> Acc (Array sh Bool) +bools sh = use $ fromList sh (cycle [True, False]) + From d5265637bd7f75f5e9948f72ae43dc6f8eb297b3 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 22 May 2019 15:04:22 +0200 Subject: [PATCH 034/316] update file header --- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs | 2 ++ src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs | 2 ++ 2 files changed, 4 insertions(+) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs index 928ad1e66..0c02f8694 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs @@ -14,6 +14,8 @@ -- Stability : experimental -- Portability : non-portable (GHC extensions) -- +-- https://github.com/AccelerateHS/accelerate/issues/364 +-- module Data.Array.Accelerate.Test.NoFib.Issues.Issue364 ( diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs index abb018390..bf028b8e2 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs @@ -9,6 +9,8 @@ -- Stability : experimental -- Portability : non-portable (GHC extensions) -- +-- https://github.com/AccelerateHS/accelerate/issues/436 +-- module Data.Array.Accelerate.Test.NoFib.Issues.Issue436 ( From 5f2c082c993a3ed4b814b2402bdeed96228c536f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 23 May 2019 10:17:51 +0200 Subject: [PATCH 035/316] build fix for ghc-8.0 --- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs index 0c02f8694..e2481c69f 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -26,6 +27,9 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue364 ( import Data.Typeable import Prelude ( fromInteger, show ) import qualified Prelude as P +#if __GLASGOW_HASKELL__ == 800 +import Prelude ( fail ) +#endif import Data.Array.Accelerate hiding ( fromInteger ) import Data.Array.Accelerate.Array.Sugar as Sugar From cd0256a6de552edbc6d2431c7c87c07a9e857645 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 28 May 2019 18:32:46 +0200 Subject: [PATCH 036/316] #once --- cbits/flags.h | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/cbits/flags.h b/cbits/flags.h index 9ab50c879..820a3aafa 100644 --- a/cbits/flags.h +++ b/cbits/flags.h @@ -8,6 +8,9 @@ * Portability : non-portable (GHC extensions) */ +#ifndef __ACCELERATE_FLAGS_H__ +#define __ACCELERATE_FLAGS_H__ + typedef union { uint32_t bitfield; @@ -41,3 +44,5 @@ typedef union { }; } __flags_t; +#endif // __ACCELERATE_FLAGS_H__ + From 4248bc5ec1fcd53f4112c3045d164a7df82ad6d2 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 28 May 2019 18:33:00 +0200 Subject: [PATCH 037/316] drop unused function --- src/Data/Array/Accelerate/Debug/Flags.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index 100da9a96..ecb70081e 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -136,13 +136,6 @@ 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 as a bitfield and initialised at program initialisation. From 7d6c5bf587b90124830fb021073fea7074f5ca91 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 29 May 2019 11:51:56 +0200 Subject: [PATCH 038/316] add module for simple bit sets --- accelerate.cabal | 3 +- src/Data/BitSet.hs | 160 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 162 insertions(+), 1 deletion(-) create mode 100644 src/Data/BitSet.hs diff --git a/accelerate.cabal b/accelerate.cabal index bbfb27d12..37ed6fb2e 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -338,7 +338,6 @@ Library Data.Array.Accelerate.Test.Similar Other-modules: - Data.Atomic Data.Array.Accelerate.Analysis.Hash.TH Data.Array.Accelerate.Array.Remote.Nursery Data.Array.Accelerate.Classes @@ -378,6 +377,8 @@ Library Data.Array.Accelerate.Trafo.Shrink Data.Array.Accelerate.Trafo.Simplify Data.Array.Accelerate.Trafo.Substitution + Data.Atomic + Data.BitSet -- Data.Array.Accelerate.Array.Lifted -- Data.Array.Accelerate.Trafo.Vectorise diff --git a/src/Data/BitSet.hs b/src/Data/BitSet.hs new file mode 100644 index 000000000..2f4858d37 --- /dev/null +++ b/src/Data/BitSet.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Data.BitSet +-- Copyright : [2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.BitSet where + +import Data.Bits +import Prelude hiding ( foldl, foldr ) +import qualified Data.List as List + +import GHC.Exts ( IsList, build ) +import qualified GHC.Exts as Exts + + +-- | A space-efficient implementation of a set data structure for +-- enumerated data types. +-- +newtype BitSet c a = BitSet { getBits :: c } + deriving Eq + +instance (Enum a, Show a, Bits c, Num c) => Show (BitSet c a) where + showsPrec p bs + = showParen (p > 10) + $ showString "fromList " . shows (toList bs) + +instance (Enum a, Bits c) => Semigroup (BitSet c a) where + (<>) = union + +instance (Enum a, Bits c, Num c) => Monoid (BitSet c a) where + mempty = empty + +instance (Enum a, Bits c, Num c) => IsList (BitSet c a) where + type Item (BitSet c a) = a + fromList = fromList + toList = toList + {-# INLINE fromList #-} + {-# INLINE toList #-} + +-- | Is the bit set empty? +-- +{-# INLINE null #-} +null :: (Eq c, Num c) => BitSet c a -> Bool +null (BitSet bits) = bits == 0 + +-- | The number of elements in the bit set. +-- +{-# INLINE size #-} +size :: Bits c => BitSet c a -> Int +size (BitSet bits) = popCount bits + +-- | Ask whether the item is in the bit set. +-- +{-# INLINE member #-} +member :: (Enum a , Bits c) => a -> BitSet c a -> Bool +member x (BitSet bits) = bits `testBit` fromEnum x + +-- | The empty bit set. +-- +{-# INLINE empty #-} +empty :: (Enum a, Bits c, Num c) => BitSet c a +empty = BitSet 0 + +-- | Create a singleton set. +-- +{-# INLINE singleton #-} +singleton :: (Enum a, Bits c, Num c) => a -> BitSet c a +singleton x = BitSet $! bit (fromEnum x) + +-- | Insert an item into the bit set. +-- +{-# INLINE insert #-} +insert :: (Enum a, Bits c) => a -> BitSet c a -> BitSet c a +insert x (BitSet bits) = BitSet $! bits `setBit` fromEnum x + +-- | Delete an item from the bit set. +{-# INLINE delete #-} +delete :: (Enum a, Bits c) => a -> BitSet c a -> BitSet c a +delete x (BitSet bits ) = BitSet $! bits `clearBit` fromEnum x + +-- | The union of two bit sets. +-- +{-# INLINE union #-} +union :: Bits c => BitSet c a -> BitSet c a -> BitSet c a +union (BitSet bits1) (BitSet bits2) = BitSet $! bits1 .|. bits2 + +-- | Difference of two bit sets. +-- +{-# INLINE difference #-} +difference :: Bits c => BitSet c a -> BitSet c a -> BitSet c a +difference (BitSet bits1) (BitSet bits2) = BitSet $! bits1 .&. complement bits2 + +-- | See 'difference'. +infix 5 \\ +{-# INLINE (\\) #-} +(\\) :: Bits c => BitSet c a -> BitSet c a -> BitSet c a +(\\) = difference + +-- | The intersection of two bit sets. +-- +{-# INLINE intersection #-} +intersection :: Bits c => BitSet c a -> BitSet c a -> BitSet c a +intersection (BitSet bits1) (BitSet bits2) = BitSet $! bits1 .&. bits2 + +-- | Transform this bit set by applying a function to every value. +-- Resulting bit set may be smaller then the original. +-- +{-# INLINE map #-} +map :: (Enum a, Enum b, Bits c, Num c) => (a -> b) -> BitSet c a -> BitSet c b +map f = foldl' (\bs a -> f a `insert` bs) empty + +-- | Reduce this bit set by applying a binary function to all elements, +-- using the given starting value. Each application of the operator is +-- evaluated before before using the result in the next application. This +-- function is strict in the starting value. +-- +{-# INLINE foldl' #-} +foldl' :: (Enum a, Bits c) => (b -> a -> b) -> b -> BitSet c a -> b +foldl' f z (BitSet bits) = go z (popCount bits) 0 + where + go !acc 0 !_ = acc + go !acc !n !b = if bits `testBit` b + then go (f acc $ toEnum b) (pred n) (succ b) + else go acc n (succ b) + +-- | Reduce this bit set by applying a binary function to all elements, +-- using the given starting value. +-- +{-# INLINE foldr #-} +foldr :: (Enum a, Bits c) => (a -> b -> b) -> b -> BitSet c a -> b +foldr f z (BitSet bits) = go (popCount bits) 0 + where + go 0 !_ = z + go !n !b = if bits `testBit` b + then toEnum b `f` go (pred n) (succ b) + else go n (succ b) + +-- | Convert this bit set set to a list of elements. +-- +{-# INLINE [0] toList #-} +toList :: (Enum a, Bits c, Num c) => BitSet c a -> [a] +toList bs = build (\k z -> foldr k z bs) + +-- | Make a bit set from a list of elements. +-- +{-# INLINE [0] fromList #-} +fromList :: (Enum a, Bits c, Num c) => [a] -> BitSet c a +fromList xs = BitSet $! List.foldl' (\i x -> i `setBit` fromEnum x) 0 xs + +{-# RULES +"fromList/toList" forall bs. fromList (toList bs) = bs + #-} + From 4c3cc28904ef4d132f97abe6932731695829e4ef Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 29 May 2019 14:55:17 +0200 Subject: [PATCH 039/316] add flag -fmax-simplifier-iterations=INT --- cbits/flags.c | 114 ++++++++++++----------- cbits/flags.h | 2 + cbits/monitoring.c | 2 +- src/Data/Array/Accelerate/Debug/Flags.hs | 54 ++++------- 4 files changed, 82 insertions(+), 90 deletions(-) diff --git a/cbits/flags.c b/cbits/flags.c index e89057e7c..4600fbdb5 100644 --- a/cbits/flags.c +++ b/cbits/flags.c @@ -33,69 +33,67 @@ * corresponding behaviour. */ -__flags_t __cmd_line_flags = { 0b111111 }; -HsInt __unfolding_use_threshold = 1; - - -#if defined(ACCELERATE_DEBUG) +__flags_t __cmd_line_flags = { 0x3f }; +HsInt __unfolding_use_threshold = 1; +HsInt __max_simplifier_iterations = 25; enum { OPT_ENABLE = 1, OPT_DISABLE, - OPT_UNFOLDING_USE_THRESHOLD + OPT_UNFOLDING_USE_THRESHOLD, + OPT_MAX_SIMPLIFIER_ITERATIONS }; -/* NOTE: [adding new command line options] +/* NOTE: [layout of command line options bitfield] * * When adding new options, make sure the offset value in the OPT_DISABLE branch * is updated, and that the flags are kept in order. */ static const char* shortopts = ""; static const struct option longopts[] = - { { "fseq-sharing", no_argument, NULL, OPT_ENABLE } - , { "facc-sharing", no_argument, NULL, OPT_ENABLE } - , { "fexp-sharing", no_argument, NULL, OPT_ENABLE } - , { "ffusion", no_argument, NULL, OPT_ENABLE } - , { "fsimplify", no_argument, NULL, OPT_ENABLE } - , { "ffast-math", no_argument, NULL, OPT_ENABLE } - , { "fflush-cache", no_argument, NULL, OPT_ENABLE } - , { "fforce-recomp", no_argument, NULL, OPT_ENABLE } - - , { "ddebug", no_argument, NULL, OPT_ENABLE } - , { "dverbose", no_argument, NULL, OPT_ENABLE } - , { "ddump-phases", no_argument, NULL, OPT_ENABLE } - , { "ddump-sharing", no_argument, NULL, OPT_ENABLE } - , { "ddump-fusion", no_argument, NULL, OPT_ENABLE } - , { "ddump-simpl-stats", no_argument, NULL, OPT_ENABLE } - , { "ddump-simpl-iterations", no_argument, NULL, OPT_ENABLE } - , { "ddump-vectorisation", no_argument, NULL, OPT_ENABLE } - , { "ddump-dot", no_argument, NULL, OPT_ENABLE } - , { "ddump-simpl-dot", no_argument, NULL, OPT_ENABLE } - , { "ddump-gc", no_argument, NULL, OPT_ENABLE } - , { "ddump-gc-stats", no_argument, NULL, OPT_ENABLE } - , { "ddump-cc", no_argument, NULL, OPT_ENABLE } - , { "ddump-ld", no_argument, NULL, OPT_ENABLE } - , { "ddump-asm", no_argument, NULL, OPT_ENABLE } - , { "ddump-exec", no_argument, NULL, OPT_ENABLE } - , { "ddump-sched", no_argument, NULL, OPT_ENABLE } - - , { "fno-seq-sharing", no_argument, NULL, OPT_DISABLE } - , { "fno-acc-sharing", no_argument, NULL, OPT_DISABLE } - , { "fno-exp-sharing", no_argument, NULL, OPT_DISABLE } - , { "fno-fusion", no_argument, NULL, OPT_DISABLE } - , { "fno-simplify", no_argument, NULL, OPT_DISABLE } - , { "fno-fast-math", no_argument, NULL, OPT_DISABLE } - , { "fno-flush-cache", no_argument, NULL, OPT_DISABLE } - , { "fno-force-recomp", no_argument, NULL, OPT_DISABLE } - - , { "funfolding-use-threshold=INT", required_argument, NULL, OPT_UNFOLDING_USE_THRESHOLD } + { { "fseq-sharing", no_argument, NULL, OPT_ENABLE } + , { "facc-sharing", no_argument, NULL, OPT_ENABLE } + , { "fexp-sharing", no_argument, NULL, OPT_ENABLE } + , { "ffusion", no_argument, NULL, OPT_ENABLE } + , { "fsimplify", no_argument, NULL, OPT_ENABLE } + , { "ffast-math", no_argument, NULL, OPT_ENABLE } + , { "fflush-cache", no_argument, NULL, OPT_ENABLE } + , { "fforce-recomp", no_argument, NULL, OPT_ENABLE } + + , { "ddebug", no_argument, NULL, OPT_ENABLE } + , { "dverbose", no_argument, NULL, OPT_ENABLE } + , { "ddump-phases", no_argument, NULL, OPT_ENABLE } + , { "ddump-sharing", no_argument, NULL, OPT_ENABLE } + , { "ddump-fusion", no_argument, NULL, OPT_ENABLE } + , { "ddump-simpl-stats", no_argument, NULL, OPT_ENABLE } + , { "ddump-simpl-iterations", no_argument, NULL, OPT_ENABLE } + , { "ddump-vectorisation", no_argument, NULL, OPT_ENABLE } + , { "ddump-dot", no_argument, NULL, OPT_ENABLE } + , { "ddump-simpl-dot", no_argument, NULL, OPT_ENABLE } + , { "ddump-gc", no_argument, NULL, OPT_ENABLE } + , { "ddump-gc-stats", no_argument, NULL, OPT_ENABLE } + , { "ddump-cc", no_argument, NULL, OPT_ENABLE } + , { "ddump-ld", no_argument, NULL, OPT_ENABLE } + , { "ddump-asm", no_argument, NULL, OPT_ENABLE } + , { "ddump-exec", no_argument, NULL, OPT_ENABLE } + , { "ddump-sched", no_argument, NULL, OPT_ENABLE } + + , { "fno-seq-sharing", no_argument, NULL, OPT_DISABLE } + , { "fno-acc-sharing", no_argument, NULL, OPT_DISABLE } + , { "fno-exp-sharing", no_argument, NULL, OPT_DISABLE } + , { "fno-fusion", no_argument, NULL, OPT_DISABLE } + , { "fno-simplify", no_argument, NULL, OPT_DISABLE } + , { "fno-fast-math", no_argument, NULL, OPT_DISABLE } + , { "fno-flush-cache", no_argument, NULL, OPT_DISABLE } + , { "fno-force-recomp", no_argument, NULL, OPT_DISABLE } + + , { "funfolding-use-threshold=INT", required_argument, NULL, OPT_UNFOLDING_USE_THRESHOLD } + , { "fmax-simplifier-iterations=INT", required_argument, NULL, OPT_MAX_SIMPLIFIER_ITERATIONS } /* 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 @@ -103,8 +101,6 @@ static const struct option longopts[] = */ static void parse_options(int argc, char *argv[]) { -#if defined(ACCELERATE_DEBUG) - const struct option* opt; char* this; int did_show_banner; @@ -125,7 +121,7 @@ static void parse_options(int argc, char *argv[]) break; case OPT_DISABLE: - __cmd_line_flags.bitfield &= ~(1 << (longindex - 25)); // SEE: [adding new command line options] + __cmd_line_flags.bitfield &= ~(1 << (longindex - 25)); // SEE: [layout of command line options bitfield] break; /* attempt to decode the argument to flags which require them */ @@ -139,6 +135,16 @@ static void parse_options(int argc, char *argv[]) } break; + case OPT_MAX_SIMPLIFIER_ITERATIONS: + if (1 != sscanf(optarg, "%lld", &__max_simplifier_iterations)) { + 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 @@ -185,11 +191,11 @@ static void parse_options(int argc, char *argv[]) } } -#else - - fprintf(stderr, "Data.Array.Accelerate: Debugging options are disabled.\n"); - fprintf(stderr, "Reinstall package 'accelerate' with '-fdebug' to enable them.\n"); - +#if !defined(ACCELERATE_DEBUG) + if (__cmd_line_flags.bitfield & 0x1ffff00) { // SEE: [layout of command line options bitfield] + fprintf(stderr, "Data.Array.Accelerate: Debugging options are disabled.\n"); + fprintf(stderr, "Reinstall package 'accelerate' with '-fdebug' to enable them.\n"); + } #endif } diff --git a/cbits/flags.h b/cbits/flags.h index 820a3aafa..0c6a41fe0 100644 --- a/cbits/flags.h +++ b/cbits/flags.h @@ -11,6 +11,8 @@ #ifndef __ACCELERATE_FLAGS_H__ #define __ACCELERATE_FLAGS_H__ +/* NOTE: [layout of command line options bitfield] + */ typedef union { uint32_t bitfield; diff --git a/cbits/monitoring.c b/cbits/monitoring.c index 57cdbe2d8..4edcb29f7 100644 --- a/cbits/monitoring.c +++ b/cbits/monitoring.c @@ -122,7 +122,7 @@ __attribute__((destructor)) void dump_gc_stats(void) /* * 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. + * format any number with commas. */ char buffer[96]; double timestamp = clock_gettime_elapsed_seconds(); diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index ecb70081e..c370f9e60 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -22,6 +22,7 @@ module Data.Array.Accelerate.Debug.Flags ( Value, unfolding_use_threshold, + max_simplifier_iterations, getValue, setValue, @@ -51,8 +52,8 @@ import Foreign.Storable import Control.Monad.IO.Class ( MonadIO, liftIO ) import qualified Control.Monad as M -newtype Flag = Flag Int -- can switch to an Enum now if we wished -newtype Value = Value (Ptr Int32) +newtype Flag = Flag Int -- can switch to an Enum now if we wished +newtype Value = Value (Ptr Int) -- of type HsInt in flags.c -- | Conditional execution of a monadic debugging expression. @@ -86,45 +87,25 @@ unless _ _ = return () setValue :: Value -> Int -> IO () -#ifdef ACCELERATE_DEBUG -setValue (Value f) v = poke f (fromIntegral v) -#else -setValue _ _ = notEnabled -#endif +setValue (Value f) v = poke f v getValue :: Value -> IO Int -#ifdef ACCELERATE_DEBUG -getValue (Value f) = fromIntegral `fmap` peek f -#else -getValue _ = notEnabled -#endif +getValue (Value f) = peek f getFlag :: Flag -> IO Bool -#ifdef ACCELERATE_DEBUG getFlag (Flag i) = do - flags <- peek cmd_line_flags + flags <- peek __cmd_line_flags return $! testBit flags i -#else -getFlag _ = notEnabled -#endif setFlag :: Flag -> IO () -#ifdef ACCELERATE_DEBUG setFlag (Flag i) = do - flags <- peek cmd_line_flags - poke cmd_line_flags (setBit flags i) -#else -setFlag _ = notEnabled -#endif + flags <- peek __cmd_line_flags + poke __cmd_line_flags (setBit flags i) clearFlag :: Flag -> IO () -#ifdef ACCELERATE_DEBUG clearFlag (Flag i) = do - flags <- peek cmd_line_flags - poke cmd_line_flags (clearBit flags i) -#else -clearFlag _ = notEnabled -#endif + flags <- peek __cmd_line_flags + poke __cmd_line_flags (clearBit flags i) setFlags :: [Flag] -> IO () setFlags = mapM_ setFlag @@ -132,19 +113,22 @@ 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." ] +-- notEnabled :: a +-- notEnabled = error $ unlines [ "Data.Array.Accelerate: Debugging options are disabled." +-- , "Reinstall package 'accelerate' with '-fdebug' to enable them." ] -- Import the underlying flag variables. These are defined in the file --- cbits/flags.c as a bitfield and initialised at program initialisation. +-- cbits/flags.h as a bitfield and initialised at program initialisation. +-- +-- SEE: [layout of command line options bitfield] -- -foreign import ccall "&__cmd_line_flags" cmd_line_flags :: Ptr Word32 +foreign import ccall "&__cmd_line_flags" __cmd_line_flags :: Ptr Word32 -- These @-f=INT@ values are used by the compiler -- -foreign import ccall "&__unfolding_use_threshold" unfolding_use_threshold :: Value -- the magic cut-off figure for inlining +foreign import ccall "&__unfolding_use_threshold" unfolding_use_threshold :: Value -- the magic cut-off figure for inlining +foreign import ccall "&__max_simplifier_iterations" max_simplifier_iterations :: Value -- maximum number of scalar simplification passes -- These @-f@ flags can be reversed with @-fno-@ -- From 4cf97cd4f3844187e6eb232d118c680123302267 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 29 May 2019 15:53:48 +0200 Subject: [PATCH 040/316] clean up options handling in Trafo.Sharing --- src/Data/Array/Accelerate/Trafo.hs | 12 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 198 ++++++++++----------- 2 files changed, 104 insertions(+), 106 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index f5c3f5696..825611cc6 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -137,7 +137,7 @@ 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) + $ phase "sharing-recovery" Sharing.convertAcc -- recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp) $ acc @@ -152,7 +152,7 @@ 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) + $ phase "sharing-recovery" Sharing.convertAfun -- recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp) $ acc @@ -161,8 +161,8 @@ convertAfunWith Phase{..} acc -- convertExp :: Elt e => Exp e -> AST.Exp () e convertExp - = phase "exp-simplify" Rewrite.simplify - . phase "sharing-recovery" (Sharing.convertExp (recoverExpSharing phases)) + = phase "exp-simplify" Rewrite.simplify + . phase "sharing-recovery" Sharing.convertExp -- (recoverExpSharing phases)) -- | Convert closed scalar functions, incorporating sharing observation and @@ -170,8 +170,8 @@ convertExp -- convertFun :: Function f => f -> AST.Fun () (FunctionR f) convertFun - = phase "exp-simplify" Rewrite.simplify - . phase "sharing-recovery" (Sharing.convertFun (recoverExpSharing phases)) + = phase "exp-simplify" Rewrite.simplify + . phase "sharing-recovery" Sharing.convertFun -- (recoverExpSharing phases)) {-- -- | Convert a closed sequence computation, incorporating sharing observation and diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 205e93471..62b1a1a67 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -1,8 +1,11 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -28,9 +31,16 @@ module Data.Array.Accelerate.Trafo.Sharing ( - -- * HOAS -> de Bruijn conversion - convertAcc, convertAfun, Afunction, AfunctionR, - convertExp, convertFun, Function, FunctionR, + -- * HOAS to de Bruijn conversion + convertAcc, convertAccWith, + + Afunction, AfunctionR, + convertAfun, convertAfunWith, + + Function, FunctionR, + convertExp, convertExpWith, + convertFun, convertFunWith, + -- convertSeq ) where @@ -38,12 +48,15 @@ module Data.Array.Accelerate.Trafo.Sharing ( -- standard library import Control.Applicative hiding ( Const ) import Control.Monad.Fix +import Data.Bits +import Data.Hashable import Data.List import Data.Maybe -import Data.Hashable import Data.Typeable -import System.Mem.StableName +import Data.Word +import Foreign.Storable import System.IO.Unsafe ( unsafePerformIO ) +import System.Mem.StableName import Text.Printf import qualified Data.HashTable.IO as Hash import qualified Data.IntMap as IntMap @@ -52,6 +65,9 @@ import qualified Data.HashSet as Set import Prelude -- friends +import Data.BitSet ( BitSet(..) ) +import qualified Data.BitSet as Options + import Data.Array.Accelerate.Error import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Array.Sugar as Sugar hiding ( (!!) ) @@ -67,16 +83,24 @@ import qualified Data.Array.Accelerate.Debug.Flags 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 ? - } +type Config = BitSet Word32 Option + +data Option + = RecoverSeqSharing -- ^ Recover sharing of sequence computations ? + | RecoverAccSharing -- ^ Recover sharing of array computations ? + | RecoverExpSharing -- ^ Recover sharing of scalar expressions ? + | FloatOutAcc -- ^ Always float array computations out of expressions ? + deriving (Show, Enum) + +defaultOptions :: Config +#if ACCELERATE_DEBUG +defaultOptions = unsafePerformIO $ do + v <- (0b111 .&.) <$> peek Debug.__cmd_line_flags -- SEE: [layout of command line options bitfield] + return $! Options.insert FloatOutAcc (BitSet v) +#else +defaultOptions = [RecoverAccSharing, RecoverExpSharing, RecoverSeqSharing, FloatOutAcc] +#endif + -- Layouts -- ------- @@ -86,9 +110,8 @@ data Config = Config -- 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) + 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. -- @@ -135,27 +158,21 @@ sizeLayout (PushLayout lyt _) = 1 + sizeLayout lyt -- | 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 +convertAcc :: Arrays arrs => Acc arrs -> AST.Acc arrs +convertAcc = convertAccWith defaultOptions + +convertAccWith :: Arrays arrs => Config -> Acc arrs -> AST.Acc arrs +convertAccWith config = convertOpenAcc config EmptyLayout -- | 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 +convertAfun :: Afunction f => f -> AST.Afun (AfunctionR f) +convertAfun = convertAfunWith defaultOptions + +convertAfunWith :: Afunction f => Config -> f -> AST.Afun (AfunctionR f) +convertAfunWith config = convertOpenAfun config EmptyLayout -- Convert a HOAS fragment into de Bruijn form, binding variables into the typed @@ -167,25 +184,18 @@ convertAfun shareAcc shareExp shareSeq floatAcc = -- class Afunction f where type AfunctionR f - aconvert :: Config -> Layout aenv aenv -> f -> AST.OpenAfun aenv (AfunctionR f) + convertOpenAfun :: 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) + convertOpenAfun config alyt f = + let a = Acc $ Atag (sizeLayout alyt) + alyt' = incLayout alyt `PushLayout` ZeroIdx + in Alam $ convertOpenAfun 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 + convertOpenAfun config alyt body = Abody $ convertOpenAcc config alyt body -- | Convert an open array expression to de Bruijn form while also incorporating sharing @@ -194,15 +204,16 @@ instance Arrays b => Afunction (Acc b) where 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 +convertOpenAcc config alyt acc = + let lvl = sizeLayout alyt + fvs = [lvl-1, lvl-2 .. 0] + (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 @@ -274,12 +285,7 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) 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) + -> AST.Aforeign ff (convertAfunWith config 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) @@ -320,7 +326,7 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) {-- -- Sequence expressions --- ------------------ +-- -------------------- -- | Convert a closed sequence expression to de Bruijn form while incorporating -- sharing information. @@ -576,33 +582,28 @@ mkReplicate = AST.Replicate (sliceIndex @slix) -- 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 +convertFun :: Function f => f -> AST.Fun () (FunctionR f) +convertFun + = convertFunWith + $ defaultOptions Options.\\ [RecoverSeqSharing, RecoverAccSharing, FloatOutAcc] +convertFunWith :: Function f => Config -> f -> AST.Fun () (FunctionR f) +convertFunWith config = convertOpenFun config EmptyLayout class Function f where type FunctionR f - convert :: Config -> Layout env env -> f -> AST.OpenFun env () (FunctionR f) + convertOpenFun :: 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) + convertOpenFun config lyt f = + let x = Exp $ Tag (sizeLayout lyt) + lyt' = incLayout lyt `PushLayout` ZeroIdx + in Lam $ convertOpenFun 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 + convertOpenFun config lyt body = Body $ convertOpenExp config lyt body -- Scalar expressions @@ -611,28 +612,26 @@ instance Elt b => Function (Exp b) where -- | Convert a closed scalar expression to de Bruijn form while incorporating -- sharing information. -- +convertExp :: Elt e => Exp e -> AST.Exp () e 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 + = convertExpWith + $ defaultOptions Options.\\ [RecoverSeqSharing, RecoverAccSharing, FloatOutAcc] + +convertExpWith :: Elt e => Config -> Exp e -> AST.Exp () e +convertExpWith config = convertOpenExp config EmptyLayout 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 +convertOpenExp config lyt exp = + let lvl = sizeLayout lyt + fvs = [lvl-1, lvl-2 .. 0] + (sharingExp, initialEnv) = recoverSharingExp config lvl fvs exp + in + convertSharingExp config lyt EmptyLayout initialEnv [] sharingExp -- | Convert an open expression with given environment layouts and sharing information into @@ -733,7 +732,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp 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) + Foreign ff f e -> AST.Foreign ff (convertFunWith config f) (cvt e) Coerce e -> AST.Coerce (cvt e) cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a @@ -1336,7 +1335,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc -> IO (UnscopedAcc arrs, Int) reconstruct newAcc = case heightIfRepeatedOccurrence of - Just height | recoverAccSharing config + Just height | Options.member RecoverAccSharing config -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height)), height) _ -> do (acc, height) <- newAcc return (UnscopedAcc [] (AccSharing (StableNameHeight sn height) acc), height) @@ -1667,7 +1666,7 @@ makeOccMapSharingExp config accOccMap expOccMap = travE -> IO (UnscopedExp a, Int) reconstruct newExp = case heightIfRepeatedOccurrence of - Just height | recoverExpSharing config + Just height | Options.member RecoverExpSharing config -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height)), height) _ -> do (exp, height) <- newExp return (UnscopedExp [] (ExpSharing (StableNameHeight sn height) exp), height) @@ -2368,7 +2367,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc (ScopedAcc [] (AvarSharing sn), thisCount) reconstruct newAcc subCount -- shared subtree => replace by a sharing variable (if 'recoverAccSharing' enabled) - | accOccCount > 1 && recoverAccSharing config + | accOccCount > 1 && Options.member RecoverAccSharing config = let allCount = (StableSharingAcc sn sharingAcc `insertAccNode` newCount) in tracePure ("SHARED" ++ completed) (show allCount) @@ -2628,8 +2627,8 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp 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 + | Options.member FloatOutAcc config = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount) + | otherwise = reconstruct (c acc) accCount where (var, stableAcc) = abstract acc (\(ScopedAcc _ s) -> s) @@ -2641,8 +2640,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp -- Occurrence count of the currently processed node expOccCount = let StableNameHeight sn' _ = sn - in - lookupWithASTName expOccMap (StableASTName sn') + in lookupWithASTName expOccMap (StableASTName sn') -- Reconstruct the current tree node. -- @@ -2667,7 +2665,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp (ScopedExp [] (VarSharing sn), thisCount) reconstruct newExp subCount -- shared subtree => replace by a sharing variable (if 'recoverExpSharing' enabled) - | expOccCount > 1 && recoverExpSharing config + | expOccCount > 1 && Options.member RecoverExpSharing config = let allCount = StableSharingExp sn sharingExp `insertExpNode` newCount in tracePure ("SHARED" ++ completed) (show allCount) From 30d7ee830afa7f7e85555358083c2ab95c5f41c6 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 29 May 2019 16:43:46 +0200 Subject: [PATCH 041/316] unify debug flags and trafo options --- accelerate.cabal | 1 + src/Data/Array/Accelerate/Debug/Flags.hs | 41 ++++++- src/Data/Array/Accelerate/Interpreter.hs | 15 +-- src/Data/Array/Accelerate/Trafo.hs | 102 ++++++---------- src/Data/Array/Accelerate/Trafo/Config.hs | 40 +++++++ src/Data/Array/Accelerate/Trafo/Fusion.hs | 130 +++++++++++---------- src/Data/Array/Accelerate/Trafo/Sharing.hs | 53 +++------ 7 files changed, 200 insertions(+), 182 deletions(-) create mode 100644 src/Data/Array/Accelerate/Trafo/Config.hs diff --git a/accelerate.cabal b/accelerate.cabal index 37ed6fb2e..33f8838f2 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -371,6 +371,7 @@ Library Data.Array.Accelerate.Pretty.Print Data.Array.Accelerate.Trafo.Algebra Data.Array.Accelerate.Trafo.Base + Data.Array.Accelerate.Trafo.Config Data.Array.Accelerate.Trafo.Fusion Data.Array.Accelerate.Trafo.Rewrite Data.Array.Accelerate.Trafo.Sharing diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index c370f9e60..9adae391c 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -26,8 +26,8 @@ module Data.Array.Accelerate.Debug.Flags ( getValue, setValue, - Flag, - acc_sharing, exp_sharing, array_fusion, simplify, flush_cache, force_recomp, + Flag(..), + seq_sharing, acc_sharing, exp_sharing, array_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, @@ -40,6 +40,8 @@ module Data.Array.Accelerate.Debug.Flags ( when, unless, + __cmd_line_flags, + ) where @@ -52,9 +54,42 @@ import Foreign.Storable import Control.Monad.IO.Class ( MonadIO, liftIO ) import qualified Control.Monad as M -newtype Flag = Flag Int -- can switch to an Enum now if we wished +newtype Flag = Flag Int -- could switch to a Haskell Enum if we wished newtype Value = Value (Ptr Int) -- of type HsInt in flags.c +instance Enum Flag where + toEnum = Flag + fromEnum (Flag x) = x + +instance Show Flag where + show (Flag x) = + case x of + 0 -> "seq-sharing" + 1 -> "acc-sharing" + 2 -> "exp-sharing" + 3 -> "fusion" + 4 -> "simplify" + 5 -> "fast-math" + 6 -> "flush_cache" + 7 -> "force-recomp" + 8 -> "debug" + 9 -> "verbose" + 10 -> "dump-phases" + 11 -> "dump-sharing" + 12 -> "dump-fusion" + 13 -> "dump-simpl_stats" + 14 -> "dump-simpl_iterations" + 15 -> "dump-vectorisation" + 16 -> "dump-dot" + 17 -> "dump-simpl_dot" + 18 -> "dump-gc" + 19 -> "dump-gc_stats" + 20 -> "dump-cc" + 21 -> "dump-ld" + 22 -> "dump-asm" + 23 -> "dump-exec" + 24 -> "dump-sched" + _ -> show x -- | Conditional execution of a monadic debugging expression. -- diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index f2d717d2a..f67addbf0 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -95,7 +95,7 @@ import qualified Data.Array.Accelerate.Debug as D run :: Arrays a => Smart.Acc a -> a run a = unsafePerformIO execute where - !acc = convertAccWith config a + !acc = convertAcc a execute = do D.dumpGraph $!! acc D.dumpSimplStats @@ -111,7 +111,7 @@ run1 = runN runN :: Afunction f => f -> AfunctionR f runN f = go where - !acc = convertAfunWith config f + !acc = convertAfun f !afun = unsafePerformIO $ do D.dumpGraph $!! acc D.dumpSimplStats @@ -131,17 +131,6 @@ runN f = go -- in evalDelayedSeq defaultSeqConfig seq' -config :: Phase -config = Phase - { recoverAccSharing = True - , recoverExpSharing = True - , recoverSeqSharing = True - , floatOutAccFromExp = True - , enableAccFusion = True - , convertOffsetOfSegment = False - -- , vectoriseSequences = True - } - -- Debugging -- --------- diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 825611cc6..c3d6efd20 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -18,7 +18,7 @@ module Data.Array.Accelerate.Trafo ( -- * HOAS -> de Bruijn conversion - Phase(..), phases, + Config(..), defaultOptions, convert_segment_offset, -- ** Array computations convertAcc, convertAccWith, @@ -35,7 +35,10 @@ module Data.Array.Accelerate.Trafo ( convertExp, convertFun, -- * Fusion - module Data.Array.Accelerate.Trafo.Fusion, + DelayedAcc, DelayedOpenAcc(..), + DelayedAfun, DelayedOpenAfun, + DelayedExp, DelayedOpenExp, + DelayedFun, DelayedOpenFun, -- * Substitution module Data.Array.Accelerate.Trafo.Substitution, @@ -52,10 +55,12 @@ module Data.Array.Accelerate.Trafo ( import Control.DeepSeq import Data.Typeable +import Data.BitSet import Data.Array.Accelerate.Smart 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.Config +import Data.Array.Accelerate.Trafo.Fusion ( DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun, DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun ) import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, Afunction, AfunctionR ) import Data.Array.Accelerate.Trafo.Substitution import qualified Data.Array.Accelerate.AST as AST @@ -65,64 +70,15 @@ 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 +import Data.Array.Accelerate.Debug.Flags hiding ( when ) + #ifdef ACCELERATE_DEBUG import Text.Printf import System.IO.Unsafe -import Data.Array.Accelerate.Debug.Flags hiding ( when ) import Data.Array.Accelerate.Debug.Timed #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 -- ---------------------------- @@ -130,14 +86,14 @@ when _ False = id -- incorporating sharing observation and array fusion. -- convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc arrs -convertAcc = convertAccWith phases +convertAcc = convertAccWith defaultOptions -convertAccWith :: Arrays arrs => Phase -> Acc arrs -> DelayedAcc arrs -convertAccWith Phase{..} acc - = phase "array-fusion" (Fusion.convertAcc enableAccFusion) +convertAccWith :: Arrays arrs => Config -> Acc arrs -> DelayedAcc arrs +convertAccWith config acc + = phase "array-fusion" (Fusion.convertAccWith config) -- phase "vectorise-sequences" Vectorise.vectoriseSeqAcc `when` vectoriseSequences - $ phase "rewrite-segment-offset" Rewrite.convertSegments `when` convertOffsetOfSegment - $ phase "sharing-recovery" Sharing.convertAcc -- recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp) + $ phase "rewrite-segment-offset" Rewrite.convertSegments `when` (convert_segment_offset `member` options config) + $ phase "sharing-recovery" (Sharing.convertAccWith config) $ acc @@ -145,14 +101,14 @@ convertAccWith Phase{..} acc -- observation and array fusion -- convertAfun :: Afunction f => f -> DelayedAfun (AfunctionR f) -convertAfun = convertAfunWith phases +convertAfun = convertAfunWith defaultOptions -convertAfunWith :: Afunction f => Phase -> f -> DelayedAfun (AfunctionR f) -convertAfunWith Phase{..} acc - = phase "array-fusion" (Fusion.convertAfun enableAccFusion) +convertAfunWith :: Afunction f => Config -> f -> DelayedAfun (AfunctionR f) +convertAfunWith config acc + = phase "array-fusion" (Fusion.convertAfunWith config) -- phase "vectorise-sequences" Vectorise.vectoriseSeqAfun `when` vectoriseSequences - $ phase "rewrite-segment-offset" Rewrite.convertSegmentsAfun `when` convertOffsetOfSegment - $ phase "sharing-recovery" Sharing.convertAfun -- recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp) + $ phase "rewrite-segment-offset" Rewrite.convertSegmentsAfun `when` (convert_segment_offset `member` options config) + $ phase "sharing-recovery" (Sharing.convertAfunWith config) $ acc @@ -161,8 +117,8 @@ convertAfunWith Phase{..} acc -- convertExp :: Elt e => Exp e -> AST.Exp () e convertExp - = phase "exp-simplify" Rewrite.simplify - . phase "sharing-recovery" Sharing.convertExp -- (recoverExpSharing phases)) + = phase "exp-simplify" Rewrite.simplify -- XXX: only if simplification is enabled + . phase "sharing-recovery" Sharing.convertExp -- | Convert closed scalar functions, incorporating sharing observation and @@ -171,7 +127,7 @@ convertExp convertFun :: Function f => f -> AST.Fun () (FunctionR f) convertFun = phase "exp-simplify" Rewrite.simplify - . phase "sharing-recovery" Sharing.convertFun -- (recoverExpSharing phases)) + . phase "sharing-recovery" Sharing.convertFun {-- -- | Convert a closed sequence computation, incorporating sharing observation and @@ -189,6 +145,14 @@ convertSeqWith Phase{..} s $ s --} + +when :: (a -> a) -> Bool -> a -> a +when f True = f +when _ False = id + +convert_segment_offset :: Flag +convert_segment_offset = Flag 31 -- TLM: let's remove the need for this + -- Debugging -- --------- diff --git a/src/Data/Array/Accelerate/Trafo/Config.hs b/src/Data/Array/Accelerate/Trafo/Config.hs new file mode 100644 index 000000000..5d3c9222e --- /dev/null +++ b/src/Data/Array/Accelerate/Trafo/Config.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Config +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Trafo.Config ( + + Config(..), + Flag(..), + defaultOptions, + +) where + +import Data.BitSet +import Data.Array.Accelerate.Debug.Flags as F + +import Data.Word +import System.IO.Unsafe +import Foreign.Storable + + +data Config = Config + { options :: {-# UNPACK #-} !(BitSet Word32 Flag) + , unfolding_use_threshold :: {-# UNPACK #-} !Int + , max_simplifier_iterations :: {-# UNPACK #-} !Int + } + deriving Show + +defaultOptions :: Config +defaultOptions = unsafePerformIO $! + Config <$> BitSet <$> peek F.__cmd_line_flags + <*> F.getValue F.unfolding_use_threshold + <*> F.getValue F.max_simplifier_iterations + diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index f8b1b5e62..1a4aa90de 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -40,7 +40,8 @@ module Data.Array.Accelerate.Trafo.Fusion ( DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun, -- ** Conversion - convertAcc, convertAfun, + convertAcc, convertAccWith, + convertAfun, convertAfunWith, ) where @@ -48,9 +49,11 @@ module Data.Array.Accelerate.Trafo.Fusion ( import Prelude hiding ( exp, until ) -- friends +import Data.BitSet import Data.Array.Accelerate.AST import Data.Array.Accelerate.Error import Data.Array.Accelerate.Trafo.Base +import Data.Array.Accelerate.Trafo.Config import Data.Array.Accelerate.Trafo.Shrink import Data.Array.Accelerate.Trafo.Simplify import Data.Array.Accelerate.Trafo.Substitution @@ -61,6 +64,7 @@ import Data.Array.Accelerate.Array.Sugar ( Array, Arrays(..), Arr import Data.Array.Accelerate.Product import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Debug.Flags ( array_fusion ) import qualified Data.Array.Accelerate.Debug.Stats as Stats #ifdef ACCELERATE_DEBUG import System.IO.Unsafe -- for debugging @@ -72,13 +76,19 @@ import System.IO.Unsafe -- for debugging -- | Apply the fusion transformation to a closed de Bruijn AST -- -convertAcc :: Arrays arrs => Bool -> Acc arrs -> DelayedAcc arrs -convertAcc fuseAcc = withSimplStats . convertOpenAcc fuseAcc +convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc arrs +convertAcc = convertAccWith defaultOptions + +convertAccWith :: Arrays arrs => Config -> Acc arrs -> DelayedAcc arrs +convertAccWith config = withSimplStats . convertOpenAcc config -- | Apply the fusion transformation to a function of array arguments -- -convertAfun :: Bool -> Afun f -> DelayedAfun f -convertAfun fuseAcc = withSimplStats . convertOpenAfun fuseAcc +convertAfun :: Afun f -> DelayedAfun f +convertAfun = convertAfunWith defaultOptions + +convertAfunWith :: Config -> Afun f -> DelayedAfun f +convertAfunWith config = withSimplStats . convertOpenAfun config -- -- | Apply the fusion transformation to the array computations embedded -- -- in a sequence computation. @@ -112,16 +122,16 @@ withSimplStats x = x -- 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 +convertOpenAcc :: Arrays arrs => Config -> OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs +convertOpenAcc config = manifest config . computeAcc . embedOpenAcc config -- 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) = +delayed :: (Shape sh, Elt e) => Config -> OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e) +delayed config (embedOpenAcc config -> 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) @@ -134,7 +144,7 @@ delayed fuseAcc (embedOpenAcc fuseAcc -> Embed BaseEnv cc) = -> Delayed sh f' (f' `compose` fromIndex sh) where cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t - cvtE = convertOpenExp fuseAcc + cvtE = convertOpenExp config cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f cvtF (Lam f) = Lam (cvtF f) @@ -142,8 +152,8 @@ delayed fuseAcc (embedOpenAcc fuseAcc -> Embed BaseEnv cc) = -- Convert array programs as manifest terms. -- -manifest :: Bool -> OpenAcc aenv a -> DelayedOpenAcc aenv a -manifest fuseAcc (OpenAcc pacc) = +manifest :: Config -> OpenAcc aenv a -> DelayedOpenAcc aenv a +manifest config (OpenAcc pacc) = let fusionError = $internalError "manifest" "unexpected fusible materials" in Manifest $ case pacc of @@ -152,13 +162,13 @@ manifest fuseAcc (OpenAcc pacc) = 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) + Alet bnd body -> alet (manifest config bnd) (manifest config body) + Acond p t e -> Acond (cvtE p) (manifest config t) (manifest config e) + Awhile p f a -> Awhile (cvtAF p) (cvtAF f) (manifest config 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) + Aprj ix tup -> Aprj ix (manifest config tup) + Apply f a -> Apply (cvtAF f) (manifest config a) + Aforeign ff f a -> Aforeign ff (cvtAF f) (manifest config a) -- Producers -- --------- @@ -168,11 +178,11 @@ manifest fuseAcc (OpenAcc pacc) = -- 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) + Map f a -> Map (cvtF f) (delayed config 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) + Transform sh p f a -> Transform (cvtE sh) (cvtF p) (cvtF f) (delayed config a) + Backpermute sh p a -> Backpermute (cvtE sh) (cvtF p) (delayed config a) + Reshape sl a -> Reshape (cvtE sl) (manifest config a) Replicate{} -> fusionError Slice{} -> fusionError @@ -186,19 +196,19 @@ manifest fuseAcc (OpenAcc pacc) = -- 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) + Fold f z a -> Fold (cvtF f) (cvtE z) (delayed config a) + Fold1 f a -> Fold1 (cvtF f) (delayed config a) + FoldSeg f z a s -> FoldSeg (cvtF f) (cvtE z) (delayed config a) (delayed config s) + Fold1Seg f a s -> Fold1Seg (cvtF f) (delayed config a) (delayed config s) + Scanl f z a -> Scanl (cvtF f) (cvtE z) (delayed config a) + Scanl1 f a -> Scanl1 (cvtF f) (delayed config a) + Scanl' f z a -> Scanl' (cvtF f) (cvtE z) (delayed config a) + Scanr f z a -> Scanr (cvtF f) (cvtE z) (delayed config a) + Scanr1 f a -> Scanr1 (cvtF f) (delayed config a) + Scanr' f z a -> Scanr' (cvtF f) (cvtE z) (delayed config a) + Permute f d p a -> Permute (cvtF f) (manifest config d) (cvtF p) (delayed config a) + Stencil f x a -> Stencil (cvtF f) (cvtB x) (delayed config a) + Stencil2 f x a y b -> Stencil2 (cvtF f) (cvtB x) (delayed config a) (cvtB y) (delayed config b) -- Collect s -> Collect (cvtS s) where @@ -215,14 +225,14 @@ manifest fuseAcc (OpenAcc pacc) = cvtAT :: Atuple (OpenAcc aenv) a -> Atuple (DelayedOpenAcc aenv) a cvtAT NilAtup = NilAtup - cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` manifest fuseAcc a + cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` manifest config a cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f cvtAF (Alam f) = Alam (cvtAF f) - cvtAF (Abody b) = Abody (manifest fuseAcc b) + cvtAF (Abody b) = Abody (manifest config b) -- cvtS :: PreOpenSeq OpenAcc aenv senv s -> PreOpenSeq DelayedOpenAcc aenv senv s - -- cvtS = convertOpenSeq fuseAcc + -- cvtS = convertOpenSeq config -- Conversions for closed scalar functions and expressions -- @@ -231,7 +241,7 @@ manifest fuseAcc (OpenAcc pacc) = cvtF (Body b) = Body (cvtE b) cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t - cvtE = convertOpenExp fuseAcc + cvtE = convertOpenExp config cvtB :: Boundary aenv t -> PreBoundary DelayedOpenAcc aenv t cvtB Clamp = Clamp @@ -240,8 +250,8 @@ manifest fuseAcc (OpenAcc pacc) = cvtB (Constant v) = Constant v cvtB (Function f) = Function (cvtF f) -convertOpenExp :: Bool -> OpenExp env aenv t -> DelayedOpenExp env aenv t -convertOpenExp fuseAcc exp = +convertOpenExp :: Config -> OpenExp env aenv t -> DelayedOpenExp env aenv t +convertOpenExp config exp = case exp of Let bnd body -> Let (cvtE bnd) (cvtE body) Var ix -> Var ix @@ -262,9 +272,9 @@ convertOpenExp fuseAcc exp = 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) + Index a sh -> Index (manifest config a) (cvtE sh) + LinearIndex a i -> LinearIndex (manifest config a) (cvtE i) + Shape a -> Shape (manifest config a) ShapeSize sh -> ShapeSize (cvtE sh) Intersect s t -> Intersect (cvtE s) (cvtE t) Union s t -> Union (cvtE s) (cvtE t) @@ -282,24 +292,24 @@ convertOpenExp fuseAcc exp = cvtF (Body b) = Body (cvtE b) cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t - cvtE = convertOpenExp fuseAcc + cvtE = convertOpenExp config -convertOpenAfun :: Bool -> OpenAfun aenv f -> DelayedOpenAfun aenv f +convertOpenAfun :: Config -> 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 = +convertOpenSeq :: Config -> PreOpenSeq OpenAcc aenv senv a -> PreOpenSeq DelayedOpenAcc aenv senv a +convertOpenSeq config s = case s of Consumer c -> Consumer (cvtC c) Reify ix -> Reify ix - Producer p s' -> Producer p' (convertOpenSeq fuseAcc s') + Producer p s' -> Producer p' (convertOpenSeq config s') where p' = case p of StreamIn arrs -> StreamIn arrs - ToSeq slix sh a -> ToSeq slix sh (delayed fuseAcc a) + ToSeq slix sh a -> ToSeq slix sh (delayed config a) MapSeq f x -> MapSeq (cvtAF f) x ChunkedMapSeq f x -> ChunkedMapSeq (cvtAF f) x ZipWithSeq f x y -> ZipWithSeq (cvtAF f) x y @@ -309,7 +319,7 @@ convertOpenSeq fuseAcc s = 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 + FoldSeqFlatten f a x -> FoldSeqFlatten (cvtAF f) (manifest config a) x Stuple t -> Stuple (cvtCT t) cvtCT :: Atuple (Consumer OpenAcc aenv senv) t -> Atuple (Consumer DelayedOpenAcc aenv senv) t @@ -318,10 +328,10 @@ convertOpenSeq fuseAcc s = cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f cvtAF (Alam f) = Alam (cvtAF f) - cvtAF (Abody b) = Abody (manifest fuseAcc b) + cvtAF (Abody b) = Abody (manifest config b) cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t - cvtE = convertOpenExp fuseAcc + cvtE = convertOpenExp config cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f cvtF (Lam f) = Lam (cvtF f) @@ -337,9 +347,9 @@ convertOpenSeq fuseAcc s = 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 +embedOpenAcc :: Arrays arrs => Config -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs +embedOpenAcc config (OpenAcc pacc) = + embedPreAcc config (embedOpenAcc config) 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 @@ -361,12 +371,12 @@ embedOpenAcc fuseAcc (OpenAcc pacc) = embedPreAcc :: forall acc aenv arrs. (Kit acc, Arrays arrs) - => Bool + => Config -> EmbedAcc acc -> ElimAcc acc -> PreOpenAcc acc aenv arrs -> Embed acc aenv arrs -embedPreAcc fuseAcc embedAcc elimAcc pacc +embedPreAcc config embedAcc elimAcc pacc = unembed $ case pacc of @@ -452,8 +462,8 @@ embedPreAcc fuseAcc embedAcc elimAcc pacc -- unembed :: Embed acc aenv arrs -> Embed acc aenv arrs unembed x - | fuseAcc = x - | otherwise = done (compute x) + | array_fusion `member` options config = x + | otherwise = done (compute x) cvtA :: Arrays a => acc aenv' a -> acc aenv' a cvtA = computeAcc . embedAcc diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 62b1a1a67..0051f4365 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -13,7 +13,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -48,13 +47,10 @@ module Data.Array.Accelerate.Trafo.Sharing ( -- standard library import Control.Applicative hiding ( Const ) import Control.Monad.Fix -import Data.Bits import Data.Hashable -import Data.List +import Data.List hiding ( (\\) ) import Data.Maybe import Data.Typeable -import Data.Word -import Foreign.Storable import System.IO.Unsafe ( unsafePerformIO ) import System.Mem.StableName import Text.Printf @@ -65,42 +61,25 @@ import qualified Data.HashSet as Set import Prelude -- friends -import Data.BitSet ( BitSet(..) ) -import qualified Data.BitSet as Options - +import Data.BitSet ( (\\), member ) import Data.Array.Accelerate.Error import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Trafo.Config 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.Trace as Debug -import qualified Data.Array.Accelerate.Debug.Flags as Debug +import Data.Array.Accelerate.Debug.Trace as Debug +import Data.Array.Accelerate.Debug.Flags as Debug -- Configuration -- ------------- -type Config = BitSet Word32 Option - -data Option - = RecoverSeqSharing -- ^ Recover sharing of sequence computations ? - | RecoverAccSharing -- ^ Recover sharing of array computations ? - | RecoverExpSharing -- ^ Recover sharing of scalar expressions ? - | FloatOutAcc -- ^ Always float array computations out of expressions ? - deriving (Show, Enum) - -defaultOptions :: Config -#if ACCELERATE_DEBUG -defaultOptions = unsafePerformIO $ do - v <- (0b111 .&.) <$> peek Debug.__cmd_line_flags -- SEE: [layout of command line options bitfield] - return $! Options.insert FloatOutAcc (BitSet v) -#else -defaultOptions = [RecoverAccSharing, RecoverExpSharing, RecoverSeqSharing, FloatOutAcc] -#endif - +float_out_acc :: Flag +float_out_acc = Flag 31 -- Layouts -- ------- @@ -585,7 +564,7 @@ mkReplicate = AST.Replicate (sliceIndex @slix) convertFun :: Function f => f -> AST.Fun () (FunctionR f) convertFun = convertFunWith - $ defaultOptions Options.\\ [RecoverSeqSharing, RecoverAccSharing, FloatOutAcc] + $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing, float_out_acc] } convertFunWith :: Function f => Config -> f -> AST.Fun () (FunctionR f) convertFunWith config = convertOpenFun config EmptyLayout @@ -615,7 +594,7 @@ instance Elt b => Function (Exp b) where convertExp :: Elt e => Exp e -> AST.Exp () e convertExp = convertExpWith - $ defaultOptions Options.\\ [RecoverSeqSharing, RecoverAccSharing, FloatOutAcc] + $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing, float_out_acc] } convertExpWith :: Elt e => Config -> Exp e -> AST.Exp () e convertExpWith config = convertOpenExp config EmptyLayout @@ -1335,7 +1314,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc -> IO (UnscopedAcc arrs, Int) reconstruct newAcc = case heightIfRepeatedOccurrence of - Just height | Options.member RecoverAccSharing config + Just height | acc_sharing `member` options config -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height)), height) _ -> do (acc, height) <- newAcc return (UnscopedAcc [] (AccSharing (StableNameHeight sn height) acc), height) @@ -1666,7 +1645,7 @@ makeOccMapSharingExp config accOccMap expOccMap = travE -> IO (UnscopedExp a, Int) reconstruct newExp = case heightIfRepeatedOccurrence of - Just height | Options.member RecoverExpSharing config + Just height | exp_sharing `member` options config -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height)), height) _ -> do (exp, height) <- newExp return (UnscopedExp [] (ExpSharing (StableNameHeight sn height) exp), height) @@ -2367,7 +2346,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc (ScopedAcc [] (AvarSharing sn), thisCount) reconstruct newAcc subCount -- shared subtree => replace by a sharing variable (if 'recoverAccSharing' enabled) - | accOccCount > 1 && Options.member RecoverAccSharing config + | accOccCount > 1 && acc_sharing `member` options config = let allCount = (StableSharingAcc sn sharingAcc `insertAccNode` newCount) in tracePure ("SHARED" ++ completed) (show allCount) @@ -2626,9 +2605,9 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp -> (ScopedExp t, NodeCounts) maybeFloatOutAcc c acc@(ScopedAcc _ (AvarSharing _)) accCount -- nothing to float out = reconstruct (c acc) accCount - maybeFloatOutAcc c acc accCount - | Options.member FloatOutAcc config = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount) - | otherwise = reconstruct (c acc) accCount + maybeFloatOutAcc c acc accCount + | float_out_acc `member` options config = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount) + | otherwise = reconstruct (c acc) accCount where (var, stableAcc) = abstract acc (\(ScopedAcc _ s) -> s) @@ -2665,7 +2644,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp (ScopedExp [] (VarSharing sn), thisCount) reconstruct newExp subCount -- shared subtree => replace by a sharing variable (if 'recoverExpSharing' enabled) - | expOccCount > 1 && Options.member RecoverExpSharing config + | expOccCount > 1 && exp_sharing `member` options config = let allCount = StableSharingExp sn sharingExp `insertExpNode` newCount in tracePure ("SHARED" ++ completed) (show allCount) From ccb516af8c4ef27fb5759b078aadae2b427029bc Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 29 May 2019 17:21:00 +0200 Subject: [PATCH 042/316] build fix --- src/Data/Array/Accelerate/Test/NoFib/Sharing.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs b/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs index 62a9a3030..d69b209fa 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs @@ -66,12 +66,12 @@ test_sharing = where sharingAcc :: Arrays a => Acc a -> Assertion sharingAcc acc = - catch (rnf (convertAcc True True True True acc) `seq` return ()) + catch (rnf (convertAcc acc) `seq` return ()) (\(e :: SomeException) -> assertFailure (show e)) sharingExp :: Elt e => Exp e -> Assertion sharingExp exp = - catch (rnf (convertExp True exp) `seq` return ()) + catch (rnf (convertExp exp) `seq` return ()) (\(e :: SomeException) -> assertFailure (show e)) From 09a3dab9d8ce0ed310c85b5e964ee550093adc3b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 29 May 2019 17:21:03 +0200 Subject: [PATCH 043/316] wibbles --- src/Data/Array/Accelerate/Trafo/Sharing.hs | 64 +++++++++++----------- 1 file changed, 32 insertions(+), 32 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 0051f4365..30f7705af 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -1,18 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -1071,6 +1069,7 @@ matchStableAcc sn1 (StableSharingAcc sn2 _) -- Dummy entry for environments to be used for unused variables. -- +{-# NOINLINE noStableAccName #-} noStableAccName :: StableAccName arrs noStableAccName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0 @@ -1134,6 +1133,7 @@ matchStableExp sn1 (StableSharingExp sn2 _) -- Dummy entry for environments to be used for unused variables. -- +{-# NOINLINE noStableExpName #-} noStableExpName :: StableExpName t noStableExpName = unsafePerformIO $ StableNameHeight <$> makeStableName undefined <*> pure 0 @@ -1976,9 +1976,9 @@ insertSeqNode ssa@(StableSharingSeq (StableNameHeight sn _) _) (subterms,g) -- -- 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 ]) +cleanCounts (ns, g) = (ns, Map.fromList [(h, Set.filter (flip elem hs) (g Map.! h)) | h <- hs ]) where - hs = (map nodeName ns) + hs = map nodeName ns nodeName :: NodeCount -> NodeName nodeName (AccNodeCount (StableSharingAcc (StableNameHeight sn _) _) _) = NodeName sn @@ -2409,10 +2409,10 @@ determineScopesSharingAcc config accOccMap = scopesAcc 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 + body@(UnscopedAcc fvs _) = f undefined + (ScopedAcc [] body', (counts,graph)) = scopesAcc body + (freeCounts, counts') = partition isBoundHere counts + ssa = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts] isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs isBoundHere _ = False @@ -2478,11 +2478,11 @@ determineScopesExp -> (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 + (ScopedExp [] expWithScopes, (nodeCounts,graph)) = determineScopesSharingExp config accOccMap expOccMap exp + (expCounts, accCounts) = partition isExpNodeCount nodeCounts - isExpNodeCount ExpNodeCount{} = True - isExpNodeCount _ = False + isExpNodeCount ExpNodeCount{} = True + isExpNodeCount _ = False in (ScopedExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, cleanCounts (accCounts,graph)) @@ -2499,12 +2499,12 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp 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)) + 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 + body@(UnscopedExp fvs _) = f undefined + (ScopedExp [] body', (counts, graph)) = scopesExp body + (freeCounts, counts') = partition isBoundHere counts + ssa = buildInitialEnvExp fvs [se | ExpNodeCount se _ <- freeCounts] isBoundHere (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag i))) _) = i `elem` fvs isBoundHere _ = False @@ -2613,8 +2613,8 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp 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 (ScopedAcc _ (AvarSharing _)) _ = $internalError "sharingAccToVar" "AvarSharing" + abstract (ScopedAcc ssa (AletSharing sa acc)) lets = abstract acc (lets . ScopedAcc ssa . AletSharing sa) abstract acc@(ScopedAcc ssa (AccSharing sn _)) lets = (ScopedAcc ssa (AvarSharing sn), StableSharingAcc sn (lets acc)) -- Occurrence count of the currently processed node From 3cd7cf1ed310483a0edcb6654815dbd94972f6fe Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 30 May 2019 11:35:26 +0200 Subject: [PATCH 044/316] fix default trafo config --- src/Data/Array/Accelerate/Debug/Flags.hs | 6 +++++- src/Data/Array/Accelerate/Trafo.hs | 3 --- src/Data/Array/Accelerate/Trafo/Config.hs | 14 +++++++++++++- src/Data/Array/Accelerate/Trafo/Sharing.hs | 6 ------ 4 files changed, 18 insertions(+), 11 deletions(-) diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index 9adae391c..d7e7c973c 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -54,9 +54,13 @@ import Foreign.Storable import Control.Monad.IO.Class ( MonadIO, liftIO ) import qualified Control.Monad as M -newtype Flag = Flag Int -- could switch to a Haskell Enum if we wished +newtype Flag = Flag Int newtype Value = Value (Ptr Int) -- of type HsInt in flags.c +-- We aren't using a "real" enum so that we can make use of the unused top +-- bits for other configuration options, not controlled by the command line +-- flags. +-- instance Enum Flag where toEnum = Flag fromEnum (Flag x) = x diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index c3d6efd20..7a7332db5 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -150,9 +150,6 @@ when :: (a -> a) -> Bool -> a -> a when f True = f when _ False = id -convert_segment_offset :: Flag -convert_segment_offset = Flag 31 -- TLM: let's remove the need for this - -- Debugging -- --------- diff --git a/src/Data/Array/Accelerate/Trafo/Config.hs b/src/Data/Array/Accelerate/Trafo/Config.hs index 5d3c9222e..c0f45e8d8 100644 --- a/src/Data/Array/Accelerate/Trafo/Config.hs +++ b/src/Data/Array/Accelerate/Trafo/Config.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -- | -- Module : Data.Array.Accelerate.Trafo.Config -- Copyright : [2008..2019] The Accelerate Team @@ -15,8 +16,13 @@ module Data.Array.Accelerate.Trafo.Config ( Flag(..), defaultOptions, + -- Other options not controlled by the command line flags + convert_segment_offset, + float_out_acc, + ) where +import Data.Bits import Data.BitSet import Data.Array.Accelerate.Debug.Flags as F @@ -32,9 +38,15 @@ data Config = Config } deriving Show +{-# NOINLINE defaultOptions #-} defaultOptions :: Config defaultOptions = unsafePerformIO $! - Config <$> BitSet <$> peek F.__cmd_line_flags + Config <$> (BitSet . (0x80000000 .|.)) <$> peek F.__cmd_line_flags <*> F.getValue F.unfolding_use_threshold <*> F.getValue F.max_simplifier_iterations +-- Extra options not covered by command line flags +-- +convert_segment_offset = Flag 30 -- TLM: let's remove the need for this +float_out_acc = Flag 31 + diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 30f7705af..69a2b6abe 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -73,12 +73,6 @@ import Data.Array.Accelerate.Debug.Trace as Debug import Data.Array.Accelerate.Debug.Flags as Debug --- Configuration --- ------------- - -float_out_acc :: Flag -float_out_acc = Flag 31 - -- Layouts -- ------- From b3ed4a53effb375e714585540cb9d95df5b25c2f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 30 May 2019 11:35:58 +0200 Subject: [PATCH 045/316] comment wibbles --- src/Data/Array/Accelerate/AST.hs | 102 ++++++++++++++++++++----------- 1 file changed, 68 insertions(+), 34 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 17dc111c8..55ed360f7 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -211,7 +211,7 @@ prjElt _ _ = $internalError "prjElt" "inconsistent val -- Array expressions -- ----------------- --- |Function abstraction over parametrised array computations +-- | Function abstraction over parametrised array computations -- data PreOpenAfun acc aenv t where Abody :: Arrays t => acc aenv t -> PreOpenAfun acc aenv t @@ -221,11 +221,11 @@ data PreOpenAfun acc aenv t where -- type OpenAfun = PreOpenAfun OpenAcc --- |Parametrised array-computation function without free array variables +-- | Parametrised array-computation function without free array variables -- type PreAfun acc = PreOpenAfun acc () --- |Vanilla array-computation function without free array variables +-- | Vanilla array-computation function without free array variables -- type Afun = OpenAfun () @@ -233,7 +233,7 @@ type Afun = OpenAfun () -- newtype OpenAcc aenv t = OpenAcc (PreOpenAcc OpenAcc aenv t) --- |Closed array expression aka an array program +-- | Closed array expression aka an array program -- type Acc = OpenAcc () @@ -241,40 +241,43 @@ deriving instance Typeable PreOpenAcc deriving instance Typeable OpenAcc --- |Collective array computations parametrised over array variables +-- | 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 +-- 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.) +-- 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). +-- 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. +-- 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 + -- Local non-recursive binding to represent sharing and demand + -- explicitly. Note 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 @@ -297,6 +300,7 @@ data PreOpenAcc acc aenv a where -- 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) @@ -304,6 +308,7 @@ data PreOpenAcc acc aenv a where -> PreOpenAcc acc aenv bs -- If-then-else for array-level computations + -- Acond :: Arrays arrs => PreExp acc aenv Bool -> acc aenv arrs @@ -311,6 +316,7 @@ data PreOpenAcc acc aenv a where -> 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 @@ -318,24 +324,31 @@ data PreOpenAcc acc aenv a where -> PreOpenAcc acc aenv arrs - -- Array inlet (triggers async host->device transfer if necessary) + -- Array inlet. Triggers (possibly) asynchronous 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' + -- Change the shape of an array without altering its contents. + -- Precondition (this may not be checked!): + -- + -- > 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 @@ -343,6 +356,7 @@ data PreOpenAcc acc aenv a where -- 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 @@ -352,6 +366,7 @@ data PreOpenAcc acc aenv a where -- 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) @@ -361,8 +376,9 @@ data PreOpenAcc acc aenv a where -> 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 + -- 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) @@ -373,34 +389,41 @@ data PreOpenAcc acc aenv a where -> 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. + -- 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 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 + -- As '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 + -- 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 @@ -408,24 +431,28 @@ data PreOpenAcc acc aenv a where -> acc aenv (Segments i) -- segment descriptor -> PreOpenAcc acc aenv (Array (sh:.Int) e) - -- 'FoldSeg' without a default value + -- As '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) + -- 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) + -- 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 @@ -433,12 +460,14 @@ data PreOpenAcc acc aenv a where -> 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 @@ -446,6 +475,7 @@ data PreOpenAcc acc aenv a where -> 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 @@ -453,6 +483,7 @@ data PreOpenAcc acc aenv a where -> 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) @@ -487,14 +518,16 @@ data PreOpenAcc acc aenv a where -- 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. + -- 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 @@ -502,6 +535,7 @@ data PreOpenAcc acc aenv a where -> 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 From ca5dcbb046541868c1951bdcd0d152331ce3a630 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 30 May 2019 12:37:19 +0200 Subject: [PATCH 046/316] avoid some work in clock_darwin_gettime() --- cbits/clock.c | 37 ++++++++++++++++++++++++++++++------- 1 file changed, 30 insertions(+), 7 deletions(-) diff --git a/cbits/clock.c b/cbits/clock.c index ddfdaea27..9ba0d3220 100644 --- a/cbits/clock.c +++ b/cbits/clock.c @@ -26,16 +26,39 @@ #include #include -static void clock_darwin_gettime(clock_id_t clock, struct timespec *t) +static clock_serv_t __cclock; + +/* constructors with priority execute before constructors without a priority + * value. + * + * constructors with a lower [numeric] priority value are executed before + * constructors with a higher [numeric] priority. + * + * constructor priority values [0,100] are reserved. + */ +__attribute__((constructor(101))) void initialise_clock_service(void) +{ + host_get_clock_service(mach_host_self(), SYSTEM_CLOCK, &__cclock); +} + +/* destructors without a priority execute before destructors with a priority + * + * destructors with a higher [numeric] priority value are executed before + * destructors with a lower priority value. + * + * destructor priority values [0,100] are reserved. + */ +__attribute__((destructor(101))) void deallocate_clock_service(void) +{ + mach_port_deallocate(mach_task_self(), __cclock); +} + +static void clock_darwin_gettime(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); + clock_get_time(__cclock, &mts); t->tv_sec = mts.tv_sec; t->tv_nsec = mts.tv_nsec; @@ -44,7 +67,7 @@ static void clock_darwin_gettime(clock_id_t clock, struct timespec *t) double clock_gettime_monotonic_seconds() { struct timespec t; - clock_darwin_gettime(SYSTEM_CLOCK, &t); + clock_darwin_gettime(&t); return (double) t.tv_sec + (double) t.tv_nsec * 1.0E-9; } From b237241f8afa8ebdc8ccaedf5e1d27d1c0d66708 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 30 May 2019 13:32:22 +0200 Subject: [PATCH 047/316] export BitSet --- accelerate.cabal | 4 +++- src/Data/Array/Accelerate/Trafo.hs | 3 ++- src/Data/BitSet.hs | 1 + 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/accelerate.cabal b/accelerate.cabal index 33f8838f2..f436dda46 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -337,6 +337,9 @@ Library Data.Array.Accelerate.Test.NoFib Data.Array.Accelerate.Test.Similar + -- Other + Data.BitSet + Other-modules: Data.Array.Accelerate.Analysis.Hash.TH Data.Array.Accelerate.Array.Remote.Nursery @@ -379,7 +382,6 @@ Library Data.Array.Accelerate.Trafo.Simplify Data.Array.Accelerate.Trafo.Substitution Data.Atomic - Data.BitSet -- Data.Array.Accelerate.Array.Lifted -- Data.Array.Accelerate.Trafo.Vectorise diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 7a7332db5..3cd6ed622 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -18,7 +18,8 @@ module Data.Array.Accelerate.Trafo ( -- * HOAS -> de Bruijn conversion - Config(..), defaultOptions, convert_segment_offset, + -- ** Options + module Data.Array.Accelerate.Trafo.Config, -- ** Array computations convertAcc, convertAccWith, diff --git a/src/Data/BitSet.hs b/src/Data/BitSet.hs index 2f4858d37..d9000f723 100644 --- a/src/Data/BitSet.hs +++ b/src/Data/BitSet.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.BitSet -- Copyright : [2019] The Accelerate Team From 89a42150965a500873c46f6596ca3a8c63dfb1ac Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 30 May 2019 13:33:43 +0200 Subject: [PATCH 048/316] stack/8.6: update extra-deps --- stack-8.6.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/stack-8.6.yaml b/stack-8.6.yaml index 46881ab93..9f62750bb 100644 --- a/stack-8.6.yaml +++ b/stack-8.6.yaml @@ -7,7 +7,8 @@ packages: - . extra-deps: -- tasty-hedgehog-0.2.0.0 +- hedgehog-1.0 +- tasty-hedgehog-1.0.0.1 # Override default flag values for local packages and extra-deps # flags: {} From c5d4cf811e07bfc69b7ff8e325f83ec790b9465f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 30 May 2019 23:41:19 +0200 Subject: [PATCH 049/316] support NO_COLOR environment variable --- src/Data/Array/Accelerate/Pretty.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index 0122dfa2a..98042967d 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -35,9 +35,11 @@ module Data.Array.Accelerate.Pretty ( ) where -- libraries +import Data.Maybe import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String import Data.Text.Prettyprint.Doc.Render.Terminal +import System.Environment import System.IO import System.IO.Unsafe import qualified Data.Text.Lazy as T @@ -118,8 +120,14 @@ instance (PrettyEnv env, PrettyEnv aenv) => Show (PreOpenFun DelayedOpenAcc env renderForTerminal :: Adoc -> String renderForTerminal = render . layoutSmart terminalLayoutOptions where - render | terminalSupportsANSI = T.unpack . renderLazy . reAnnotateS ansiKeyword - | otherwise = renderString + fancy = terminalSupportsANSI && terminalColourAllowed + render + | fancy = T.unpack . renderLazy . reAnnotateS ansiKeyword + | otherwise = renderString + +{-# NOINLINE terminalColourAllowed #-} +terminalColourAllowed :: Bool +terminalColourAllowed = unsafePerformIO $ isNothing <$> lookupEnv "NO_COLOR" {-# NOINLINE terminalSupportsANSI #-} terminalSupportsANSI :: Bool From 15c9e03a8cc29d0b0b87600c6082b6788cd7be74 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 31 May 2019 00:40:05 +0200 Subject: [PATCH 050/316] build fix --- src/Data/BitSet.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Data/BitSet.hs b/src/Data/BitSet.hs index d9000f723..e952a0459 100644 --- a/src/Data/BitSet.hs +++ b/src/Data/BitSet.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.BitSet @@ -16,6 +17,9 @@ module Data.BitSet where import Data.Bits import Prelude hiding ( foldl, foldr ) import qualified Data.List as List +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup +#endif import GHC.Exts ( IsList, build ) import qualified GHC.Exts as Exts @@ -37,6 +41,9 @@ instance (Enum a, Bits c) => Semigroup (BitSet c a) where instance (Enum a, Bits c, Num c) => Monoid (BitSet c a) where mempty = empty +#if __GLASGOW_HASKELL__ < 804 + mappend = (<>) +#endif instance (Enum a, Bits c, Num c) => IsList (BitSet c a) where type Item (BitSet c a) = a @@ -99,7 +106,8 @@ difference :: Bits c => BitSet c a -> BitSet c a -> BitSet c a difference (BitSet bits1) (BitSet bits2) = BitSet $! bits1 .&. complement bits2 -- | See 'difference'. -infix 5 \\ +-- +infix 5 \\ -- comment to fool cpp: https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/phases.html#cpp-and-string-gaps {-# INLINE (\\) #-} (\\) :: Bits c => BitSet c a -> BitSet c a -> BitSet c a (\\) = difference From 0b907b7fc554e523fef9ee2c0be21aea010bcb5b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 4 Jun 2019 10:25:23 +0200 Subject: [PATCH 051/316] nofib: add test for AccelerateHS/accelerate#437 --- accelerate.cabal | 1 + .../Array/Accelerate/Test/NoFib/Issues.hs | 2 + .../Accelerate/Test/NoFib/Issues/Issue437.hs | 80 +++++++++++++++++++ 3 files changed, 83 insertions(+) create mode 100644 src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs diff --git a/accelerate.cabal b/accelerate.cabal index f436dda46..1c979b2af 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -438,6 +438,7 @@ Library Data.Array.Accelerate.Test.NoFib.Issues.Issue407 Data.Array.Accelerate.Test.NoFib.Issues.Issue409 Data.Array.Accelerate.Test.NoFib.Issues.Issue436 + Data.Array.Accelerate.Test.NoFib.Issues.Issue437 else cpp-options: diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs index 87b980626..3d0811f1a 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs @@ -60,6 +60,7 @@ import Data.Array.Accelerate.Test.NoFib.Issues.Issue364 import Data.Array.Accelerate.Test.NoFib.Issues.Issue407 import Data.Array.Accelerate.Test.NoFib.Issues.Issue409 import Data.Array.Accelerate.Test.NoFib.Issues.Issue436 +import Data.Array.Accelerate.Test.NoFib.Issues.Issue437 test_issues :: RunN -> TestTree @@ -86,5 +87,6 @@ test_issues runN = , test_issue407 runN , test_issue409 runN , test_issue436 runN + , test_issue437 runN ] diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs new file mode 100644 index 000000000..46e1d67b8 --- /dev/null +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- | +-- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue437 +-- Copyright : [2009..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- https://github.com/AccelerateHS/accelerate/issues/437 +-- + +module Data.Array.Accelerate.Test.NoFib.Issues.Issue437 ( + + test_issue437 + +) where + +import Data.Atomic as Atomic +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Test.NoFib.Base + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.ExpectedFailure + +import Text.Printf +import Prelude as P + + +test_issue437 :: RunN -> TestTree +test_issue437 runN +#ifndef ACCELERATE_DEBUG + = expectFail + $ testCase "437" + $ assertFailure "This test requires building with -fdebug" +#else + = testCase "437" + $ do + a0 <- Atomic.read __total_bytes_allocated_remote + b0 <- Atomic.read __total_bytes_copied_to_remote + c0 <- Atomic.read __total_bytes_copied_from_remote + + let (a,_) = go xs + a `seq` return () + + a1 <- Atomic.read __total_bytes_allocated_remote + b1 <- Atomic.read __total_bytes_copied_to_remote + c1 <- Atomic.read __total_bytes_copied_from_remote + + let alloc = a1-a0 + to = b1-b0 + from = c1-c0 + + assertBool (printf "bytes_allocated_remote=%d, bytes_copied_to_remote=%d, bytes_copied_from_remote=%d" alloc to from) + $ (alloc P.== 0 P.&& from P.== 0 P.&& to P.== 0) P.|| + (alloc P.> 0 P.&& from P.== 4 P.&& to P.== 4) + where + xs :: (Scalar Float, Matrix Float) + xs = runN $ T2 (unit 0) (fill (constant $ Z:.10000:.10000) 1) + + go :: Arrays a => a -> a + go = runN f + where + f :: Arrays a => Acc a -> Acc a + f = id + +-- internals +foreign import ccall "&__total_bytes_allocated_remote" __total_bytes_allocated_remote :: Atomic +foreign import ccall "&__total_bytes_copied_to_remote" __total_bytes_copied_to_remote :: Atomic +foreign import ccall "&__total_bytes_copied_from_remote" __total_bytes_copied_from_remote :: Atomic + +#endif + From 9251a9fc5895642753e9930642732373c399d0e0 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 4 Jun 2019 13:08:26 +0200 Subject: [PATCH 052/316] nofix: improve test for #437 --- .../Accelerate/Test/NoFib/Issues/Issue437.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs index 46e1d67b8..1f34ff7ac 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs @@ -48,7 +48,9 @@ test_issue437 runN c0 <- Atomic.read __total_bytes_copied_from_remote let (a,_) = go xs - a `seq` return () + + -- check the final result is actually transferred back + a @?= fromList Z [42] a1 <- Atomic.read __total_bytes_allocated_remote b1 <- Atomic.read __total_bytes_copied_to_remote @@ -58,12 +60,19 @@ test_issue437 runN to = b1-b0 from = c1-c0 + -- Either: + -- a) this is a local memory backend; no transfer takes place + -- + -- b) this is a remote memory backend; we should only transfer the 4 bytes + -- to the device for the 'unit', but since the data is already on the + -- host we can avoid the transfer back + -- assertBool (printf "bytes_allocated_remote=%d, bytes_copied_to_remote=%d, bytes_copied_from_remote=%d" alloc to from) - $ (alloc P.== 0 P.&& from P.== 0 P.&& to P.== 0) P.|| - (alloc P.> 0 P.&& from P.== 4 P.&& to P.== 4) + $ (alloc P.== 0 P.&& to P.== 0 P.&& from P.== 0) P.|| -- local memory space + (alloc P.> 0 P.&& to P.== 4 P.&& from P.== 0) -- remote memory space where xs :: (Scalar Float, Matrix Float) - xs = runN $ T2 (unit 0) (fill (constant $ Z:.10000:.10000) 1) + xs = runN $ T2 (unit 42) (fill (constant $ Z:.10000:.10000) 1) go :: Arrays a => a -> a go = runN f From 34353c9a51c3dadaacc1763804461b1706a19fd1 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 13 Jun 2019 17:55:02 +0200 Subject: [PATCH 053/316] add lift instances for 16-tuples --- src/Data/Array/Accelerate/Lift.hs | 38 +++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 902f6d22b..549e07caa 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -455,6 +455,20 @@ 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, Exp k, Exp l, Exp m, Exp n, Exp o) where unlift = untup15 +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, Lift Exp p, + 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), Elt (Plain p)) + => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + = (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, Plain p) + lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + = tup16 (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, lift p) + +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) + => 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, Exp p) where + unlift = untup16 + -- Instances for Arrays class @@ -634,6 +648,20 @@ 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, Acc h, Acc i, Acc j, Acc k, Acc l, Acc m, Acc n, Acc o) where unlift = unatup15 +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, Lift Acc p, + 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), Arrays (Plain p)) + => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + = (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, Plain p) + lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + = atup16 (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, lift p) + +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) + => 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, Acc p) where + unlift = unatup16 + {-- -- Instances for Seq @@ -750,5 +778,15 @@ instance (Lift Seq a, Lift Seq b, Lift Seq c, Lift Seq d, Lift Seq e, Lift Seq f = (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) + +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, Lift Seq p, + 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), Arrays (Plain p)) + => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where + type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + = (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, Plain p) + lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + = stup16 (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, lift p) --} From 885bdf1ab270b3d62c4aad2f06a5d863b3a4c937 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 14 Jun 2019 15:20:20 +0200 Subject: [PATCH 054/316] add haddock module descriptions --- src/Data/Array/Accelerate.hs | 1 + src/Data/Array/Accelerate/Interpreter.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 2f3b6f37f..b042c4c25 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate +-- Description : The Accelerate standard prelude -- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index f67addbf0..a36c66d4c 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -16,6 +16,7 @@ {-# OPTIONS_HADDOCK prune #-} -- | -- Module : Data.Array.Accelerate.Interpreter +-- Description : Reference backend (interpreted) -- Copyright : [2008..2019] The Accelerate Team -- License : BSD3 -- From 6ba668face6a9afbc02bf157ca910b48d412b198 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 14 Jun 2019 15:20:39 +0200 Subject: [PATCH 055/316] stack/8.6: upgrade to lts-13.25 --- stack-8.6.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-8.6.yaml b/stack-8.6.yaml index 9f62750bb..6833b379c 100644 --- a/stack-8.6.yaml +++ b/stack-8.6.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-13.20 +resolver: lts-13.25 packages: - . From 4d37ce411404b4eb4eab79618d8318aa75f566f5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 20 Jun 2019 15:19:47 +0200 Subject: [PATCH 056/316] comment --- cbits/monitoring.c | 1 + 1 file changed, 1 insertion(+) diff --git a/cbits/monitoring.c b/cbits/monitoring.c index 4edcb29f7..dd2c7d1be 100644 --- a/cbits/monitoring.c +++ b/cbits/monitoring.c @@ -35,6 +35,7 @@ int64_t __total_bytes_evicted_from_remote = 0; int64_t __num_remote_gcs = 0; int64_t __num_evictions = 0; +/* cbits/flags.c */ extern __flags_t __cmd_line_flags; #if defined(ACCELERATE_DEBUG) From d76d07be131feafb21590ad4d716c7a0992e19e4 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 20 Jun 2019 21:01:10 +0200 Subject: [PATCH 057/316] add flag -f[no-]inplace --- accelerate.cabal | 2 + cbits/flags.c | 4 +- cbits/flags.h | 1 + src/Data/Array/Accelerate/Debug/Flags.hs | 82 ++++++++++++------------ 4 files changed, 48 insertions(+), 41 deletions(-) diff --git a/accelerate.cabal b/accelerate.cabal index 1c979b2af..46bb545c6 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -155,6 +155,8 @@ Flag debug * @fusion@: Enable array fusion (True). . * @simplify@: Enable program simplification phase (True). + . + * @inplace@: Enable in-place array updates (True). . * @flush-cache@: Clear any persistent caches on program startup (False). . diff --git a/cbits/flags.c b/cbits/flags.c index 4600fbdb5..d2f55bd34 100644 --- a/cbits/flags.c +++ b/cbits/flags.c @@ -56,6 +56,7 @@ static const struct option longopts[] = , { "fexp-sharing", no_argument, NULL, OPT_ENABLE } , { "ffusion", no_argument, NULL, OPT_ENABLE } , { "fsimplify", no_argument, NULL, OPT_ENABLE } + , { "finplace", no_argument, NULL, OPT_ENABLE } , { "ffast-math", no_argument, NULL, OPT_ENABLE } , { "fflush-cache", no_argument, NULL, OPT_ENABLE } , { "fforce-recomp", no_argument, NULL, OPT_ENABLE } @@ -83,6 +84,7 @@ static const struct option longopts[] = , { "fno-exp-sharing", no_argument, NULL, OPT_DISABLE } , { "fno-fusion", no_argument, NULL, OPT_DISABLE } , { "fno-simplify", no_argument, NULL, OPT_DISABLE } + , { "fno-inplace", no_argument, NULL, OPT_DISABLE } , { "fno-fast-math", no_argument, NULL, OPT_DISABLE } , { "fno-flush-cache", no_argument, NULL, OPT_DISABLE } , { "fno-force-recomp", no_argument, NULL, OPT_DISABLE } @@ -121,7 +123,7 @@ static void parse_options(int argc, char *argv[]) break; case OPT_DISABLE: - __cmd_line_flags.bitfield &= ~(1 << (longindex - 25)); // SEE: [layout of command line options bitfield] + __cmd_line_flags.bitfield &= ~(1 << (longindex - 26)); // SEE: [layout of command line options bitfield] break; /* attempt to decode the argument to flags which require them */ diff --git a/cbits/flags.h b/cbits/flags.h index 0c6a41fe0..2c13e997e 100644 --- a/cbits/flags.h +++ b/cbits/flags.h @@ -22,6 +22,7 @@ typedef union { uint32_t exp_sharing : 1; uint32_t fusion : 1; uint32_t simplify : 1; + uint32_t inplace : 1; uint32_t fast_math : 1; uint32_t flush_cache : 1; uint32_t force_recomp : 1; diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index d7e7c973c..c072454dc 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -73,26 +73,27 @@ instance Show Flag where 2 -> "exp-sharing" 3 -> "fusion" 4 -> "simplify" - 5 -> "fast-math" - 6 -> "flush_cache" - 7 -> "force-recomp" - 8 -> "debug" - 9 -> "verbose" - 10 -> "dump-phases" - 11 -> "dump-sharing" - 12 -> "dump-fusion" - 13 -> "dump-simpl_stats" - 14 -> "dump-simpl_iterations" - 15 -> "dump-vectorisation" - 16 -> "dump-dot" - 17 -> "dump-simpl_dot" - 18 -> "dump-gc" - 19 -> "dump-gc_stats" - 20 -> "dump-cc" - 21 -> "dump-ld" - 22 -> "dump-asm" - 23 -> "dump-exec" - 24 -> "dump-sched" + 5 -> "inplace" + 6 -> "fast-math" + 7 -> "flush_cache" + 8 -> "force-recomp" + 9 -> "debug" + 10 -> "verbose" + 11 -> "dump-phases" + 12 -> "dump-sharing" + 13 -> "dump-fusion" + 14 -> "dump-simpl_stats" + 15 -> "dump-simpl_iterations" + 16 -> "dump-vectorisation" + 17 -> "dump-dot" + 18 -> "dump-simpl_dot" + 19 -> "dump-gc" + 20 -> "dump-gc_stats" + 21 -> "dump-cc" + 22 -> "dump-ld" + 23 -> "dump-asm" + 24 -> "dump-exec" + 25 -> "dump-sched" _ -> show x -- | Conditional execution of a monadic debugging expression. @@ -176,27 +177,28 @@ acc_sharing = Flag 1 -- recover sharing of array computations exp_sharing = Flag 2 -- recover sharing of scalar expressions array_fusion = Flag 3 -- fuse array expressions simplify = Flag 4 -- simplify scalar expressions -fast_math = Flag 5 -- delete persistent compilation cache(s) -flush_cache = Flag 6 -- force recompilation of array programs -force_recomp = Flag 7 -- use faster, less precise math library operations +inplace = Flag 5 -- allow (safe) in-place array updates +fast_math = Flag 6 -- delete persistent compilation cache(s) +flush_cache = Flag 7 -- force recompilation of array programs +force_recomp = Flag 8 -- use faster, less precise math library operations -- These debugging flags are disable by default and are enabled with @-d@ -- -debug = Flag 8 -- compile code with debugging symbols (-g) -verbose = Flag 9 -- be very chatty -dump_phases = Flag 10 -- print information about each phase of the compiler -dump_sharing = Flag 11 -- sharing recovery phase -dump_fusion = Flag 12 -- array fusion phase -dump_simpl_stats = Flag 13 -- statistics form fusion/simplification -dump_simpl_iterations = Flag 14 -- output from each simplifier iteration -dump_vectorisation = Flag 15 -- output from the vectoriser -dump_dot = Flag 16 -- generate dot output of the program -dump_simpl_dot = Flag 17 -- generate simplified dot output -dump_gc = Flag 18 -- trace garbage collector -dump_gc_stats = Flag 19 -- print final GC statistics -dump_cc = Flag 20 -- trace code generation & compilation -dump_ld = Flag 21 -- trace runtime linker -dump_asm = Flag 22 -- trace assembler -dump_exec = Flag 23 -- trace execution -dump_sched = Flag 24 -- trace scheduler +debug = Flag 9 -- compile code with debugging symbols (-g) +verbose = Flag 10 -- be very chatty +dump_phases = Flag 11 -- print information about each phase of the compiler +dump_sharing = Flag 12 -- sharing recovery phase +dump_fusion = Flag 13 -- array fusion phase +dump_simpl_stats = Flag 14 -- statistics form fusion/simplification +dump_simpl_iterations = Flag 15 -- output from each simplifier iteration +dump_vectorisation = Flag 16 -- output from the vectoriser +dump_dot = Flag 17 -- generate dot output of the program +dump_simpl_dot = Flag 18 -- generate simplified dot output +dump_gc = Flag 19 -- trace garbage collector +dump_gc_stats = Flag 20 -- print final GC statistics +dump_cc = Flag 21 -- trace code generation & compilation +dump_ld = Flag 22 -- trace runtime linker +dump_asm = Flag 23 -- trace assembler +dump_exec = Flag 24 -- trace execution +dump_sched = Flag 25 -- trace scheduler From b689c38169b2052e33d0ebc2119131dea29c06f4 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 21 Jun 2019 19:37:56 +0200 Subject: [PATCH 058/316] add extra debug stats --- src/Data/Array/Accelerate/Trafo/Shrink.hs | 4 ++-- .../Array/Accelerate/Trafo/Substitution.hs | 20 +++++++++---------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 346e8566a..c56cd30c5 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -72,7 +72,7 @@ instance Kit acc => Shrink (PreOpenFun acc env aenv f) where -- (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 +shrinkExp = Stats.substitution "shrinkE" . 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 @@ -152,7 +152,7 @@ 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 +shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrinkA" shrinkA where shrinkA :: PreOpenAcc acc aenv' a -> PreOpenAcc acc aenv' a shrinkA pacc = case pacc of diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index dd768b5d9..29d5232c1 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -171,22 +171,22 @@ type RebuildableAcc acc = (Rebuildable acc, AccClo acc ~ acc) instance RebuildableAcc acc => Rebuildable (PreOpenExp acc env) where type AccClo (PreOpenExp acc env) = acc {-# INLINEABLE rebuildPartial #-} - rebuildPartial = rebuildPreOpenExp rebuildPartial (pure . IE) + rebuildPartial x = Stats.substitution "rebuild" $ rebuildPreOpenExp rebuildPartial (pure . IE) x instance RebuildableAcc acc => Rebuildable (PreOpenFun acc env) where type AccClo (PreOpenFun acc env) = acc {-# INLINEABLE rebuildPartial #-} - rebuildPartial = rebuildFun rebuildPartial (pure . IE) + rebuildPartial x = Stats.substitution "rebuild" $ rebuildFun rebuildPartial (pure . IE) x instance RebuildableAcc acc => Rebuildable (PreOpenAcc acc) where type AccClo (PreOpenAcc acc) = acc {-# INLINEABLE rebuildPartial #-} - rebuildPartial = rebuildPreOpenAcc rebuildPartial + rebuildPartial x = Stats.substitution "rebuild" $ rebuildPreOpenAcc rebuildPartial x instance RebuildableAcc acc => Rebuildable (PreOpenAfun acc) where type AccClo (PreOpenAfun acc) = acc {-# INLINEABLE rebuildPartial #-} - rebuildPartial = rebuildAfun rebuildPartial + rebuildPartial x = Stats.substitution "rebuild" $ rebuildAfun rebuildPartial x -- Tuples have to be handled specially. newtype RebuildTup acc env aenv t = RebuildTup { unRTup :: Tuple (PreOpenExp acc env aenv) t } @@ -194,20 +194,20 @@ newtype RebuildTup acc env aenv t = RebuildTup { unRTup :: Tuple (PreOpenExp acc 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) + rebuildPartial v t = Stats.substitution "rebuild" . RebuildTup <$> rebuildTup rebuildPartial (pure . IE) v (unRTup t) instance Rebuildable OpenAcc where type AccClo OpenAcc = OpenAcc {-# INLINEABLE rebuildPartial #-} - rebuildPartial = rebuildOpenAcc + rebuildPartial x = Stats.substitution "rebuild" $ rebuildOpenAcc x instance RebuildableAcc acc => RebuildableExp (PreOpenExp acc) where {-# INLINEABLE rebuildPartialE #-} - rebuildPartialE v = rebuildPreOpenExp rebuildPartial v (pure . IA) + rebuildPartialE v x = Stats.substitution "rebuild" $ rebuildPreOpenExp rebuildPartial v (pure . IA) x instance RebuildableAcc acc => RebuildableExp (PreOpenFun acc) where {-# INLINEABLE rebuildPartialE #-} - rebuildPartialE v = rebuildFun rebuildPartial v (pure . IA) + rebuildPartialE v x = Stats.substitution "rebuild" $ rebuildFun rebuildPartial v (pure . IA) x -- NOTE: [Weakening] -- @@ -321,11 +321,11 @@ 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) +strengthen k x = Stats.substitution "strengthen" $ rebuildPartial (fmap IA . k) x {-# INLINEABLE strengthenE #-} strengthenE :: RebuildableExp f => env :?> env' -> f env aenv t -> Maybe (f env' aenv t) -strengthenE k = rebuildPartialE (fmap IE . k) +strengthenE k x = Stats.substitution "strengthenE" $ rebuildPartialE (fmap IE . k) x -- Simultaneous Substitution =================================================== -- From f26faa6a38bf97ca6a94456d34396d45e41c0948 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 21 Jun 2019 20:07:28 +0200 Subject: [PATCH 059/316] leave terms at their lowest common use site The motivation is that we can determine when it is safe to in-place update arrays as a straightforward syntactic check. The disadvantage is that this removes the invariant that the arguments to terms have been evaluated already (that is, applied as array variables). SEE: [Fusion and the lowest common use site] AccelerateHS/accelerate#432 --- src/Data/Array/Accelerate/Interpreter.hs | 6 +- src/Data/Array/Accelerate/Pretty.hs | 16 +- src/Data/Array/Accelerate/Trafo/Fusion.hs | 271 +++++++++++++++------- 3 files changed, 187 insertions(+), 106 deletions(-) diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index a36c66d4c..0f612cac7 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -67,7 +67,7 @@ import Data.Typeable import System.IO.Unsafe ( unsafePerformIO ) import Text.Printf ( printf ) import Unsafe.Coerce -import Prelude hiding ( sum ) +import Prelude hiding ( (!!), sum ) -- friends import Data.Array.Accelerate.AST hiding ( Boundary, PreBoundary(..) ) @@ -180,9 +180,9 @@ evalOpenAcc (AST.Manifest pacc) aenv = 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 :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e) -> Delayed (Array sh e) delayed AST.Delayed{..} = Delayed (evalE extentD) (evalF indexD) (evalF linearIndexD) + delayed (manifest -> a) = Delayed (shape a) (a!) (a!!) evalE :: DelayedExp aenv t -> t evalE exp = evalPreExp evalOpenAcc exp aenv diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index 98042967d..5784828b5 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -158,21 +158,7 @@ extractOpenAcc (OpenAcc pacc) = pacc prettyDelayedOpenAcc :: PrettyAcc DelayedOpenAcc prettyDelayedOpenAcc context aenv (Manifest pacc) = prettyPreOpenAcc context prettyDelayedOpenAcc extractDelayedOpenAcc aenv pacc -prettyDelayedOpenAcc context aenv (Delayed sh f _) - | Shape a <- sh - , Just Refl <- match f (Lam (Body (Index a (Var ZeroIdx)))) - = prettyDelayedOpenAcc context aenv a - -- - -- 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 - -- - | otherwise +prettyDelayedOpenAcc _ aenv (Delayed sh f _) = parens $ nest shiftwidth $ sep [ delayed "delayed" diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 1a4aa90de..80b193046 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} @@ -131,17 +132,18 @@ convertOpenAcc config = manifest config . computeAcc . embedOpenAcc config -- will put producers adjacent to the term consuming it. -- delayed :: (Shape sh, Elt e) => Config -> OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e) -delayed config (embedOpenAcc config -> 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) +delayed config (embedOpenAcc config -> Embed env cc) + | BaseEnv <- env + = case simplify cc of + Done v -> avarIn 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) + -- + | otherwise + = manifest config (computeAcc (Embed env cc)) where cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t cvtE = convertOpenExp config @@ -150,6 +152,7 @@ delayed config (embedOpenAcc config -> Embed BaseEnv cc) = cvtF (Lam f) = Lam (cvtF f) cvtF (Body b) = Body (cvtE b) + -- Convert array programs as manifest terms. -- manifest :: Config -> OpenAcc aenv a -> DelayedOpenAcc aenv a @@ -173,10 +176,10 @@ manifest config (OpenAcc pacc) = -- 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. + -- 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 a evaluated array term, else something went wrong. -- Map f a -> Map (cvtF f) (delayed config a) Generate sh f -> Generate (cvtE sh) (cvtF f) @@ -191,10 +194,9 @@ manifest config (OpenAcc pacc) = -- 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. + -- Embed producers directly into the representation. For delayed terms + -- with local bindings, these will have been floated up above the + -- consumer already -- Fold f z a -> Fold (cvtF f) (cvtE z) (delayed config a) Fold1 f a -> Fold1 (cvtF f) (delayed config a) @@ -463,7 +465,10 @@ embedPreAcc config embedAcc elimAcc pacc unembed :: Embed acc aenv arrs -> Embed acc aenv arrs unembed x | array_fusion `member` options config = x - | otherwise = done (compute x) + | Embed env cc <- x + = case compute cc of + Avar v -> Embed env (Done v) + pacc -> Embed (env `PushEnv` inject pacc) (Done ZeroIdx) cvtA :: Arrays a => acc aenv' a -> acc aenv' a cvtA = computeAcc . embedAcc @@ -480,7 +485,7 @@ embedPreAcc config embedAcc elimAcc pacc -- permute f p d a = Permute f d p a - -- Note: [Stencil fusion] + -- NOTE: [Stencil fusion] -- -- We allow stencils to delay their argument arrays with no special -- considerations. This means that the delayed function will be evaluated @@ -520,6 +525,11 @@ embedPreAcc config embedAcc elimAcc pacc => (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) + -- Operations which can be fused into consumers. Move all of the local + -- bindings out of the way so that the fusible function operates + -- directly on the delayed representation. See also: [Representing + -- delayed arrays] + -- fuse :: Arrays as => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs) -> acc aenv as @@ -537,44 +547,86 @@ embedPreAcc config embedAcc elimAcc pacc , env <- env1 `append` env0 = Embed env (op env (sink env0 cc1) cc0) + -- Consumer operations which will be evaluated. + -- + -- NOTE: [Fusion and the lowest common use site] + -- + -- The AST given to us by sharing recovery will place let bindings at + -- the lowest common use site for that shared term. For example: + -- + -- fold f z (let a0 = .. + -- a1 = .. + -- in zipWith g a0 a1) + -- + -- In order to enable producer/consumer fusion for the above example, + -- it is necessary to float the let bindings above the `fold` + -- operation; SEE: [Sharing vs. Fusion] for more information. + -- + -- Furthermore, we used to maintain an invariant that all (manifest) + -- arguments were supplied as array variables, for example: + -- + -- fold1 f (let a0 = .. let a0 = .. + -- in stencil g a0) ==> a1 = stencil g a0 + -- a2 = fold1 f a1 + -- + -- However, if the argument term will be evaluated (i.e. can not be + -- fused into the producer) then it is better that we do _not_ float + -- those terms, and instead leave them under the consumer. This helps + -- to syntactically constrain the "liveness" of terms: if the argument + -- to an operation is not an array variable, we can see directly that + -- this will be the last use-site of that array. In particular, this is + -- useful for the 'permute' operation to know when it can in-place + -- update the array of default values. + -- 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 + embed op (embedAcc -> Embed env cc) + | Done{} <- cc = Embed (BaseEnv `PushEnv` inject (op BaseEnv (computeAcc (Embed env cc)))) (Done ZeroIdx) + | otherwise = Embed (env `PushEnv` inject (op env (inject (compute cc)))) (Done ZeroIdx) - embed2 :: forall aenv as bs cs. (Arrays as, Arrays bs, Arrays cs) + embed2 :: (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) + embed2 op (embedAcc -> Embed env1 cc1) a0 + | Done{} <- cc1 + , a1 <- computeAcc (Embed env1 cc1) + = embed (\env0 -> op env0 (sink env0 a1)) a0 + -- + | Embed env0 cc0 <- embedAcc (sink env1 a0) + , env <- env1 `append` env0 + = case cc0 of + Done{} -> Embed (env1 `PushEnv` inject (op env1 (inject (compute cc1)) (computeAcc (Embed env0 cc0)))) (Done ZeroIdx) + _ -> Embed (env `PushEnv` inject (op env (inject (compute (sink env0 cc1))) (inject (compute cc0)))) (Done ZeroIdx) + + -- 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 :: (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) + -- | 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 @@ -617,7 +669,7 @@ embedSeq embedAcc s -> 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))) + = 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) @@ -669,7 +721,7 @@ data ExtendProducer acc aenv senv arrs where -- Internal representation -- ======================= --- Note: [Representing delayed array] +-- NOTE: [Representing delayed arrays] -- -- During the fusion transformation we represent terms as a pair consisting of -- a collection of supplementary environment bindings and a description of how @@ -745,9 +797,14 @@ data Cunctation acc aenv a where 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 + simplify = \case + Done v -> Done v + Yield (simplify -> sh) (simplify -> f) -> Yield sh f + Step (simplify -> sh) (simplify -> p) (simplify -> f) v + | Just Refl <- match sh (arrayShape v) + , Just Refl <- isIdentity p + , Just Refl <- isIdentity f -> Done v + | otherwise -> Step sh p f v -- Convert a real AST node into the internal representation @@ -805,7 +862,7 @@ accType _ = arrays @a -- ======================== instance Kit acc => Sink (Cunctation acc) where - weaken k cc = case cc of + weaken k = \case 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) @@ -864,30 +921,68 @@ instance Kit acc => Sink (SinkSeq acc senv) where -- 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 -- +-- We do a bit of extra work to maintain that terms should be left at their +-- lowest common use site. SEE: [Fusion and the lowest common use site] +-- computeAcc :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> acc aenv arrs -computeAcc = inject . compute +computeAcc (Embed BaseEnv cc) = inject (compute cc) +computeAcc (Embed env@(PushEnv bot top) cc) = + case simplify cc of + Done v -> bindA env (avarIn v) + Yield sh f -> bindA env (inject (Generate sh f)) + Step sh p f v + | Just Refl <- match sh (arrayShape v) + , Just Refl <- isIdentity p + -> case v of + ZeroIdx + | Just g <- strengthen noTop f -> bindA bot (inject (Map g top)) + _ -> bindA env (inject (Map f (avarIn v))) + + | Just Refl <- isIdentity f + -> case v of + ZeroIdx + | Just q <- strengthen noTop p + , Just sz <- strengthen noTop sh -> bindA bot (inject (Backpermute sz q top)) + _ -> bindA env (inject (Backpermute sh p (avarIn v))) + + | otherwise + -> case v of + ZeroIdx + | Just g <- strengthen noTop f + , Just q <- strengthen noTop p + , Just sz <- strengthen noTop sh -> bindA bot (inject (Transform sz q g top)) + _ -> bindA env (inject (Transform sh p f (avarIn v))) + + where + bindA :: (Kit acc, Arrays a) + => Extend acc aenv aenv' + -> acc aenv' a + -> acc aenv a + bindA BaseEnv b = b + bindA (PushEnv env a) b = + case extract b of + Just (Avar ZeroIdx) -> bindA env a + _ -> bindA env (inject (Alet a b)) + + noTop :: (aenv, a) :?> aenv + noTop ZeroIdx = Nothing + noTop (SuccIdx ix) = Just ix + + +-- Convert 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) => 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 (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) -- Representation of a generator as a delayed array @@ -921,11 +1016,11 @@ mapD f (Embed env cc) -- 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 +-- map (\x -> fst . fst ... x) arr -- -- into multiple stages so that they can all be executed in constant time: -- --- > map fst . map fst ... arr +-- 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 @@ -1132,8 +1227,8 @@ zipWithD f cc1 cc0 -- 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 +-- reverse xs = let len = unindex1 (shape xs) +-- pf i = len - i - 1 -- in -- backpermute (shape xs) (ilift1 pf) xs -- @@ -1147,7 +1242,7 @@ zipWithD f cc1 cc0 -- 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 +-- be beneficial if we can estimate that the cost of re-computation is less than -- the cost of completely evaluating the array and subsequently retrieving the -- data from memory. -- @@ -1215,10 +1310,10 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) -- 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 + | acc1 <- computeAcc (Embed env1 cc1) + , False <- elimAcc acc1 acc0 = Stats.ruleFired "aletD/bind" - $ Embed (BaseEnv `PushEnv` inject acc1 `append` env0) cc0 + $ Embed (BaseEnv `PushEnv` acc1 `append` env0) cc0 -- let-elimination -- --------------- @@ -1226,11 +1321,11 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) -- 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 + | acc0' <- sink1 env1 acc0 = Stats.ruleFired "aletD/eliminate" $ case cc1 of - Step{} -> eliminate env1 cc1 acc0' - Yield{} -> eliminate env1 cc1 acc0' + Step{} -> eliminate env1 cc1 acc0' + Yield{} -> eliminate env1 cc1 acc0' where acc0 :: acc (aenv, arrs) brrs @@ -1251,13 +1346,13 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) | Yield sh1 f1 <- cc1 = elim sh1 f1 where bnd :: PreOpenAcc acc aenv' (Array sh e) - bnd = compute' cc1 + 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 + | 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 From b0704723c4439f197bbca965176652688c028931 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 22 Jun 2019 14:28:45 +0200 Subject: [PATCH 060/316] pretty: fix wrapping of alet as arguments to terms --- src/Data/Array/Accelerate/Pretty/Print.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index d94eddcbb..20334e648 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -126,7 +126,7 @@ prettyPreOpenAcc prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = case pacc of Avar idx -> prj idx aenv - Alet{} -> prettyAlet prettyAcc extractAcc aenv pacc + Alet{} -> prettyAlet ctx prettyAcc extractAcc aenv pacc Atuple tup -> prettyAtuple prettyAcc aenv tup Apply f a -> apply where @@ -206,12 +206,15 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = prettyAlet :: forall acc aenv arrs. - PrettyAcc acc + Context + -> PrettyAcc acc -> ExtractAcc acc -> Val aenv -> PreOpenAcc acc aenv arrs -> Adoc -prettyAlet prettyAcc extractAcc aenv0 = align . wrap . collect aenv0 +prettyAlet ctx prettyAcc extractAcc aenv0 + = parensIf (needsParens ctx "let") + . align . wrap . collect aenv0 where collect :: Val aenv' -> PreOpenAcc acc aenv' a -> ([Adoc], Adoc) collect aenv = From d53180e03451e6b95a083ff382d84058ea1b9d7c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 23 Jun 2019 17:41:15 +0200 Subject: [PATCH 061/316] export debug flag --- src/Data/Array/Accelerate/Debug/Flags.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index c072454dc..0f9cb6cc6 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -27,7 +27,7 @@ module Data.Array.Accelerate.Debug.Flags ( setValue, Flag(..), - seq_sharing, acc_sharing, exp_sharing, array_fusion, simplify, flush_cache, force_recomp, + seq_sharing, acc_sharing, exp_sharing, array_fusion, simplify, inplace, 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, From e6b30e20475c5253492e9f00d20400f248dab8d2 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 24 Jun 2019 11:18:06 +0200 Subject: [PATCH 062/316] wibble --- src/Data/Array/Accelerate/Trafo/Fusion.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 80b193046..a45e5af2d 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -923,8 +923,8 @@ instance Kit acc => Sink (SinkSeq acc senv) where -- Evaluate a delayed computation and tie the recursive knot -- --- We do a bit of extra work to maintain that terms should be left at their --- lowest common use site. SEE: [Fusion and the lowest common use site] +-- We do a bit of extra work to (try to) maintain that terms should be left +-- at their lowest common use site. SEE: [Fusion and the lowest common use site] -- computeAcc :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> acc aenv arrs computeAcc (Embed BaseEnv cc) = inject (compute cc) @@ -1140,7 +1140,7 @@ reshapeD -> PreExp acc aenv sl -> Embed acc aenv (Array sl e) reshapeD (Embed env cc) (sink env -> sl) - | Done v <- cc + | Done v <- cc = Embed (env `PushEnv` inject (Reshape sl (avarIn v))) (Done ZeroIdx) | otherwise From 42aa50c743620cfd50b40948d0f40b122ea1e45b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 24 Jun 2019 11:18:10 +0200 Subject: [PATCH 063/316] moar simplify --- src/Data/Array/Accelerate/Trafo/Fusion.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index a45e5af2d..fbb1298a3 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -1646,7 +1646,7 @@ restrict :: (Kit acc, Shape sh, Shape sl, Elt slix) 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 +arrayShape = simplify . 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))) From 27a13986d4fc87eaea853b8517475e19bd11fc94 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 26 Jun 2019 11:51:40 +0200 Subject: [PATCH 064/316] update .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 1cb7d6a43..5ab8a2309 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ /accelerate-io/dist/ /.stack-work /stack.yaml +/stack.yaml.lock From b17a427994eb61efc935c4aa85dd10286e07fc40 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 26 Jun 2019 13:35:32 +0200 Subject: [PATCH 065/316] travis: moar cache --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index b70cb1608..42d48d8d1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,9 +6,9 @@ dist: xenial cache: timeout: 600 directories: - - $HOME/.stack/snapshots + - $HOME/.stack - $HOME/.local/bin - - .stack-work/install + - $TRAVIS_BUILD_DIR/.stack-work before_cache: # - rm -vrf $(stack path --local-install-root)/bin From c1159d7303e52c191bc254d07f4c1f5116b76d45 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 26 Jun 2019 14:18:13 +0200 Subject: [PATCH 066/316] warning police --- src/Data/Array/Accelerate/Trafo.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 3cd6ed622..ba99a7ce5 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -71,11 +71,10 @@ 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 -import Data.Array.Accelerate.Debug.Flags hiding ( when ) - #ifdef ACCELERATE_DEBUG import Text.Printf import System.IO.Unsafe +import Data.Array.Accelerate.Debug.Flags hiding ( when ) import Data.Array.Accelerate.Debug.Timed #endif From 26c87ac69ac597e0192493f57b56f3e0baf0359d Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 26 Jun 2019 16:28:24 +0200 Subject: [PATCH 067/316] fix initial configuration settings --- cbits/flags.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cbits/flags.c b/cbits/flags.c index d2f55bd34..07338bb22 100644 --- a/cbits/flags.c +++ b/cbits/flags.c @@ -33,7 +33,7 @@ * corresponding behaviour. */ -__flags_t __cmd_line_flags = { 0x3f }; +__flags_t __cmd_line_flags = { 0x7f }; // SEE: [layout of command line options bitfield] HsInt __unfolding_use_threshold = 1; HsInt __max_simplifier_iterations = 25; @@ -194,7 +194,7 @@ static void parse_options(int argc, char *argv[]) } #if !defined(ACCELERATE_DEBUG) - if (__cmd_line_flags.bitfield & 0x1ffff00) { // SEE: [layout of command line options bitfield] + if (__cmd_line_flags.bitfield & 0x3fffe00) { // SEE: [layout of command line options bitfield] fprintf(stderr, "Data.Array.Accelerate: Debugging options are disabled.\n"); fprintf(stderr, "Reinstall package 'accelerate' with '-fdebug' to enable them.\n"); } From 5c2c1db205fcf1e0777ef9399959100b75e7bbec Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 26 Jun 2019 16:28:31 +0200 Subject: [PATCH 068/316] warning police --- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs index 1f34ff7ac..e377bd160 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs @@ -35,12 +35,13 @@ import Prelude as P test_issue437 :: RunN -> TestTree -test_issue437 runN #ifndef ACCELERATE_DEBUG +test_issue437 _ = expectFail $ testCase "437" $ assertFailure "This test requires building with -fdebug" #else +test_issue437 runN = testCase "437" $ do a0 <- Atomic.read __total_bytes_allocated_remote From 6ffa011435d2f66cd2fc69dc2c356f784f83ef81 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 2 Jul 2019 20:06:22 +0200 Subject: [PATCH 069/316] drop the convert-segment-offset pass MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The internal representation of FoldSeg now expects the segment descriptor to be in offset format, rather than encoding the length of each logical sub-array. The existing `foldSeg` function now unconditionally inserts the `scan` of the segment descriptor. A new `foldSeg’` takes the offset segment descriptor directly. We lose the ability to execute a sequential foldSeg without scan. We could reintroduce this by keeping track on a per-FoldSeg node basis what format the segment descriptor is in. --- accelerate.cabal | 1 - .../Accelerate/Trafo => icebox}/Rewrite.hs | 0 src/Data/Array/Accelerate.hs | 3 +- src/Data/Array/Accelerate/Interpreter.hs | 25 +++--- src/Data/Array/Accelerate/Language.hs | 50 +++++------- src/Data/Array/Accelerate/Prelude.hs | 76 +++++++++++++++++++ src/Data/Array/Accelerate/Trafo.hs | 12 +-- src/Data/Array/Accelerate/Trafo/Config.hs | 2 - 8 files changed, 114 insertions(+), 55 deletions(-) rename {src/Data/Array/Accelerate/Trafo => icebox}/Rewrite.hs (100%) diff --git a/accelerate.cabal b/accelerate.cabal index 46bb545c6..47485a87f 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -378,7 +378,6 @@ Library Data.Array.Accelerate.Trafo.Base Data.Array.Accelerate.Trafo.Config Data.Array.Accelerate.Trafo.Fusion - Data.Array.Accelerate.Trafo.Rewrite Data.Array.Accelerate.Trafo.Sharing Data.Array.Accelerate.Trafo.Shrink Data.Array.Accelerate.Trafo.Simplify diff --git a/src/Data/Array/Accelerate/Trafo/Rewrite.hs b/icebox/Rewrite.hs similarity index 100% rename from src/Data/Array/Accelerate/Trafo/Rewrite.hs rename to icebox/Rewrite.hs diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index b042c4c25..137cb67cf 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -255,7 +255,8 @@ module Data.Array.Accelerate ( fold, fold1, foldAll, fold1All, -- *** Segmented reductions - foldSeg, fold1Seg, + foldSeg, fold1Seg, + foldSeg', fold1Seg', -- *** Specialised reductions all, any, and, or, sum, product, minimum, maximum, diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 0f612cac7..ba0cac4ca 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -397,15 +397,15 @@ foldSegOp -> Delayed (Array (sh :. Int) e) -> Delayed (Segments i) -> Array (sh :. Int) e -foldSegOp f z (Delayed (sh :. _) arr _) seg@(Delayed (Z :. n) _ _) +foldSegOp f z (Delayed (sh :. _) arr _) (Delayed (Z :. n) _ seg) | IntegralDict <- integralDict (integralType :: IntegralType i) - = fromFunction (sh :. n) - $ \(sz :. ix) -> let start = fromIntegral $ offset ! (Z :. ix) - end = fromIntegral $ offset ! (Z :. ix+1) + = $boundsCheck "foldSeg" "empty segment descriptor" (n > 0) + $ fromFunction (sh :. n-1) + $ \(sz :. ix) -> let start = fromIntegral $ seg ix + end = fromIntegral $ seg (ix+1) in - iter (Z :. end-start) (\(Z:.i) -> arr (sz :. start+i)) f z - where - offset = scanlOp (+) 0 seg + $boundsCheck "foldSeg" "empty segment" (end >= start) + $ iter (Z :. end-start) (\(Z:.i) -> arr (sz :. start+i)) f z fold1SegOp @@ -414,16 +414,15 @@ fold1SegOp -> Delayed (Array (sh :. Int) e) -> Delayed (Segments i) -> Array (sh :. Int) e -fold1SegOp f (Delayed (sh :. _) arr _) seg@(Delayed (Z :. n) _ _) +fold1SegOp f (Delayed (sh :. _) arr _) (Delayed (Z :. n) _ seg) | IntegralDict <- integralDict (integralType :: IntegralType i) - = fromFunction (sh :. n) - $ \(sz :. ix) -> let start = fromIntegral $ offset ! (Z :. ix) - end = fromIntegral $ offset ! (Z :. ix+1) + = $boundsCheck "foldSeg" "empty segment descriptor" (n > 0) + $ fromFunction (sh :. n-1) + $ \(sz :. ix) -> let start = fromIntegral $ seg ix + end = fromIntegral $ seg (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 diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 60241c2b1..f643cd501 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -54,7 +54,7 @@ module Data.Array.Accelerate.Language ( -- foldSeq, foldSeqFlatten, -- * Reductions - fold, fold1, foldSeg, fold1Seg, + fold, fold1, foldSeg', fold1Seg', -- * Scan functions scanl, scanl', scanl1, scanr, scanr', scanr1, @@ -526,52 +526,42 @@ fold1 :: (Shape sh, Elt 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). +-- | Segmented reduction along the innermost dimension of an array. The +-- segment descriptor specifies the starting index (offset) along the +-- innermost dimension to the beginning of each logical sub-array. -- --- >>> let seg = fromList (Z:.4) [1,4,0,3] :: Segments Int --- >>> seg --- Vector (Z :. 4) [1,4,0,3] +-- The value in the output array at index i is the reduction of values +-- between the indices of the segment descriptor at index i and (i+1). -- --- >>> 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] +-- We have that: -- --- >>> 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 f z xs seg == foldSeg' f z xs (scanl (+) 0 seg) -- -foldSeg +-- @since 1.3.0.0 +-- +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 +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. +-- | 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 offset to the beginning of each of the logical +-- sub-arrays. +-- +-- @since 1.3.0.0 -- -fold1Seg +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 +fold1Seg' = Acc $$$ Fold1Seg -- Scan functions -- -------------- diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index ac0d8f795..762114f8b 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -40,6 +40,7 @@ module Data.Array.Accelerate.Prelude ( -- * Reductions foldAll, fold1All, + foldSeg, fold1Seg, -- ** Specialised folds all, any, and, or, sum, product, minimum, maximum, @@ -704,6 +705,81 @@ fold1All fold1All f arr = fold1 f (flatten arr) +-- | 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 + :: forall sh e i. (Shape sh, Elt e, Elt i, IsIntegral i) + => (Exp e -> Exp e -> Exp e) + -> Exp e + -> Acc (Array (sh:.Int) e) + -> Acc (Segments i) + -> Acc (Array (sh:.Int) e) +foldSeg f z arr seg = foldSeg' f z arr (scanl plus zero seg) + where + (plus, zero) = + case integralType @i of + TypeInt{} -> ((+), 0) + TypeInt8{} -> ((+), 0) + TypeInt16{} -> ((+), 0) + TypeInt32{} -> ((+), 0) + TypeInt64{} -> ((+), 0) + TypeWord{} -> ((+), 0) + TypeWord8{} -> ((+), 0) + TypeWord16{} -> ((+), 0) + TypeWord32{} -> ((+), 0) + TypeWord64{} -> ((+), 0) + + +-- | Variant of 'foldSeg' that requires /all/ segments of the reduced array +-- to be non-empty, and does not need a default value. The segment +-- descriptor species the length of each of the logical sub-arrays. +-- +fold1Seg + :: forall sh e i. (Shape sh, Elt e, Elt i, IsIntegral i) + => (Exp e -> Exp e -> Exp e) + -> Acc (Array (sh:.Int) e) + -> Acc (Segments i) + -> Acc (Array (sh:.Int) e) +fold1Seg f arr seg = fold1Seg' f arr (scanl plus zero seg) + where + (plus, zero) = + case integralType @i of + TypeInt{} -> ((+), 0) + TypeInt8{} -> ((+), 0) + TypeInt16{} -> ((+), 0) + TypeInt32{} -> ((+), 0) + TypeInt64{} -> ((+), 0) + TypeWord{} -> ((+), 0) + TypeWord8{} -> ((+), 0) + TypeWord16{} -> ((+), 0) + TypeWord32{} -> ((+), 0) + TypeWord64{} -> ((+), 0) + + -- Specialised reductions -- ---------------------- -- diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index ba99a7ce5..fd34c0242 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -56,7 +56,6 @@ module Data.Array.Accelerate.Trafo ( import Control.DeepSeq import Data.Typeable -import Data.BitSet import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Array.Sugar ( Arrays, Elt ) import Data.Array.Accelerate.Trafo.Base @@ -66,7 +65,6 @@ import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, A 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 @@ -92,7 +90,6 @@ convertAccWith :: Arrays arrs => Config -> Acc arrs -> DelayedAcc arrs convertAccWith config acc = phase "array-fusion" (Fusion.convertAccWith config) -- phase "vectorise-sequences" Vectorise.vectoriseSeqAcc `when` vectoriseSequences - $ phase "rewrite-segment-offset" Rewrite.convertSegments `when` (convert_segment_offset `member` options config) $ phase "sharing-recovery" (Sharing.convertAccWith config) $ acc @@ -107,7 +104,6 @@ convertAfunWith :: Afunction f => Config -> f -> DelayedAfun (AfunctionR f) convertAfunWith config acc = phase "array-fusion" (Fusion.convertAfunWith config) -- phase "vectorise-sequences" Vectorise.vectoriseSeqAfun `when` vectoriseSequences - $ phase "rewrite-segment-offset" Rewrite.convertSegmentsAfun `when` (convert_segment_offset `member` options config) $ phase "sharing-recovery" (Sharing.convertAfunWith config) $ acc @@ -140,15 +136,15 @@ 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 "rewrite-segment-offset" Rewrite.convertSegmentsSeq `when` convertOffsetOfSegment $ phase "sharing-recovery" (Sharing.convertSeq recoverAccSharing recoverExpSharing recoverSeqSharing floatOutAccFromExp) $ s --} -when :: (a -> a) -> Bool -> a -> a -when f True = f -when _ False = id +-- when :: (a -> a) -> Bool -> a -> a +-- when f True = f +-- when _ False = id -- Debugging -- --------- diff --git a/src/Data/Array/Accelerate/Trafo/Config.hs b/src/Data/Array/Accelerate/Trafo/Config.hs index c0f45e8d8..0ba9fb291 100644 --- a/src/Data/Array/Accelerate/Trafo/Config.hs +++ b/src/Data/Array/Accelerate/Trafo/Config.hs @@ -17,7 +17,6 @@ module Data.Array.Accelerate.Trafo.Config ( defaultOptions, -- Other options not controlled by the command line flags - convert_segment_offset, float_out_acc, ) where @@ -47,6 +46,5 @@ defaultOptions = unsafePerformIO $! -- Extra options not covered by command line flags -- -convert_segment_offset = Flag 30 -- TLM: let's remove the need for this float_out_acc = Flag 31 From ff520d5c1d29b94c88f313cad583f928d35536b0 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 12 Jul 2019 14:05:49 +0200 Subject: [PATCH 070/316] add Eq and Ord instance for Shapes --- src/Data/Array/Accelerate/Classes/Eq.hs | 9 +++++++ src/Data/Array/Accelerate/Classes/Ord.hs | 34 ++++++++++++++++++++---- src/Data/Array/Accelerate/Language.hs | 18 ------------- src/Data/Array/Accelerate/Smart.hs | 21 +++++++++++++++ 4 files changed, 59 insertions(+), 23 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 5ff000dd8..276f77f28 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Eq @@ -183,6 +184,14 @@ instance Eq CDouble where (==) = lift2 mkEq (/=) = lift2 mkNEq +instance Eq Z where + (==) _ _ = constant True + (/=) _ _ = constant False + +instance Eq sh => Eq (sh :. Int) where + x == y = indexHead x == indexHead y && indexTail x == indexTail y + x /= y = indexHead x /= indexHead y || indexTail x /= indexTail y + instance (Eq a, Eq b) => Eq (a, b) where x == y = let (a1,b1) = untup2 x (a2,b2) = untup2 y diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 4f1a4f4b9..095615a8d 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Ord @@ -20,6 +23,7 @@ module Data.Array.Accelerate.Classes.Ord ( ) where +import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -27,7 +31,7 @@ import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Eq import Text.Printf -import Prelude ( ($), (.), Ordering(..), String, error, unlines ) +import Prelude ( ($), (.), Ordering(..), Maybe(..), String, error, unlines ) import qualified Prelude as P @@ -299,6 +303,26 @@ instance Ord CDouble where min = lift2 mkMin max = lift2 mkMax +instance Ord Z where + (<) _ _ = constant False + (>) _ _ = constant False + (<=) _ _ = constant True + (>=) _ _ = constant True + min _ _ = constant Z + max _ _ = constant Z + +instance Ord sh => Ord (sh :. Int) where + x <= y = indexHead x <= indexHead y && indexTail x <= indexTail y + x >= y = indexHead x >= indexHead y && indexTail x >= indexTail y + x < y = indexHead x < indexHead y + && case matchTupleType (eltType @sh) (eltType @Z) of + Just Refl -> constant True + Nothing -> indexTail x < indexTail y + x > y = indexHead x > indexHead y + && case matchTupleType (eltType @sh) (eltType @Z) of + Just Refl -> constant True + Nothing -> indexTail x > indexTail y + instance (Ord a, Ord b) => Ord (a, b) where x <= y = let (a1,b1) = untup2 x (a2,b2) = untup2 y diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 60241c2b1..a13c2a1d0 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1218,24 +1218,6 @@ 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 :: (Elt sh, Elt a) => Exp (sh :. a) -> Exp a -indexHead = Exp . IndexHead - --- | Get all but the innermost element of a shape --- -indexTail :: (Elt 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. -- diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index c418067c1..d627f01fd 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -32,6 +32,9 @@ module Data.Array.Accelerate.Smart ( -- * Smart constructors for literals constant, undef, + -- * Smart destructors for shapes + indexHead, indexTail, + -- * 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, @@ -1499,6 +1502,24 @@ constant = Exp . Const undef :: Elt t => Exp t undef = Exp Undef +-- | 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 :: (Elt sh, Elt a) => Exp (sh :. a) -> Exp a +indexHead = Exp . IndexHead + +-- | Get all but the innermost element of a shape +-- +indexTail :: (Elt sh, Elt a) => Exp (sh :. a) -> Exp sh +indexTail = Exp . IndexTail + -- Smart constructor and destructors for scalar tuples -- tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b) From 0dc2cf1b8c608b3b37dcac4d4478f2502693d30d Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 12 Jul 2019 14:08:57 +0200 Subject: [PATCH 071/316] moar simplify --- src/Data/Array/Accelerate/Trafo/Algebra.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index 87370661a..9ffd57c2e 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -732,6 +732,10 @@ evalLAnd (untup2 -> Just (x,y)) env = Just $ if a then Stats.ruleFired "True &&" y else Stats.ruleFired "False &&" $ Const (fromElt False) + | Just b <- propagate env y + = Just $ if b then Stats.ruleFired "True &&" x + else Stats.ruleFired "False &&" $ Const (fromElt False) + evalLAnd _ _ = Nothing @@ -741,6 +745,10 @@ evalLOr (untup2 -> Just (x,y)) env = Just $ if a then Stats.ruleFired "True ||" $ Const (fromElt True) else Stats.ruleFired "False ||" y + | Just b <- propagate env y + = Just $ if b then Stats.ruleFired "True ||" $ Const (fromElt True) + else Stats.ruleFired "False ||" x + evalLOr _ _ = Nothing From 58f1c70328c3045e97374f0658dd4c696f0ea629 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 16 Jul 2019 15:42:50 +0200 Subject: [PATCH 072/316] nofib: add test case for AccelerateHS/accelerate-llvm#46 --- accelerate.cabal | 1 + .../Array/Accelerate/Test/NoFib/Issues.hs | 5 +++ .../Accelerate/Test/NoFib/Issues/Issue439.hs | 37 +++++++++++++++++++ 3 files changed, 43 insertions(+) create mode 100644 src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs diff --git a/accelerate.cabal b/accelerate.cabal index 46bb545c6..77e5968cc 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -441,6 +441,7 @@ Library Data.Array.Accelerate.Test.NoFib.Issues.Issue409 Data.Array.Accelerate.Test.NoFib.Issues.Issue436 Data.Array.Accelerate.Test.NoFib.Issues.Issue437 + Data.Array.Accelerate.Test.NoFib.Issues.Issue439 else cpp-options: diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs index 3d0811f1a..21087fffe 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs @@ -33,6 +33,9 @@ module Data.Array.Accelerate.Test.NoFib.Issues ( module Data.Array.Accelerate.Test.NoFib.Issues.Issue364, module Data.Array.Accelerate.Test.NoFib.Issues.Issue407, module Data.Array.Accelerate.Test.NoFib.Issues.Issue409, + module Data.Array.Accelerate.Test.NoFib.Issues.Issue436, + module Data.Array.Accelerate.Test.NoFib.Issues.Issue437, + module Data.Array.Accelerate.Test.NoFib.Issues.Issue439, ) where @@ -61,6 +64,7 @@ import Data.Array.Accelerate.Test.NoFib.Issues.Issue407 import Data.Array.Accelerate.Test.NoFib.Issues.Issue409 import Data.Array.Accelerate.Test.NoFib.Issues.Issue436 import Data.Array.Accelerate.Test.NoFib.Issues.Issue437 +import Data.Array.Accelerate.Test.NoFib.Issues.Issue439 test_issues :: RunN -> TestTree @@ -88,5 +92,6 @@ test_issues runN = , test_issue409 runN , test_issue436 runN , test_issue437 runN + , test_issue439 runN ] diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs new file mode 100644 index 000000000..f0c295649 --- /dev/null +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE RankNTypes #-} +-- | +-- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue439 +-- Copyright : [2009..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- https://github.com/AccelerateHS/accelerate-llvm/issues/46 +-- + +module Data.Array.Accelerate.Test.NoFib.Issues.Issue439 ( + + test_issue439 + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Test.NoFib.Base + +import Test.Tasty +import Test.Tasty.HUnit + + +test_issue439 :: RunN -> TestTree +test_issue439 runN + = testCase "439" + $ e1 @=? runN t1 + +e1 :: Scalar Float +e1 = fromList Z [2] + +t1 :: Acc (Scalar Float) +t1 = compute . A.map (* 2) . compute $ fill Z_ 1 + From 070bdbc55e7b20cef79d5c5dfb80bdb5503cfe53 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 16 Jul 2019 15:52:23 +0200 Subject: [PATCH 073/316] fusion: delay (>->) elimination until phase two fixes: AccelerateHS/accelerate-llvm#46 --- src/Data/Array/Accelerate/Trafo/Fusion.hs | 57 ++++++++++------------- 1 file changed, 25 insertions(+), 32 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index fbb1298a3..68f9a1d12 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -170,7 +170,7 @@ manifest config (OpenAcc pacc) = Awhile p f a -> Awhile (cvtAF p) (cvtAF f) (manifest config a) Atuple tup -> Atuple (cvtAT tup) Aprj ix tup -> Aprj ix (manifest config tup) - Apply f a -> Apply (cvtAF f) (manifest config a) + Apply f a -> apply (cvtAF f) (manifest config a) Aforeign ff f a -> Aforeign ff (cvtAF f) (manifest config a) -- Producers @@ -221,10 +221,26 @@ manifest config (OpenAcc pacc) = | Manifest (Avar ZeroIdx) <- body , Manifest x <- bnd = x - + -- | otherwise = Alet bnd body + -- Eliminate redundant application to an identity function. This + -- arises in the use of pipe to avoid fusion and force its argument + -- to be evaluated, i.e.: + -- + -- > compute :: Acc a -> Acc a + -- > compute = id >-> id + -- + apply afun x + | Alam (Abody body) <- afun + , Manifest (Avar ZeroIdx) <- body + , Manifest x' <- x + = Stats.ruleFired "applyD/identity" x' + -- + | otherwise + = Apply afun x + cvtAT :: Atuple (OpenAcc aenv) a -> Atuple (DelayedOpenAcc aenv) a cvtAT NilAtup = NilAtup cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` manifest config a @@ -391,10 +407,10 @@ embedPreAcc config embedAcc elimAcc pacc -- 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 + Apply f a -> done $ Apply (cvtAF f) (cvtA a) 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) @@ -811,8 +827,8 @@ instance Kit acc => Simplify (Cunctation acc aenv a) where -- 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) + | 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. @@ -822,11 +838,11 @@ yield :: Kit acc -> 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) + 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" + | 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 @@ -1541,29 +1557,6 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) --} --- 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 - , Just (Avar ZeroIdx) <- extract body - , Just x' <- extract x - = Stats.ruleFired "applyD/identity" - $ done x' - - | otherwise - = done $ Apply afun x - - -- Array conditionals, in particular eliminate branches when the predicate -- reduces to a known constant. -- From 1eeb832b22cae171551468b7e466598ebac1e2d8 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 16 Jul 2019 18:19:45 +0200 Subject: [PATCH 074/316] add type signatures --- src/Data/Array/Accelerate/Trafo/Fusion.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 68f9a1d12..a5152b3b3 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -214,9 +214,13 @@ manifest config (OpenAcc pacc) = -- Collect s -> Collect (cvtS s) where - -- Flatten needless let-binds, which can be introduced by the conversion to - -- the internal embeddable representation. + -- Flatten needless let-binds, which can be introduced by the + -- conversion to the internal embeddable representation. -- + alet :: (Arrays a, Arrays b) + => DelayedOpenAcc aenv a + -> DelayedOpenAcc (aenv,a) b + -> PreOpenAcc DelayedOpenAcc aenv b alet bnd body | Manifest (Avar ZeroIdx) <- body , Manifest x <- bnd @@ -232,6 +236,10 @@ manifest config (OpenAcc pacc) = -- > compute :: Acc a -> Acc a -- > compute = id >-> id -- + apply :: (Arrays a, Arrays b) + => PreOpenAfun DelayedOpenAcc aenv (a -> b) + -> DelayedOpenAcc aenv a + -> PreOpenAcc DelayedOpenAcc aenv b apply afun x | Alam (Abody body) <- afun , Manifest (Avar ZeroIdx) <- body From 901598f4acd63d36a02b63b2f55b6410bcbbc8d2 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 17 Jul 2019 11:56:20 +0200 Subject: [PATCH 075/316] add flag -f[no-]fast-permute-const --- accelerate.cabal | 3 + cbits/flags.c | 8 ++- cbits/flags.h | 1 + src/Data/Array/Accelerate/Debug/Flags.hs | 79 ++++++++++++------------ src/Data/Array/Accelerate/Language.hs | 20 +++++- 5 files changed, 69 insertions(+), 42 deletions(-) diff --git a/accelerate.cabal b/accelerate.cabal index 77e5968cc..5efcee140 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -164,6 +164,9 @@ Flag debug . * @fast-math@: Allow algebraically equivalent transformations which may change floating point results (e.g., reassociate) (True). + . + * @fast-permute-const@: Allow non-atomic `permute const` for product types + (True). . The following options control debug message output, and are enabled with @-d\@. diff --git a/cbits/flags.c b/cbits/flags.c index 07338bb22..231f137dc 100644 --- a/cbits/flags.c +++ b/cbits/flags.c @@ -33,7 +33,7 @@ * corresponding behaviour. */ -__flags_t __cmd_line_flags = { 0x7f }; // SEE: [layout of command line options bitfield] +__flags_t __cmd_line_flags = { 0xff }; // SEE: [layout of command line options bitfield] HsInt __unfolding_use_threshold = 1; HsInt __max_simplifier_iterations = 25; @@ -58,6 +58,7 @@ static const struct option longopts[] = , { "fsimplify", no_argument, NULL, OPT_ENABLE } , { "finplace", no_argument, NULL, OPT_ENABLE } , { "ffast-math", no_argument, NULL, OPT_ENABLE } + , { "ffast-permute-const", no_argument, NULL, OPT_ENABLE } , { "fflush-cache", no_argument, NULL, OPT_ENABLE } , { "fforce-recomp", no_argument, NULL, OPT_ENABLE } @@ -86,6 +87,7 @@ static const struct option longopts[] = , { "fno-simplify", no_argument, NULL, OPT_DISABLE } , { "fno-inplace", no_argument, NULL, OPT_DISABLE } , { "fno-fast-math", no_argument, NULL, OPT_DISABLE } + , { "fno-fast-permute-const", no_argument, NULL, OPT_DISABLE } , { "fno-flush-cache", no_argument, NULL, OPT_DISABLE } , { "fno-force-recomp", no_argument, NULL, OPT_DISABLE } @@ -123,7 +125,7 @@ static void parse_options(int argc, char *argv[]) break; case OPT_DISABLE: - __cmd_line_flags.bitfield &= ~(1 << (longindex - 26)); // SEE: [layout of command line options bitfield] + __cmd_line_flags.bitfield &= ~(1 << (longindex - 27)); // SEE: [layout of command line options bitfield] break; /* attempt to decode the argument to flags which require them */ @@ -194,7 +196,7 @@ static void parse_options(int argc, char *argv[]) } #if !defined(ACCELERATE_DEBUG) - if (__cmd_line_flags.bitfield & 0x3fffe00) { // SEE: [layout of command line options bitfield] + if (__cmd_line_flags.bitfield & 0x7fffc00) { // SEE: [layout of command line options bitfield] fprintf(stderr, "Data.Array.Accelerate: Debugging options are disabled.\n"); fprintf(stderr, "Reinstall package 'accelerate' with '-fdebug' to enable them.\n"); } diff --git a/cbits/flags.h b/cbits/flags.h index 2c13e997e..c64c6f08b 100644 --- a/cbits/flags.h +++ b/cbits/flags.h @@ -24,6 +24,7 @@ typedef union { uint32_t simplify : 1; uint32_t inplace : 1; uint32_t fast_math : 1; + uint32_t fast_permute_const : 1; uint32_t flush_cache : 1; uint32_t force_recomp : 1; diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index 0f9cb6cc6..2213a8ab3 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -65,6 +65,7 @@ instance Enum Flag where toEnum = Flag fromEnum (Flag x) = x +-- SEE: [layout of command line options bitfield] instance Show Flag where show (Flag x) = case x of @@ -75,25 +76,26 @@ instance Show Flag where 4 -> "simplify" 5 -> "inplace" 6 -> "fast-math" - 7 -> "flush_cache" - 8 -> "force-recomp" - 9 -> "debug" - 10 -> "verbose" - 11 -> "dump-phases" - 12 -> "dump-sharing" - 13 -> "dump-fusion" - 14 -> "dump-simpl_stats" - 15 -> "dump-simpl_iterations" - 16 -> "dump-vectorisation" - 17 -> "dump-dot" - 18 -> "dump-simpl_dot" - 19 -> "dump-gc" - 20 -> "dump-gc_stats" - 21 -> "dump-cc" - 22 -> "dump-ld" - 23 -> "dump-asm" - 24 -> "dump-exec" - 25 -> "dump-sched" + 7 -> "fast-permute-const" + 8 -> "flush_cache" + 9 -> "force-recomp" + 10 -> "debug" + 11 -> "verbose" + 12 -> "dump-phases" + 13 -> "dump-sharing" + 14 -> "dump-fusion" + 15 -> "dump-simpl_stats" + 16 -> "dump-simpl_iterations" + 17 -> "dump-vectorisation" + 18 -> "dump-dot" + 19 -> "dump-simpl_dot" + 20 -> "dump-gc" + 21 -> "dump-gc_stats" + 22 -> "dump-cc" + 23 -> "dump-ld" + 24 -> "dump-asm" + 25 -> "dump-exec" + 26 -> "dump-sched" _ -> show x -- | Conditional execution of a monadic debugging expression. @@ -179,26 +181,27 @@ array_fusion = Flag 3 -- fuse array expressions simplify = Flag 4 -- simplify scalar expressions inplace = Flag 5 -- allow (safe) in-place array updates fast_math = Flag 6 -- delete persistent compilation cache(s) -flush_cache = Flag 7 -- force recompilation of array programs -force_recomp = Flag 8 -- use faster, less precise math library operations +fast_permute_const = Flag 7 -- allow non-atomic permute const for product types +flush_cache = Flag 8 -- force recompilation of array programs +force_recomp = Flag 9 -- use faster, less precise math library operations -- These debugging flags are disable by default and are enabled with @-d@ -- -debug = Flag 9 -- compile code with debugging symbols (-g) -verbose = Flag 10 -- be very chatty -dump_phases = Flag 11 -- print information about each phase of the compiler -dump_sharing = Flag 12 -- sharing recovery phase -dump_fusion = Flag 13 -- array fusion phase -dump_simpl_stats = Flag 14 -- statistics form fusion/simplification -dump_simpl_iterations = Flag 15 -- output from each simplifier iteration -dump_vectorisation = Flag 16 -- output from the vectoriser -dump_dot = Flag 17 -- generate dot output of the program -dump_simpl_dot = Flag 18 -- generate simplified dot output -dump_gc = Flag 19 -- trace garbage collector -dump_gc_stats = Flag 20 -- print final GC statistics -dump_cc = Flag 21 -- trace code generation & compilation -dump_ld = Flag 22 -- trace runtime linker -dump_asm = Flag 23 -- trace assembler -dump_exec = Flag 24 -- trace execution -dump_sched = Flag 25 -- trace scheduler +debug = Flag 10 -- compile code with debugging symbols (-g) +verbose = Flag 11 -- be very chatty +dump_phases = Flag 12 -- print information about each phase of the compiler +dump_sharing = Flag 13 -- sharing recovery phase +dump_fusion = Flag 14 -- array fusion phase +dump_simpl_stats = Flag 15 -- statistics form fusion/simplification +dump_simpl_iterations = Flag 16 -- output from each simplifier iteration +dump_vectorisation = Flag 17 -- output from the vectoriser +dump_dot = Flag 18 -- generate dot output of the program +dump_simpl_dot = Flag 19 -- generate simplified dot output +dump_gc = Flag 20 -- trace garbage collector +dump_gc_stats = Flag 21 -- print final GC statistics +dump_cc = Flag 22 -- trace code generation & compilation +dump_ld = Flag 23 -- trace runtime linker +dump_asm = Flag 24 -- trace assembler +dump_exec = Flag 25 -- trace execution +dump_sched = Flag 26 -- trace scheduler diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index a13c2a1d0..f965b7712 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -745,7 +745,7 @@ scanr1 = Acc $$ Scanr1 -- 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. +-- in-place. This behaviour can be disabled this with @-fno-inplace@. -- -- Regarding the defaults array: -- @@ -754,6 +754,24 @@ scanr1 = Acc $$ Scanr1 -- array created by 'Data.Array.Accelerate.Prelude.fill'ing with the value -- 'Data.Array.Accelerate.Unsafe.undef' will give you a new uninitialised array. -- +-- Regarding the combination function: +-- +-- The function 'const' can be used to replace elements of the defaults +-- array with the new values. If the permutation function maps multiple +-- values to the same location in the results array (the function is not +-- injective) then this operation is non-deterministic. +-- +-- Since Accelerate uses an unzipped struct-of-array representation, where +-- the individual components of product types (for example, pairs) are +-- stored in separate arrays, storing values of product type requires +-- multiple store instructions. +-- +-- Accelerate prior to version 1.3.0.0 performs this operation atomically, +-- to ensure that the stored values are always consistent (each component +-- of the product type is written by the same thread). Later versions relax +-- this restriction, but this behaviour can be disabled with +-- @-fno-fast-permute-const@. +-- permute :: (Shape sh, Shape sh', Elt a) => (Exp a -> Exp a -> Exp a) -- ^ combination function From 8c64c6567619056da2eeca046669eab5f5ae79b6 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 17 Jul 2019 14:03:48 +0200 Subject: [PATCH 076/316] export flag fast_permute_const --- src/Data/Array/Accelerate/Debug/Flags.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index 2213a8ab3..a1e5dd6fc 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -28,7 +28,7 @@ module Data.Array.Accelerate.Debug.Flags ( Flag(..), seq_sharing, acc_sharing, exp_sharing, array_fusion, simplify, inplace, flush_cache, force_recomp, - fast_math, debug, verbose, dump_phases, dump_sharing, dump_fusion, + fast_math, fast_permute_const, 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, From f7aa79d52de8aac95e8b9c2c85e31fdcf4bab9df Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 17 Jul 2019 23:05:43 +0200 Subject: [PATCH 077/316] add IsProduct instancs for vec types --- src/Data/Array/Accelerate/Product.hs | 38 ++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/src/Data/Array/Accelerate/Product.hs b/src/Data/Array/Accelerate/Product.hs index 57b9de7fb..fdecdc3a4 100644 --- a/src/Data/Array/Accelerate/Product.hs +++ b/src/Data/Array/Accelerate/Product.hs @@ -34,6 +34,9 @@ module Data.Array.Accelerate.Product ( ) where import GHC.Generics +import Data.Primitive.Types + +import Data.Array.Accelerate.Type -- | Type-safe projection indices for tuples. @@ -249,3 +252,38 @@ instance (cst a, cst b, cst c, cst d, cst e, cst f, cst g, cst h, cst i, cst j, prod = ProdRsnoc (prod @cst @(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) +instance (Prim a, cst a) => IsProduct cst (V2 a) where + type ProdRepr (V2 a) = (((), a), a) + fromProd (V2 a b) = (((), a), b) + toProd (((), a), b) = V2 a b + prod = prod @cst @(a,a) + +instance (Prim a, cst a) => IsProduct cst (V3 a) where + type ProdRepr (V3 a) = ((((), a), a), a) + fromProd (V3 a b c) = ((((), a), b), c) + toProd ((((), a), b), c) = V3 a b c + prod = prod @cst @(a,a,a) + +instance (Prim a, cst a) => IsProduct cst (V4 a) where + type ProdRepr (V4 a) = (((((), a), a), a), a) + fromProd (V4 a b c d) = (((((), a), b), c), d) + toProd (((((), a), b), c), d) = V4 a b c d + prod = prod @cst @(a,a,a,a) + +instance (Prim a, cst a) => IsProduct cst (V8 a) where + type ProdRepr (V8 a) = (((((((((), a), a), a), a), a), a), a), a) + fromProd (V8 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) + = V8 a b c d e f g h + prod + = prod @cst @(a,a,a,a,a,a,a,a) + +instance (Prim a, cst a) => IsProduct cst (V16 a) where + type ProdRepr (V16 a) = (((((((((((((((((), a), a), a), a), a), a), a), a), a), a), a), a), a), a), a), a) + fromProd (V16 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) + = V16 a b c d e f g h i j k l m n o p + prod + = prod @cst @(a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a) + From 2768e0f4cb33809de2e695708ef73ff8b42a99d4 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 17 Jul 2019 23:09:06 +0200 Subject: [PATCH 078/316] add tests for SIMD types --- accelerate.cabal | 3 +- src/Data/Array/Accelerate/Test/NoFib/Base.hs | 17 ++ .../Accelerate/Test/NoFib/Issues/Issue228.hs | 6 +- .../Array/Accelerate/Test/NoFib/Prelude.hs | 3 + .../Accelerate/Test/NoFib/Prelude/SIMD.hs | 248 ++++++++++++++++++ 5 files changed, 273 insertions(+), 4 deletions(-) create mode 100644 src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs diff --git a/accelerate.cabal b/accelerate.cabal index 6c93e99de..90c2096ef 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -166,7 +166,7 @@ Flag debug change floating point results (e.g., reassociate) (True). . * @fast-permute-const@: Allow non-atomic `permute const` for product types - (True). + (True). . The following options control debug message output, and are enabled with @-d\@. @@ -406,6 +406,7 @@ Library 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.SIMD Data.Array.Accelerate.Test.NoFib.Prelude.Fold Data.Array.Accelerate.Test.NoFib.Prelude.Scan Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute diff --git a/src/Data/Array/Accelerate/Test/NoFib/Base.hs b/src/Data/Array/Accelerate/Test/NoFib/Base.hs index e81bf0983..f79c69949 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Base.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Base.hs @@ -20,6 +20,7 @@ import Data.Array.Accelerate.Trafo.Sharing ( Afunction, import Data.Array.Accelerate.Type import Control.Monad +import Data.Primitive.Types import Hedgehog import qualified Hedgehog.Gen as Gen @@ -90,6 +91,22 @@ 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) +v2 :: Prim a => Gen a -> Gen (V2 a) +v2 a = V2 <$> a <*> a + +v3 :: Prim a => Gen a -> Gen (V3 a) +v3 a = V3 <$> a <*> a <*> a + +v4 :: Prim a => Gen a -> Gen (V4 a) +v4 a = V4 <$> a <*> a <*> a <*> a + +v8 :: Prim a => Gen a -> Gen (V8 a) +v8 a = V8 <$> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a + +v16 :: Prim a => Gen a -> Gen (V16 a) +v16 a = V16 <$> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a + <*> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a + log_flt_max :: RealFloat a => a log_flt_max = log flt_max diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs index ca31d3758..579510d67 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs @@ -61,8 +61,8 @@ 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) + t1 = unlift e1 :: (Exp Int,Exp Int) + t2 = unlift e2 :: (Exp Int,Exp Int) in - lift $ merge v1 v2 + lift $ merge t1 t2 diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs index 2fe80e8a8..ec263b231 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs @@ -15,6 +15,7 @@ module Data.Array.Accelerate.Test.NoFib.Prelude ( module Data.Array.Accelerate.Test.NoFib.Prelude.Map, module Data.Array.Accelerate.Test.NoFib.Prelude.ZipWith, + module Data.Array.Accelerate.Test.NoFib.Prelude.SIMD, module Data.Array.Accelerate.Test.NoFib.Prelude.Fold, module Data.Array.Accelerate.Test.NoFib.Prelude.Scan, module Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute, @@ -29,6 +30,7 @@ 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.SIMD import Data.Array.Accelerate.Test.NoFib.Prelude.Fold import Data.Array.Accelerate.Test.NoFib.Prelude.Scan import Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute @@ -42,6 +44,7 @@ test_prelude runN = testGroup "prelude" [ test_map runN , test_zipWith runN + , test_simd runN , test_fold runN , test_foldSeg runN , test_backpermute runN diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs new file mode 100644 index 000000000..485873ddd --- /dev/null +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.Test.NoFib.Prelude.SIMD +-- Copyright : [2009..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Test.NoFib.Prelude.SIMD ( + + test_simd, + +) where + +import Data.Typeable +import Data.Primitive.Types +import Control.Lens ( view, _1, _2, _3, _4 ) +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.Type +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Product + +import Hedgehog +import qualified Hedgehog.Gen as Gen + +import Test.Tasty +import Test.Tasty.Hedgehog + + +test_simd :: RunN -> TestTree +test_simd runN = + testGroup "simd" + [ at @TestInt8 $ testElt i8 + , at @TestInt16 $ testElt i16 + , at @TestInt32 $ testElt i32 + , at @TestInt64 $ testElt i64 + , at @TestWord8 $ testElt w8 + , at @TestWord16 $ testElt w16 + , at @TestWord32 $ testElt w32 + , at @TestWord64 $ testElt w64 + , at @TestHalf $ testElt f16 + , at @TestFloat $ testElt f32 + , at @TestDouble $ testElt f64 + ] + where + testElt :: forall e. (Prim e, P.Eq e, Elt e, Elt (V2 e), Elt (V3 e), Elt (V4 e)) + => Gen e + -> TestTree + testElt e = + testGroup (show (typeOf (undefined::e))) + [ testExtract e + , testInject e + ] + + testExtract :: forall e. (Prim e, P.Eq e, Elt e, Elt (V2 e), Elt (V3 e), Elt (V4 e)) + => Gen e + -> TestTree + testExtract e = + testGroup "extract" + [ testProperty "V2" $ test_extract_v2 runN dim1 e + , testProperty "V3" $ test_extract_v3 runN dim1 e + , testProperty "V4" $ test_extract_v4 runN dim1 e + ] + + testInject :: forall e. (Prim e, P.Eq e, Elt e, Elt (V2 e), Elt (V3 e), Elt (V4 e)) + => Gen e + -> TestTree + testInject e = + testGroup "inject" + [ testProperty "V2" $ test_inject_v2 runN dim1 e + , testProperty "V3" $ test_inject_v3 runN dim1 e + , testProperty "V4" $ test_inject_v4 runN dim1 e + ] + + +test_extract_v2 + :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V2 e)) + => RunN + -> Gen sh + -> Gen e + -> Property +test_extract_v2 runN dim e = + property $ do + sh <- forAll dim + xs <- forAll (array sh (v2 e)) + (_l,_m) <- P.snd <$> forAllWith P.fst (Gen.element [("_1",(_1,_1)), ("_2",(_2,_2))]) + let !go = runN (A.map (view _m . unpackV2')) in go xs === mapRef (view _l . unpackV2) xs + +test_extract_v3 + :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V3 e)) + => RunN + -> Gen sh + -> Gen e + -> Property +test_extract_v3 runN dim e = + property $ do + sh <- forAll dim + xs <- forAll (array sh (v3 e)) + (_l,_m) <- P.snd <$> forAllWith P.fst (Gen.element [("_1",(_1,_1)), ("_2",(_2,_2)), ("_3",(_3,_3))]) + let !go = runN (A.map (view _m . unpackV3')) in go xs === mapRef (view _l . unpackV3) xs + +test_extract_v4 + :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V4 e)) + => RunN + -> Gen sh + -> Gen e + -> Property +test_extract_v4 runN dim e = + property $ do + sh <- forAll dim + xs <- forAll (array sh (v4 e)) + (_l,_m) <- P.snd <$> forAllWith P.fst (Gen.element [("_1",(_1,_1)), ("_2",(_2,_2)), ("_3",(_3,_3)), ("_4",(_4,_4))]) + let !go = runN (A.map (view _m . unpackV4')) in go xs === mapRef (view _l . unpackV4) xs + +test_inject_v2 + :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V2 e)) + => RunN + -> Gen sh + -> Gen e + -> Property +test_inject_v2 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 packV2') in go xs ys === zipWithRef V2 xs ys + +test_inject_v3 + :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V3 e)) + => RunN + -> Gen sh + -> Gen e + -> Property +test_inject_v3 runN dim e = + property $ do + sh1 <- forAll dim + sh2 <- forAll dim + sh3 <- forAll dim + xs <- forAll (array sh1 e) + ys <- forAll (array sh2 e) + zs <- forAll (array sh3 e) + let !go = runN (A.zipWith3 packV3') in go xs ys zs === zipWith3Ref V3 xs ys zs + +test_inject_v4 + :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V4 e)) + => RunN + -> Gen sh + -> Gen e + -> Property +test_inject_v4 runN dim e = + property $ do + sh1 <- forAll dim + sh2 <- forAll dim + sh3 <- forAll dim + sh4 <- forAll dim + xs <- forAll (array sh1 e) + ys <- forAll (array sh2 e) + zs <- forAll (array sh3 e) + ws <- forAll (array sh4 e) + let !go = runN (A.zipWith4 packV4') in go xs ys zs ws === zipWith4Ref V4 xs ys zs ws + + +unpackV2' :: (Prim e, Elt e, Elt (V2 e)) => Exp (V2 e) -> (Exp e, Exp e) +unpackV2' e = + ( Exp $ SuccTupIdx ZeroTupIdx `Prj` e + , Exp $ ZeroTupIdx `Prj` e + ) + +unpackV3' :: (Prim e, Elt e, Elt (V3 e)) => Exp (V3 e) -> (Exp e, Exp e, Exp e) +unpackV3' e = + ( Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e + , Exp $ SuccTupIdx ZeroTupIdx `Prj` e + , Exp $ ZeroTupIdx `Prj` e + ) + +unpackV4' :: (Prim e, Elt e, Elt (V4 e)) => Exp (V4 e) -> (Exp e, Exp e, Exp e, Exp e) +unpackV4' e = + ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e + , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e + , Exp $ SuccTupIdx ZeroTupIdx `Prj` e + , Exp $ ZeroTupIdx `Prj` e + ) + +packV2' :: (Prim e, Elt e, Elt (V2 e)) => Exp e -> Exp e -> Exp (V2 e) +packV2' x y = Exp . Tuple $ NilTup `SnocTup` x `SnocTup` y + +packV3' :: (Prim e, Elt e, Elt (V3 e)) => Exp e -> Exp e -> Exp e -> Exp (V3 e) +packV3' x y z = Exp . Tuple $ NilTup `SnocTup` x `SnocTup` y `SnocTup` z + +packV4' :: (Prim e, Elt e, Elt (V4 e)) => Exp e -> Exp e -> Exp e -> Exp e -> Exp (V4 e) +packV4' x y z w = Exp . Tuple $ NilTup `SnocTup` x `SnocTup` y `SnocTup` z `SnocTup` w + + +-- Reference Implementation +-- ------------------------ + +mapRef :: (Shape sh, Elt a, Elt b) => (a -> b) -> Array sh a -> Array sh b +mapRef f xs = fromFunction (arrayShape xs) (\ix -> f (xs S.! ix)) + +zipWithRef + :: (Shape sh, Elt a, Elt b, 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)) + +zipWith3Ref + :: (Shape sh, Elt a, Elt b, Elt c, Elt d) + => (a -> b -> c -> d) + -> Array sh a + -> Array sh b + -> Array sh c + -> Array sh d +zipWith3Ref f xs ys zs = + fromFunction + (S.shape xs `S.intersect` S.shape ys `S.intersect` S.shape zs) + (\ix -> f (xs S.! ix) (ys S.! ix) (zs S.! ix)) + +zipWith4Ref + :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e) + => (a -> b -> c -> d -> e) + -> Array sh a + -> Array sh b + -> Array sh c + -> Array sh d + -> Array sh e +zipWith4Ref f xs ys zs ws = + fromFunction + (S.shape xs `S.intersect` S.shape ys `S.intersect` S.shape zs `S.intersect` S.shape ws) + (\ix -> f (xs S.! ix) (ys S.! ix) (zs S.! ix) (ws S.! ix)) + From 6895603dc493605be4cefd6562963ae6d0420c91 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 29 Aug 2019 12:13:04 +0200 Subject: [PATCH 079/316] stack/8.6: upgrade to lts-14.3 --- stack-8.6.yaml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/stack-8.6.yaml b/stack-8.6.yaml index 6833b379c..855568ba2 100644 --- a/stack-8.6.yaml +++ b/stack-8.6.yaml @@ -1,14 +1,12 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-13.25 +resolver: lts-14.3 packages: - . -extra-deps: -- hedgehog-1.0 -- tasty-hedgehog-1.0.0.1 +# extra-deps: [] # Override default flag values for local packages and extra-deps # flags: {} From 156b5ce9232f3d9bbb94f3054daf51e23454fb0b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 30 Aug 2019 12:48:40 +0200 Subject: [PATCH 080/316] align memory at 64-byte boundary --- src/Data/Array/Accelerate/Array/Data.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 6c70275af..8c6987f6b 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -367,7 +367,7 @@ __mallocForeignPtrBytes = unsafePerformIO $! newIORef mallocPlainForeignPtrBytes {-# INLINE mallocPlainForeignPtrBytesAligned #-} mallocPlainForeignPtrBytesAligned :: Int -> IO (ForeignPtr a) mallocPlainForeignPtrBytesAligned (I# size) = IO $ \s -> - case newAlignedPinnedByteArray# size 16# s of + case newAlignedPinnedByteArray# size 64# s of (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (PlainPtr mbarr#) #) From 95ff15a5ee25dd8450a972e1112771e6c2b60594 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 20 Sep 2019 18:14:39 +0200 Subject: [PATCH 081/316] allow ghc-8.8 --- .travis.yml | 3 ++ accelerate.cabal | 2 +- stack-8.8.yaml | 108 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 112 insertions(+), 1 deletion(-) create mode 100644 stack-8.8.yaml diff --git a/.travis.yml b/.travis.yml index 42d48d8d1..3bb32fcc5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -27,6 +27,9 @@ addons: matrix: fast_finish: true include: + - env: GHC=8.8.1 + compiler: "GHC 8.8" + - env: GHC=8.6.5 compiler: "GHC 8.6" diff --git a/accelerate.cabal b/accelerate.cabal index 90c2096ef..fb4dcb6e4 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -268,7 +268,7 @@ Flag nofib Library Build-depends: - base >= 4.9 && < 4.13 + base >= 4.9 && < 4.14 , ansi-terminal >= 0.6.2 , base-orphans >= 0.3 , bytestring >= 0.10.2 diff --git a/stack-8.8.yaml b/stack-8.8.yaml new file mode 100644 index 000000000..70f4785c4 --- /dev/null +++ b/stack-8.8.yaml @@ -0,0 +1,108 @@ +# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md +# vim: nospell + +resolver: ghc-8.8.1 +allow-newer: true # transformers-compat + +packages: +- . + +extra-deps: +- adjunctions-4.4@sha256:2738dd5f5d5e93749adb14a05472e58a96a75d0f299e46371c6f46dc4e97daf9,3067 +- ansi-terminal-0.10@sha256:69d3fc72208f2d8830c18636182e342fabee4859bc091a89a77fe84d5674156b,3224 +- ansi-wl-pprint-0.6.9@sha256:f6fd6dbd4adcad0432bf75e5f5b19bb1deda00a1d8056faf18090026e577652d,2388 +- async-2.2.2@sha256:ed46f0f5be36cf8a3e3aebc6827d015e1f3bf9615c245e057b9e9bd35faddd21,2895 +- base-compat-0.11.0@sha256:d92c8732c415ba6a3a1fa5fcc578e714c453685afba8d936ead91c496b0f546f,7043 +- base-orphans-0.8.1@sha256:defd0057b5db93257528d89b5b01a0fee9738e878c121c686948ac4aa5dded63,2927 +- basement-0.0.11@sha256:af43e2e334e515b52ca309919b135c51b5e9411e6d4c68d0e8950d61eb5f25d1,5711 +- bifunctors-5.5.5@sha256:e89def05aa5a9c729435592c11a35b54747558b1ec15c7283c7d61df03873ab6,3300 +- cabal-doctest-1.0.7@sha256:2a9d524b9593fc5054c0bcfda9aeaffd4203f3663b77fab57db35ddd48ce6ad3,1573 +- call-stack-0.2.0@sha256:5ce796b78d5f964468ec6fe0717b4e7d0430817f37370c47b3e6b38e345b6643,1202 +- clock-0.8@sha256:b4ae207e2d3761450060a0d0feb873269233898039c76fceef9cc1a544067767,4113 +- code-page-0.2@sha256:f701393cb1ff7b3ec7880816abc44387647811be31670e884e02d6a20c4aa508,2356 +- colour-2.3.5@sha256:b27db0a3ad40d70bdbd8510a104269f8707592e80757a1abc66a22ba25e5a42f,1801 +- comonad-5.0.5@sha256:b33bc635615647916e374a27e96c3de4df390684001eab6291283471cd3a9b62,3345 +- concurrent-output-1.10.10@sha256:5290b0900504fdfd32ded51bb3140f4eafaa14e3e2366b9ffa9c63db24a424ed,1651 +- constraints-0.11.2@sha256:d028005d93f891b48b61ff0c82c6f868859eb728010dea3e355b0c55d0f57cf9,2219 +- contravariant-1.5.2@sha256:853259271870000c007a281f0bf0bf6e1aaa97c5fd5cd5734d7b0d79b9de2af5,2761 +- cryptonite-0.26@sha256:43c722f3770c31f4c5376e7aa42645b104834103312e217aa7fe79316416d6df,17352 +- distributive-0.6.1@sha256:90cef5a2d9c2477775e382c96fc716763e517ffd99dc6843046b3eabb2a7ff29,3062 +- doctest-0.16.2@sha256:2f96e9bbe9aee11b47453c82c24b3dc76cdbb8a2a7c984dfd60b4906d08adf68,6942 +- exceptions-0.10.3@sha256:6e8e66f3acf2ea59f9e100c55a885591c1981789ac2222022ff523c30990efb8,2251 +- fail-4.9.0.0@sha256:35d1ee29364447c1b7d616bb1ee31f162b73e85fea91d7ca6441cf901398f572,1051 +- free-5.1.2@sha256:cd57d8cbaf8ef37620219095694b83e3b3baf3b06e1c59f422a4954d3a5f4c42,4116 +- ghc-paths-0.1.0.12@sha256:e7120e162fe070e01a80b0404dda2fd8c8c9feea48e75aec6286cdc05f81bb28,618 +- half-0.3@sha256:48cc70e3cd42ccd13039b8d5865ca3aeffe526572aff7e2baf9cf9c28bc31eeb,1316 +- happy-1.19.12@sha256:acc67bfbf3af87892766781dd064c9447181ea81269a7a1e5fc9ace4a8fa4768,5691 +- hashable-1.3.0.0@sha256:7ad8edaa681e81162ddddb4d703a9cffe6a0c9ddcfede31cf6569507ed3f1ddb,5179 +- hashtables-1.2.3.4@sha256:16a77784ba31ce90cfaab198b42a888fd30d838f9fd581c0efc5b7ee6dfe458f,8223 +- haskell-lexer-1.0.2@sha256:1c84537dbd29809c1004ccb156552429de35fe77fab6dd484ac8deb318cc6b64,917 +- hedgehog-1.0.1@sha256:b65b1ebde7b7fe8e693070916e45aa2ed63eea5e3f84ac3a8f9a0b7f8fcf0337,4465 +- invariant-0.5.3@sha256:cc403ccbb176435d7039e28916c8a54ad0971596b90f935a460582bb77a83148,3233 +- kan-extensions-5.2@sha256:2407501562039dad6a3d19aacd0bbcca07aa28497cbd1cdaaf5aabc30146899d,2771 +- lens-4.18.1@sha256:5c21912d5af370ae608a7e010c8a705e987e42e89bbed306de73f87166251c27,15419 +- lifted-async-0.10.0.4@sha256:f763f568b01f4d2e7f25f137d005445af2ffdaa08aa2406810b56c3b9e7acb07,2579 +- lifted-base-0.2.3.12@sha256:e94ad0692c9c5d85c373e508f23654f2da8ac8c3e475c2b65ffbc04fb165ad69,3369 +- memory-0.15.0@sha256:be7024b50e876a9c3b7febaefdd81d5dc67268c58a7b4e6b3825bdc58274d88c,5002 +- mmorph-1.1.3@sha256:abfc95648fef0008f984b94137ce8e1635fb071c7bfaaa7393ba175a1b3bb12f,919 +- monad-control-1.0.2.3@sha256:a3ae888d2fed2e2a0ca33ae11e2480219e07312bccf1a02ffe2ba2e3ec5913ee,2255 +- optparse-applicative-0.15.1.0@sha256:a0b9924d88a17c36cd8e6839d7dd2138419dd8f08cbb4f9af18f3c367b0c69a3,4673 +- parallel-3.2.2.0@sha256:924dc6f8ac94d535689070b96864da0913aee99d8e3354f9130e4d96d5b17328,1792 +- pretty-show-1.9.5@sha256:92aa3f43d8459a9b543e102fbb0b7a6aae0074e18ca6a9970d9922a867114f53,1963 +- prettyprinter-1.3.0@sha256:83336d853f38e72f9213a3051de11dcb3c948eb09903a34f312e4fef00d79f10,5537 +- prettyprinter-ansi-terminal-1.1.1.2@sha256:f4bc019f73f8721a628b36bfca80b4d721886f3d05c8f80117ed75d8b6878ea3,1894 +- primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 +- profunctors-5.5@sha256:685ab6c53705e184d9459714d381ca8a2d25ab62c069f88aec7b3664218f4b2c,2073 +- random-1.1@sha256:7b67624fd76ddf97c206de0801dc7e888097e9d572974be9b9ea6551d76965df,1777 +- reflection-2.1.5@sha256:8dca1275d0c12d9711890cf2e89cd1ec341f64b22c133d2e47a56b7f1a896557,3884 +- resourcet-1.2.2@sha256:8cd361114a67a1e18303569b022d39875eb38f91d5176b657f22b16866ccc395,1655 +- semigroupoids-5.3.3@sha256:260b62cb8539bb988e7f551f10a45ef1c81421c0d79010e9bde9321bad4982a7,7363 +- semigroups-0.19.1@sha256:ecae129621e0d2f77bef2f01e4458c2e0567ab6e1f39579c61d7cec8058ebb0e,6262 +- StateVar-1.2@sha256:9ab3e4a0e252d28bc2f799c83e0725c3e23e8d3b722cff0fdb9822e64b6c16ac,1413 +- syb-0.7.1@sha256:8d37b1e4d04a9aa8512dc6c2a06e02afc015a2fd3e735bdfeeacb5e2e853323c,2462 +- tagged-0.8.6@sha256:7093ee39c9779beeacffa4b0035a0e8a25da16afcd1c1a876930207fb8e31d1c,2606 +- tasty-1.2.3@sha256:bba67074e5326d57e8f53fc1dabcb6841daa4dc51b053506eb7f40a6f49a0497,2517 +- tasty-expected-failure-0.11.1.2@sha256:0b6c76793eb1eb76b0e36f5b4d1d2db25f1b7afa12549f1fa86a05a1ddaa10bc,1771 +- tasty-hedgehog-1.0.0.1@sha256:f632aa57399fbd9a0910757bd550e702e13752f9fd1fced0cc9e6b54dd49c7d8,1823 +- tasty-hunit-0.10.0.2@sha256:8e8bd5807cec650f5aebc5ada07b57620c863e69145e65249651c1b48d97bd70,1515 +- terminal-size-0.3.2.1@sha256:7b2d8e0475a46961d07ddfb91dee618de70eff55d9ba0402ebeac1f9dcf9b18b,1259 +- th-abstraction-0.3.1.0@sha256:96042f6658f2dccfac03b33f0fd59f62b1f65b9b0a765d8a2ea6026f4081ee4a,1838 +- transformers-base-0.4.5.2@sha256:e4d8155470905ba2942033a1537fc4cf91927d1c9b34693fd57ddf3bc02334af,1550 +- transformers-compat-0.6.5@sha256:50b00c57bf3fc379ec2477bfc261a2aebc983084488478adb29854f193af4696,5490 +- type-equality-1@sha256:aeb9c44abf5d2edf52caff114a7da565d8328fa84bbe194828e4355ea85bf5b3,1457 +- unbounded-delays-0.1.1.0@sha256:8e57c6ffb72ed605b85c69d3b3a7ebbbbb70bfb5e9b9816309f1f733240838f2,1184 +- unique-0@sha256:cbac09fc80d77605357a246b10a3dbd9250f39ce451a3f57ac24bf234d93b279,997 +- unliftio-core-0.1.2.0@sha256:7f9b48adef8e36da0202e6e70a733a5e210263ed4177c93e47a4b3f89694194b,1081 +- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204,5199 +- vector-0.12.0.3@sha256:1422b0bcf4e7675116ca8d9f473bf239850c58c4518a56010e3bfebeac345ace,7171 +- void-0.7.3@sha256:13d30f62fcdf065e595d679d4ac8b4b0c1bb1a1b73db7b5b5a8f857cb5c8a546,1857 +- wcwidth-0.0.2@sha256:77531eb6683c505c22ab3fa11bbc43d3ce1e7dac21401d4d5a19677d348bb5f3,1998 +- wl-pprint-annotated-0.1.0.1@sha256:0b8fd3649bfe72d155a4379e4c88b7ef00408f6f4973f63333787fd2e1b5ba1e,2214 + +# Override default flag values for local packages and extra-deps +flags: + accelerate: + debug: true + nofib: true + +# Extra global and per-package GHC options +# ghc-options: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 0.1.4.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] + From ac839f27de32b68b2abd7cd6807a9ee82c68b325 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 20 Sep 2019 19:04:03 +0200 Subject: [PATCH 082/316] warning police --- src/Data/Array/Accelerate/AST.hs | 6 +++--- src/Data/Array/Accelerate/Array/Data.hs | 5 +++-- .../Array/Accelerate/Array/Remote/Class.hs | 5 +++-- src/Data/Array/Accelerate/Array/Sugar.hs | 19 ++++++++++--------- src/Data/Array/Accelerate/Pattern.hs | 6 +++++- src/Data/Array/Accelerate/Product.hs | 2 +- src/Data/Array/Accelerate/Smart.hs | 3 ++- src/Data/Array/Accelerate/Trafo.hs | 2 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 2 +- .../Array/Accelerate/Trafo/Substitution.hs | 7 ++++--- 10 files changed, 33 insertions(+), 24 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 55ed360f7..47e7b1d34 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -673,7 +673,7 @@ type Boundary = PreBoundary OpenAcc -- | Boundary condition specification for stencil operations -- -data PreBoundary (acc :: * -> * -> *) aenv t where +data PreBoundary acc aenv t where -- Clamp coordinates to the extent of the array Clamp :: PreBoundary acc aenv t @@ -807,7 +807,7 @@ instance (Stencil (sh:.Int) a row1, -- |Parametrised open function abstraction -- -data PreOpenFun (acc :: * -> * -> *) env aenv t where +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) @@ -841,7 +841,7 @@ type Exp = OpenExp () -- -- The data type is parametrised over the surface types (not the representation type). -- -data PreOpenExp (acc :: * -> * -> *) env aenv t where +data PreOpenExp acc env aenv t where -- Local binding of a scalar expression Let :: (Elt bnd_t, Elt body_t) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 8c6987f6b..f1ede7162 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -59,11 +59,12 @@ import Control.Monad ( (<=<) ) import Data.Bits import Data.Char import Data.IORef +import Data.Kind import Data.Primitive ( sizeOf# ) import Data.Typeable ( Typeable ) import Foreign.ForeignPtr import Foreign.Storable -import Language.Haskell.TH +import Language.Haskell.TH hiding ( Type ) import System.IO.Unsafe import Text.Printf import Prelude hiding ( mapM ) @@ -122,7 +123,7 @@ type MutableArrayData e = GArrayData e -- In previous versions this was abstracted over by the mutable/immutable array -- representation, but this is now fixed to our UniqueArray type. -- -data family GArrayData a :: * +data family GArrayData a :: Type data instance GArrayData () = AD_Unit data instance GArrayData Int = AD_Int {-# UNPACK #-} !(UniqueArray Int) data instance GArrayData Int8 = AD_Int8 {-# UNPACK #-} !(UniqueArray Int8) diff --git a/src/Data/Array/Accelerate/Array/Remote/Class.hs b/src/Data/Array/Accelerate/Array/Remote/Class.hs index 59510f7c2..86b93b6a2 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Class.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Class.hs @@ -36,8 +36,9 @@ import Data.Array.Accelerate.Array.Data import Control.Applicative import Control.Monad.Catch import Data.Int -import Data.Word +import Data.Kind import Data.Typeable +import Data.Word import Foreign.Ptr import Foreign.Storable import Prelude @@ -54,7 +55,7 @@ type PrimElt e a = (ArrayElt e, Storable a, ArrayPtrs e ~ Ptr a, Typeable e, Typ class (Applicative m, Monad m, MonadCatch m, MonadMask m) => RemoteMemory m where -- | Pointers into this particular remote memory. - type RemotePtr m :: * -> * + type RemotePtr m :: Type -> Type -- | Attempt to allocate the given number of bytes in the remote memory space. -- Returns Nothing on failure. diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 8f77f46d7..5aebd85d0 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -63,9 +63,10 @@ module Data.Array.Accelerate.Array.Sugar ( -- standard library import Control.DeepSeq +import Data.Kind import Data.Typeable import System.IO.Unsafe ( unsafePerformIO ) -import Language.Haskell.TH hiding ( Foreign ) +import Language.Haskell.TH hiding ( Foreign, Type ) import Prelude hiding ( (!!) ) import qualified Data.Vector.Unboxed as U @@ -213,7 +214,7 @@ class (Show a, Typeable a, Typeable (EltRepr a), ArrayElt (EltRepr a)) => Elt a -- the surface type into the internal representation type consisting only of -- simple primitive types, unit '()', and pair '(,)'. -- - type EltRepr a :: * + type EltRepr a :: Type type EltRepr a = GEltRepr () (Rep a) -- eltType :: TupleType (EltRepr a) @@ -241,7 +242,7 @@ class (Show a, Typeable a, Typeable (EltRepr a), ArrayElt (EltRepr a)) => Elt a toElt = to . snd . gtoElt @(Rep a) @() -class GElt (f :: * -> *) where +class GElt f where type GEltRepr t f geltType :: TupleType t -> TupleType (GEltRepr t f) gfromElt :: t -> f a -> GEltRepr t f @@ -500,7 +501,7 @@ class (Typeable a, Typeable (ArrRepr a)) => Arrays a where -- surface type into the internal representation type, which consists only of -- 'Array', and '()' and '(,)' as type-level nil and snoc. -- - type ArrRepr a :: * + type ArrRepr a :: Type type ArrRepr a = GArrRepr () (Rep a) arrays :: ArraysR (ArrRepr a) @@ -532,7 +533,7 @@ class (Typeable a, Typeable (ArrRepr a)) => Arrays a where -- flavour _ = gflavour @(Rep a) -class GArrays (f :: * -> *) where +class GArrays f where type GArrRepr t f garrays :: ArraysR t -> ArraysR (GArrRepr t f) gfromArr :: f a -> t -> GArrRepr t f @@ -941,9 +942,9 @@ instance Shape sh => Shape (sh:.Int) where -- 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 + type SliceShape sl :: Type -- the projected slice + type CoSliceShape sl :: Type -- the complement of the slice + type FullShape sl :: Type -- the combined dimension sliceIndex :: Repr.SliceIndex (EltRepr sl) (EltRepr (SliceShape sl)) (EltRepr (CoSliceShape sl)) @@ -977,7 +978,7 @@ instance Shape sh => Slice (Any sh) where -- many subarrays, as opposed to extracting a single subarray. -- class (Slice (DivisionSlice sl)) => Division sl where - type DivisionSlice sl :: * -- the slice + type DivisionSlice sl :: Type -- the slice slicesIndex :: slix ~ DivisionSlice sl => Repr.SliceIndex (EltRepr slix) (EltRepr (SliceShape slix)) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index e6f1f1cec..c79d352b6 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,7 +8,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} +#if __GLASGOW_HASKELL__ <= 800 +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} +#endif -- | -- Module : Data.Array.Accelerate.Pattern -- Copyright : [2018..2019] The Accelerate Team diff --git a/src/Data/Array/Accelerate/Product.hs b/src/Data/Array/Accelerate/Product.hs index fdecdc3a4..320bd29b9 100644 --- a/src/Data/Array/Accelerate/Product.hs +++ b/src/Data/Array/Accelerate/Product.hs @@ -88,7 +88,7 @@ class IsProduct cst tup where prod = gprod @cst @(Rep tup) ProdRunit -class GIsProduct cst (f :: * -> *) where +class GIsProduct cst f where type GProdRepr t f gfromProd :: t -> f a -> GProdRepr t f gtoProd :: GProdRepr t f -> (t, f a) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index d627f01fd..8ed698a22 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -72,6 +72,7 @@ module Data.Array.Accelerate.Smart ( -- standard library import Prelude hiding ( exp ) +import Data.Kind import Data.List import Data.Typeable @@ -1193,7 +1194,7 @@ data PreBoundary acc exp t where -- 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 :: * + type StencilRepr sh stencil :: Type stencilPrj :: Exp (StencilRepr sh stencil) -> stencil diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index fd34c0242..c2e9717a8 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -58,7 +58,7 @@ import Data.Typeable import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Array.Sugar ( Arrays, Elt ) -import Data.Array.Accelerate.Trafo.Base +import Data.Array.Accelerate.Trafo.Base ( Match(..), matchDelayedOpenAcc, encodeDelayedOpenAcc ) import Data.Array.Accelerate.Trafo.Config import Data.Array.Accelerate.Trafo.Fusion ( DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun, DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun ) import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, Afunction, AfunctionR ) diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 69a2b6abe..5566d010a 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -1077,7 +1077,7 @@ 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 +data SharingExp acc exp t where VarSharing :: Elt t => StableExpName t -> SharingExp acc exp t LetSharing :: StableSharingExp -> exp t -> SharingExp acc exp t diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 29d5232c1..287cc8d0e 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -37,6 +37,7 @@ module Data.Array.Accelerate.Trafo.Substitution ( ) where +import Data.Kind import Control.Applicative hiding ( Const ) import Prelude hiding ( exp, seq ) @@ -132,7 +133,7 @@ instance Applicative Identity where -- class Rebuildable f where {-# MINIMAL rebuildPartial #-} - type AccClo f :: (* -> * -> *) + type AccClo f :: Type -> Type -> Type rebuildPartial :: (Applicative f', SyntacticAcc fa) => (forall a'. Arrays a' => Idx aenv a' -> f' (fa (AccClo f) aenv' a')) @@ -342,7 +343,7 @@ class SyntacticExp f where 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 } +newtype IdxE (acc :: Type -> Type -> Type) env aenv t = IE { unIE :: Idx env t } instance SyntacticExp IdxE where varIn = IE @@ -444,7 +445,7 @@ class SyntacticAcc f where 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 } +newtype IdxA (acc :: Type -> Type -> Type) aenv t = IA { unIA :: Idx aenv t } instance SyntacticAcc IdxA where avarIn = IA From 619d9331d37cd32adc53836bbe9a8ff661375fb2 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 21 Sep 2019 16:48:38 +0200 Subject: [PATCH 083/316] travis: no jobs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ghc-8.8 really uses a lot of memory… --- .travis.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 3bb32fcc5..8e14cd71d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -63,13 +63,13 @@ before_install: - stack --version install: - - export FLAGS="--jobs=2 --no-terminal --no-copy-bins --flag accelerate:nofib" + - export FLAGS="--no-terminal --no-copy-bins --flag accelerate:nofib" - travis_retry stack build $FLAGS --only-dependencies --test script: - stack build $FLAGS $HADDOCK --test --no-run-tests - - stack test accelerate:doctest --flag accelerate:nofib - - stack test accelerate:nofib-interpreter --test-arguments='--hedgehog-tests 25' --flag accelerate:nofib + - stack test accelerate:doctest $FLAGS + - stack test accelerate:nofib-interpreter $FLAGS --test-arguments='--hedgehog-tests 25' after_success: - source .travis/update-accelerate-buildbot.sh From 207ea47020951cb69e20903e70f1c8f28c3db6f5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 21 Sep 2019 17:15:37 +0200 Subject: [PATCH 084/316] travis: after_failure --- .travis.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.travis.yml b/.travis.yml index 8e14cd71d..2b61146d1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -74,3 +74,7 @@ script: after_success: - source .travis/update-accelerate-buildbot.sh +after_failure: + - dmesg + - df -h + From f255a2d397a7e476997ccb8c831f3ccbe7c9b6cc Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 21 Sep 2019 17:52:05 +0200 Subject: [PATCH 085/316] travis: after_failure --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 2b61146d1..266592024 100644 --- a/.travis.yml +++ b/.travis.yml @@ -77,4 +77,5 @@ after_success: after_failure: - dmesg - df -h + - ulimit -a From 0efd39bbb12e14237d332e1b3b1193b55a914e32 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 23 Sep 2019 12:04:56 +0200 Subject: [PATCH 086/316] travis: after_failure --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 266592024..1195d079e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -75,7 +75,7 @@ after_success: - source .travis/update-accelerate-buildbot.sh after_failure: - - dmesg - - df -h - ulimit -a + - df -h + - dmesg From 17693f981c5a58a1e828568cd7a15b815ce570c1 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 23 Sep 2019 15:07:50 +0200 Subject: [PATCH 087/316] travis: retry^2 --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 1195d079e..6aa673eca 100644 --- a/.travis.yml +++ b/.travis.yml @@ -64,7 +64,7 @@ before_install: install: - export FLAGS="--no-terminal --no-copy-bins --flag accelerate:nofib" - - travis_retry stack build $FLAGS --only-dependencies --test + - travis_retry travis_retry stack build $FLAGS --only-dependencies --test script: - stack build $FLAGS $HADDOCK --test --no-run-tests From 4af1efb3207a02f7bc3725df3f8e0f6b42dfcd09 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 23 Sep 2019 15:30:36 +0200 Subject: [PATCH 088/316] travis: retry retry^2 --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 6aa673eca..ac9ab48eb 100644 --- a/.travis.yml +++ b/.travis.yml @@ -64,10 +64,10 @@ before_install: install: - export FLAGS="--no-terminal --no-copy-bins --flag accelerate:nofib" - - travis_retry travis_retry stack build $FLAGS --only-dependencies --test + - travis_retry stack build $FLAGS --only-dependencies --test script: - - stack build $FLAGS $HADDOCK --test --no-run-tests + - travis_retry travis_retry stack build $FLAGS $HADDOCK --test --no-run-tests - stack test accelerate:doctest $FLAGS - stack test accelerate:nofib-interpreter $FLAGS --test-arguments='--hedgehog-tests 25' From efbf02943f739bbb6be179e169e853d8d9c402e3 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 23 Sep 2019 16:06:28 +0200 Subject: [PATCH 089/316] travis: allow ghc-8.8 to fail \: --- .travis.yml | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/.travis.yml b/.travis.yml index ac9ab48eb..4d0774a96 100644 --- a/.travis.yml +++ b/.travis.yml @@ -42,12 +42,8 @@ matrix: - env: GHC=8.0.2 compiler: "GHC 8.0" - # - env: GHC=head CABAL=head - # compiler: "GHC HEAD" - # addons: { apt: { sources: [ hvr-ghc ], packages: [ ghc-head, cabal-install-head, happy-1.19.5, alex-3.1.7 ] }} - - # allow_failures: - # - env: GHC=head CABAL=head + allow_failures: + - env: GHC=8.8.1 # not enough memory \: before_install: - export PATH=/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:${PATH} @@ -67,7 +63,7 @@ install: - travis_retry stack build $FLAGS --only-dependencies --test script: - - travis_retry travis_retry stack build $FLAGS $HADDOCK --test --no-run-tests + - stack build $FLAGS $HADDOCK --test --no-run-tests - stack test accelerate:doctest $FLAGS - stack test accelerate:nofib-interpreter $FLAGS --test-arguments='--hedgehog-tests 25' From dd38687b9b53bd4ac77b195165d63c9ec7f8f23c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 23 Sep 2019 16:08:55 +0200 Subject: [PATCH 090/316] stack: wibble --- stack-8.8.yaml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/stack-8.8.yaml b/stack-8.8.yaml index 70f4785c4..df5de8ba9 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -80,10 +80,7 @@ extra-deps: - wl-pprint-annotated-0.1.0.1@sha256:0b8fd3649bfe72d155a4379e4c88b7ef00408f6f4973f63333787fd2e1b5ba1e,2214 # Override default flag values for local packages and extra-deps -flags: - accelerate: - debug: true - nofib: true +# flags: {} # Extra global and per-package GHC options # ghc-options: {} From 2763d3169608dc802f33d9ccd23408acd9aefdaf Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 23 Sep 2019 16:15:27 +0200 Subject: [PATCH 091/316] update README.md --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 728b8ca7a..78676ceec 100644 --- a/README.md +++ b/README.md @@ -90,7 +90,7 @@ Documentation * Haddock documentation is included and linked with the individual package releases on [Hackage][Hackage]. * Haddock documentation for in-development components can be found [here](http://tmcdonell-bot.github.io/accelerate-travis-buildbot/). - * The idea behind the HOAS (higher-order abstract syntax) to de-Bruijn conversion used in the library is [~~described separately~~][HOAS-conv]. + * The idea behind the HOAS (higher-order abstract syntax) to de-Bruijn conversion used in the library is [described separately][HOAS-conv]. Examples -------- @@ -251,7 +251,7 @@ Here is a list of features that are currently missing: [Wiki]: https://github.com/AccelerateHS/accelerate/wiki [Issues]: https://github.com/AccelerateHS/accelerate/issues [Google-Group]: http://groups.google.com/group/accelerate-haskell - [HOAS-conv]: http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ + [HOAS-conv]: https://web.archive.org/web/20180805092417/http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ [repa]: http://hackage.haskell.org/package/repa [wiki-cc]: https://en.wikipedia.org/wiki/CUDA#Supported_GPUs [YLJ13-video]: http://youtu.be/ARqE4yT2Z0o From cda49adc1ebc5b88d7e9876e5561e33d85c88656 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 26 Sep 2019 10:56:01 +0200 Subject: [PATCH 092/316] travis: before_cache --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 4d0774a96..3679c1697 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,6 +13,7 @@ cache: before_cache: # - rm -vrf $(stack path --local-install-root)/bin - rm -rf $(stack path --local-install-root)/doc + - rm -f $HOME/.stack/programs/*/*.tar.bz2 addons: apt: From 640d0ae6c9d9f1fe79b0a09b2db6748b6e77883b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 26 Sep 2019 10:57:10 +0200 Subject: [PATCH 093/316] stack/8.8: use nightly resolver --- stack-8.8.yaml | 75 ++------------------------------------------------ 1 file changed, 3 insertions(+), 72 deletions(-) diff --git a/stack-8.8.yaml b/stack-8.8.yaml index df5de8ba9..7132fea0e 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -1,83 +1,14 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: ghc-8.8.1 -allow-newer: true # transformers-compat +resolver: nightly-2019-09-26 packages: - . extra-deps: -- adjunctions-4.4@sha256:2738dd5f5d5e93749adb14a05472e58a96a75d0f299e46371c6f46dc4e97daf9,3067 -- ansi-terminal-0.10@sha256:69d3fc72208f2d8830c18636182e342fabee4859bc091a89a77fe84d5674156b,3224 -- ansi-wl-pprint-0.6.9@sha256:f6fd6dbd4adcad0432bf75e5f5b19bb1deda00a1d8056faf18090026e577652d,2388 -- async-2.2.2@sha256:ed46f0f5be36cf8a3e3aebc6827d015e1f3bf9615c245e057b9e9bd35faddd21,2895 -- base-compat-0.11.0@sha256:d92c8732c415ba6a3a1fa5fcc578e714c453685afba8d936ead91c496b0f546f,7043 -- base-orphans-0.8.1@sha256:defd0057b5db93257528d89b5b01a0fee9738e878c121c686948ac4aa5dded63,2927 -- basement-0.0.11@sha256:af43e2e334e515b52ca309919b135c51b5e9411e6d4c68d0e8950d61eb5f25d1,5711 -- bifunctors-5.5.5@sha256:e89def05aa5a9c729435592c11a35b54747558b1ec15c7283c7d61df03873ab6,3300 -- cabal-doctest-1.0.7@sha256:2a9d524b9593fc5054c0bcfda9aeaffd4203f3663b77fab57db35ddd48ce6ad3,1573 -- call-stack-0.2.0@sha256:5ce796b78d5f964468ec6fe0717b4e7d0430817f37370c47b3e6b38e345b6643,1202 -- clock-0.8@sha256:b4ae207e2d3761450060a0d0feb873269233898039c76fceef9cc1a544067767,4113 -- code-page-0.2@sha256:f701393cb1ff7b3ec7880816abc44387647811be31670e884e02d6a20c4aa508,2356 -- colour-2.3.5@sha256:b27db0a3ad40d70bdbd8510a104269f8707592e80757a1abc66a22ba25e5a42f,1801 -- comonad-5.0.5@sha256:b33bc635615647916e374a27e96c3de4df390684001eab6291283471cd3a9b62,3345 -- concurrent-output-1.10.10@sha256:5290b0900504fdfd32ded51bb3140f4eafaa14e3e2366b9ffa9c63db24a424ed,1651 -- constraints-0.11.2@sha256:d028005d93f891b48b61ff0c82c6f868859eb728010dea3e355b0c55d0f57cf9,2219 -- contravariant-1.5.2@sha256:853259271870000c007a281f0bf0bf6e1aaa97c5fd5cd5734d7b0d79b9de2af5,2761 -- cryptonite-0.26@sha256:43c722f3770c31f4c5376e7aa42645b104834103312e217aa7fe79316416d6df,17352 -- distributive-0.6.1@sha256:90cef5a2d9c2477775e382c96fc716763e517ffd99dc6843046b3eabb2a7ff29,3062 -- doctest-0.16.2@sha256:2f96e9bbe9aee11b47453c82c24b3dc76cdbb8a2a7c984dfd60b4906d08adf68,6942 -- exceptions-0.10.3@sha256:6e8e66f3acf2ea59f9e100c55a885591c1981789ac2222022ff523c30990efb8,2251 -- fail-4.9.0.0@sha256:35d1ee29364447c1b7d616bb1ee31f162b73e85fea91d7ca6441cf901398f572,1051 -- free-5.1.2@sha256:cd57d8cbaf8ef37620219095694b83e3b3baf3b06e1c59f422a4954d3a5f4c42,4116 -- ghc-paths-0.1.0.12@sha256:e7120e162fe070e01a80b0404dda2fd8c8c9feea48e75aec6286cdc05f81bb28,618 -- half-0.3@sha256:48cc70e3cd42ccd13039b8d5865ca3aeffe526572aff7e2baf9cf9c28bc31eeb,1316 -- happy-1.19.12@sha256:acc67bfbf3af87892766781dd064c9447181ea81269a7a1e5fc9ace4a8fa4768,5691 -- hashable-1.3.0.0@sha256:7ad8edaa681e81162ddddb4d703a9cffe6a0c9ddcfede31cf6569507ed3f1ddb,5179 -- hashtables-1.2.3.4@sha256:16a77784ba31ce90cfaab198b42a888fd30d838f9fd581c0efc5b7ee6dfe458f,8223 -- haskell-lexer-1.0.2@sha256:1c84537dbd29809c1004ccb156552429de35fe77fab6dd484ac8deb318cc6b64,917 -- hedgehog-1.0.1@sha256:b65b1ebde7b7fe8e693070916e45aa2ed63eea5e3f84ac3a8f9a0b7f8fcf0337,4465 -- invariant-0.5.3@sha256:cc403ccbb176435d7039e28916c8a54ad0971596b90f935a460582bb77a83148,3233 -- kan-extensions-5.2@sha256:2407501562039dad6a3d19aacd0bbcca07aa28497cbd1cdaaf5aabc30146899d,2771 -- lens-4.18.1@sha256:5c21912d5af370ae608a7e010c8a705e987e42e89bbed306de73f87166251c27,15419 -- lifted-async-0.10.0.4@sha256:f763f568b01f4d2e7f25f137d005445af2ffdaa08aa2406810b56c3b9e7acb07,2579 -- lifted-base-0.2.3.12@sha256:e94ad0692c9c5d85c373e508f23654f2da8ac8c3e475c2b65ffbc04fb165ad69,3369 -- memory-0.15.0@sha256:be7024b50e876a9c3b7febaefdd81d5dc67268c58a7b4e6b3825bdc58274d88c,5002 -- mmorph-1.1.3@sha256:abfc95648fef0008f984b94137ce8e1635fb071c7bfaaa7393ba175a1b3bb12f,919 -- monad-control-1.0.2.3@sha256:a3ae888d2fed2e2a0ca33ae11e2480219e07312bccf1a02ffe2ba2e3ec5913ee,2255 -- optparse-applicative-0.15.1.0@sha256:a0b9924d88a17c36cd8e6839d7dd2138419dd8f08cbb4f9af18f3c367b0c69a3,4673 -- parallel-3.2.2.0@sha256:924dc6f8ac94d535689070b96864da0913aee99d8e3354f9130e4d96d5b17328,1792 -- pretty-show-1.9.5@sha256:92aa3f43d8459a9b543e102fbb0b7a6aae0074e18ca6a9970d9922a867114f53,1963 -- prettyprinter-1.3.0@sha256:83336d853f38e72f9213a3051de11dcb3c948eb09903a34f312e4fef00d79f10,5537 -- prettyprinter-ansi-terminal-1.1.1.2@sha256:f4bc019f73f8721a628b36bfca80b4d721886f3d05c8f80117ed75d8b6878ea3,1894 -- primitive-0.7.0.0@sha256:ee352d97cc390d8513530029a2213a95c179a66c406906b18d03702c1d9ab8e5,3416 -- profunctors-5.5@sha256:685ab6c53705e184d9459714d381ca8a2d25ab62c069f88aec7b3664218f4b2c,2073 -- random-1.1@sha256:7b67624fd76ddf97c206de0801dc7e888097e9d572974be9b9ea6551d76965df,1777 -- reflection-2.1.5@sha256:8dca1275d0c12d9711890cf2e89cd1ec341f64b22c133d2e47a56b7f1a896557,3884 -- resourcet-1.2.2@sha256:8cd361114a67a1e18303569b022d39875eb38f91d5176b657f22b16866ccc395,1655 -- semigroupoids-5.3.3@sha256:260b62cb8539bb988e7f551f10a45ef1c81421c0d79010e9bde9321bad4982a7,7363 -- semigroups-0.19.1@sha256:ecae129621e0d2f77bef2f01e4458c2e0567ab6e1f39579c61d7cec8058ebb0e,6262 -- StateVar-1.2@sha256:9ab3e4a0e252d28bc2f799c83e0725c3e23e8d3b722cff0fdb9822e64b6c16ac,1413 -- syb-0.7.1@sha256:8d37b1e4d04a9aa8512dc6c2a06e02afc015a2fd3e735bdfeeacb5e2e853323c,2462 -- tagged-0.8.6@sha256:7093ee39c9779beeacffa4b0035a0e8a25da16afcd1c1a876930207fb8e31d1c,2606 -- tasty-1.2.3@sha256:bba67074e5326d57e8f53fc1dabcb6841daa4dc51b053506eb7f40a6f49a0497,2517 -- tasty-expected-failure-0.11.1.2@sha256:0b6c76793eb1eb76b0e36f5b4d1d2db25f1b7afa12549f1fa86a05a1ddaa10bc,1771 -- tasty-hedgehog-1.0.0.1@sha256:f632aa57399fbd9a0910757bd550e702e13752f9fd1fced0cc9e6b54dd49c7d8,1823 -- tasty-hunit-0.10.0.2@sha256:8e8bd5807cec650f5aebc5ada07b57620c863e69145e65249651c1b48d97bd70,1515 -- terminal-size-0.3.2.1@sha256:7b2d8e0475a46961d07ddfb91dee618de70eff55d9ba0402ebeac1f9dcf9b18b,1259 -- th-abstraction-0.3.1.0@sha256:96042f6658f2dccfac03b33f0fd59f62b1f65b9b0a765d8a2ea6026f4081ee4a,1838 -- transformers-base-0.4.5.2@sha256:e4d8155470905ba2942033a1537fc4cf91927d1c9b34693fd57ddf3bc02334af,1550 -- transformers-compat-0.6.5@sha256:50b00c57bf3fc379ec2477bfc261a2aebc983084488478adb29854f193af4696,5490 -- type-equality-1@sha256:aeb9c44abf5d2edf52caff114a7da565d8328fa84bbe194828e4355ea85bf5b3,1457 -- unbounded-delays-0.1.1.0@sha256:8e57c6ffb72ed605b85c69d3b3a7ebbbbb70bfb5e9b9816309f1f733240838f2,1184 -- unique-0@sha256:cbac09fc80d77605357a246b10a3dbd9250f39ce451a3f57ac24bf234d93b279,997 -- unliftio-core-0.1.2.0@sha256:7f9b48adef8e36da0202e6e70a733a5e210263ed4177c93e47a4b3f89694194b,1081 -- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204,5199 -- vector-0.12.0.3@sha256:1422b0bcf4e7675116ca8d9f473bf239850c58c4518a56010e3bfebeac345ace,7171 -- void-0.7.3@sha256:13d30f62fcdf065e595d679d4ac8b4b0c1bb1a1b73db7b5b5a8f857cb5c8a546,1857 -- wcwidth-0.0.2@sha256:77531eb6683c505c22ab3fa11bbc43d3ce1e7dac21401d4d5a19677d348bb5f3,1998 -- wl-pprint-annotated-0.1.0.1@sha256:0b8fd3649bfe72d155a4379e4c88b7ef00408f6f4973f63333787fd2e1b5ba1e,2214 +- prettyprinter-1.3.0 +- prettyprinter-ansi-terminal-1.1.1.2 # Override default flag values for local packages and extra-deps # flags: {} From 5f5838ad95d2de2b8eebd72b2bfb1093a74e2dfd Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 30 Sep 2019 18:43:06 +0200 Subject: [PATCH 094/316] warning police --- cbits/monitoring.c | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/cbits/monitoring.c b/cbits/monitoring.c index dd2c7d1be..c2d2e0bb9 100644 --- a/cbits/monitoring.c +++ b/cbits/monitoring.c @@ -12,6 +12,7 @@ * This is a hack to work around */ +#include #include #include @@ -58,22 +59,22 @@ static char* format_int64(char *buffer, int64_t x) if (x < 1000) { - sprintf(s, "%lld", x); + sprintf(s, "%"PRId64, x); } else if (x < 1000000) { - sprintf(s, "%lld,%03lld", x/1000, x%1000); + sprintf(s, "%"PRId64",%03"PRId64, x/1000, x%1000); } else if (x < 1000000000) { - sprintf(s, "%lld,%03lld,%03lld" + sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64 , x/1000000 , (x/1000)%1000 , x%1000); } else if (x < 1000000000000) { - sprintf(s, "%lld,%03lld,%03lld,%03lld" + sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64",%03"PRId64 , x/1000000000 , (x/1000000)%1000 , (x/1000)%1000 @@ -81,7 +82,7 @@ static char* format_int64(char *buffer, int64_t x) } else if (x < 1000000000000000) { - sprintf(s, "%lld,%03lld,%03lld,%03lld,%03lld" + sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64 , x/1000000000000 , (x/1000000000)%1000 , (x/1000000)%1000 @@ -90,7 +91,7 @@ static char* format_int64(char *buffer, int64_t x) } else if (x < 1000000000000000000) { - sprintf(s, "%lld,%03lld,%03lld,%03lld,%03lld,%03lld" + sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64 , x/1000000000000000 , (x/1000000000000)%1000 , (x/1000000000)%1000 @@ -100,7 +101,7 @@ static char* format_int64(char *buffer, int64_t x) } else { - sprintf(s, "%lld,%03lld,%03lld,%03lld,%03lld,%03lld,%03lld" + sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64 , x/1000000000000000000 , (x/1000000000000000)%1000 , (x/1000000000000)%1000 From 66e4600407deff57c342c22d77543fefefc100e9 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 1 Oct 2019 10:12:40 +0200 Subject: [PATCH 095/316] warning police --- cbits/flags.c | 10 +++++----- cbits/monitoring.c | 14 +++++++------- src/Data/Array/Accelerate/Debug/Flags.hs | 6 +++--- src/Data/Array/Accelerate/Trafo/Config.hs | 4 ++-- 4 files changed, 17 insertions(+), 17 deletions(-) diff --git a/cbits/flags.c b/cbits/flags.c index 231f137dc..1a2c8321e 100644 --- a/cbits/flags.c +++ b/cbits/flags.c @@ -19,6 +19,7 @@ #include #include +#include #include #include #include @@ -26,7 +27,6 @@ #include #include "flags.h" -#include "HsFFI.h" /* These globals will be accessed from the Haskell side to implement the @@ -34,8 +34,8 @@ */ __flags_t __cmd_line_flags = { 0xff }; // SEE: [layout of command line options bitfield] -HsInt __unfolding_use_threshold = 1; -HsInt __max_simplifier_iterations = 25; +uint32_t __unfolding_use_threshold = 1; +uint32_t __max_simplifier_iterations = 25; enum { OPT_ENABLE = 1, @@ -130,7 +130,7 @@ static void parse_options(int argc, char *argv[]) /* attempt to decode the argument to flags which require them */ case OPT_UNFOLDING_USE_THRESHOLD: - if (1 != sscanf(optarg, "%lld", &__unfolding_use_threshold)) { + if (1 != sscanf(optarg, "%"PRIu32, &__unfolding_use_threshold)) { fprintf(stderr, "%s: option `-%s' requires an integer argument, but got: %s\n" , basename(argv[0]) , longopts[longindex].name @@ -140,7 +140,7 @@ static void parse_options(int argc, char *argv[]) break; case OPT_MAX_SIMPLIFIER_ITERATIONS: - if (1 != sscanf(optarg, "%lld", &__max_simplifier_iterations)) { + if (1 != sscanf(optarg, "%"PRIu32, &__max_simplifier_iterations)) { fprintf(stderr, "%s: option `-%s' requires an integer argument, but got: %s\n" , basename(argv[0]) , longopts[longindex].name diff --git a/cbits/monitoring.c b/cbits/monitoring.c index c2d2e0bb9..fc8133267 100644 --- a/cbits/monitoring.c +++ b/cbits/monitoring.c @@ -59,22 +59,22 @@ static char* format_int64(char *buffer, int64_t x) if (x < 1000) { - sprintf(s, "%"PRId64, x); + sprintf(s, "%"PRIi64, x); } else if (x < 1000000) { - sprintf(s, "%"PRId64",%03"PRId64, x/1000, x%1000); + sprintf(s, "%"PRIi64",%03"PRIi64, x/1000, x%1000); } else if (x < 1000000000) { - sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64 + sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64 , x/1000000 , (x/1000)%1000 , x%1000); } else if (x < 1000000000000) { - sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64",%03"PRId64 + sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64 , x/1000000000 , (x/1000000)%1000 , (x/1000)%1000 @@ -82,7 +82,7 @@ static char* format_int64(char *buffer, int64_t x) } else if (x < 1000000000000000) { - sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64 + sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64 , x/1000000000000 , (x/1000000000)%1000 , (x/1000000)%1000 @@ -91,7 +91,7 @@ static char* format_int64(char *buffer, int64_t x) } else if (x < 1000000000000000000) { - sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64 + sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64 , x/1000000000000000 , (x/1000000000000)%1000 , (x/1000000000)%1000 @@ -101,7 +101,7 @@ static char* format_int64(char *buffer, int64_t x) } else { - sprintf(s, "%"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64",%03"PRId64 + sprintf(s, "%"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64",%03"PRIi64 , x/1000000000000000000 , (x/1000000000000000)%1000 , (x/1000000000000)%1000 diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index a1e5dd6fc..ef66b5354 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -55,7 +55,7 @@ import Control.Monad.IO.Class ( MonadIO, l import qualified Control.Monad as M newtype Flag = Flag Int -newtype Value = Value (Ptr Int) -- of type HsInt in flags.c +newtype Value = Value (Ptr Word32) -- see flags.c -- We aren't using a "real" enum so that we can make use of the unused top -- bits for other configuration options, not controlled by the command line @@ -128,10 +128,10 @@ unless _ _ = return () #endif -setValue :: Value -> Int -> IO () +setValue :: Value -> Word32 -> IO () setValue (Value f) v = poke f v -getValue :: Value -> IO Int +getValue :: Value -> IO Word32 getValue (Value f) = peek f getFlag :: Flag -> IO Bool diff --git a/src/Data/Array/Accelerate/Trafo/Config.hs b/src/Data/Array/Accelerate/Trafo/Config.hs index 0ba9fb291..a3f984023 100644 --- a/src/Data/Array/Accelerate/Trafo/Config.hs +++ b/src/Data/Array/Accelerate/Trafo/Config.hs @@ -41,8 +41,8 @@ data Config = Config defaultOptions :: Config defaultOptions = unsafePerformIO $! Config <$> (BitSet . (0x80000000 .|.)) <$> peek F.__cmd_line_flags - <*> F.getValue F.unfolding_use_threshold - <*> F.getValue F.max_simplifier_iterations + <*> (fromIntegral <$> F.getValue F.unfolding_use_threshold) + <*> (fromIntegral <$> F.getValue F.max_simplifier_iterations) -- Extra options not covered by command line flags -- From 78df290101c6103bf4ff6baf5473cef44bd16f97 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 4 Oct 2019 12:10:35 +0200 Subject: [PATCH 096/316] Perform runtime rank check in Show Array Instead of using an incoherent type class instance --- src/Data/Array/Accelerate/Array/Sugar.hs | 44 +++++++++--------------- 1 file changed, 17 insertions(+), 27 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 8f77f46d7..1f85f095f 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -697,30 +697,32 @@ instance (Shape sh, Elt e, Eq sh, Eq e) => Eq (Array sh e) where arr1 == arr2 = shape arr1 == shape arr2 && toList arr1 == toList arr2 arr1 /= arr2 = 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). +-- We perform the rank check at runtime, as we want a generic Show (Array sh e) +-- instance. Alternatives would be to create instances for Show (Array Z e), +-- Show (Array (Z :. Int) e) and so on. This would either require that the +-- instance for general ranks either works only for DIM3+ arrays, or mean +-- that the general case is defined with the INCOHERENT annotation. In the first +-- option, we do not have a general 'Show (Array sh e)' implementation, which +-- is an annoying limitation for users. In the second option, scalars, vectors and +-- matrices may not always be shown with their appropriate format. -- +instance {-# INCOHERENT #-} (Shape sh, Elt e) => Show (Array sh e) where + show arr = case shapeToList $ shape arr of + [] -> "Scalar Z " ++ show (toList arr) + [_] -> "Vector (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) + [cols, rows] -> showMatrix rows cols arr + _ -> "Array (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) + -- 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 Elt e => Show (Scalar e) where - show arr = - "Scalar Z " ++ show (toList arr) - -instance Elt e => Show (Vector e) where - show arr = - "Vector (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) - -instance Elt e => Show (Array DIM2 e) where - show arr = +showMatrix :: (Shape sh, Elt e) => Int -> Int -> Array sh e -> String +showMatrix rows cols arr = "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)))) -- @@ -747,18 +749,6 @@ instance Elt e => Show (Array DIM2 e) where | 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 #-} (Shape sh, Elt e) => Show (Array sh e) where - show arr = - "Array (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) instance Elt e => IsList (Vector e) where type Item (Vector e) = e From da4e0b7e2377c434a71cf53a3d70baa8bce4d956 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Mon, 7 Oct 2019 16:44:36 +0200 Subject: [PATCH 097/316] Code review --- src/Data/Array/Accelerate/Array/Sugar.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 1f85f095f..7562609ac 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -706,18 +706,17 @@ instance (Shape sh, Elt e, Eq sh, Eq e) => Eq (Array sh e) where -- is an annoying limitation for users. In the second option, scalars, vectors and -- matrices may not always be shown with their appropriate format. -- -instance {-# INCOHERENT #-} (Shape sh, Elt e) => Show (Array sh e) where +instance (Shape sh, Elt e) => Show (Array sh e) where show arr = case shapeToList $ shape arr of - [] -> "Scalar Z " ++ show (toList arr) - [_] -> "Vector (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) + [] -> "Scalar Z " ++ show (toList arr) + [_] -> "Vector (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) [cols, rows] -> showMatrix rows cols arr - _ -> "Array (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) + _ -> "Array (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) -- 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 +-- 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. -- showMatrix :: (Shape sh, Elt e) => Int -> Int -> Array sh e -> String showMatrix rows cols arr = From 8aac892e905cda7b0413d59daca2725a93be34ac Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 6 Nov 2019 14:37:42 +0100 Subject: [PATCH 098/316] Change AST to work with representation types In the Smart AST and internal AST: - The type argument regards representation types. We now distinguish SmartAcc and Acc in the Smart AST, the first works on representation types, the latter on surface types - Tuples of arrays are now embedded in the AST using pairs and nils - The Arrays type class is not used in the ASTs, instead we add the data type ArrRepr which acts as evidence to some constructors In the internal AST: - Projections are removed - A let binding may declare multiple variables. If the right hand side is a tuple, it is destructured into multiple variables, such that each variable is an array --- src/Data/Array/Accelerate.hs | 2 +- src/Data/Array/Accelerate/AST.hs | 266 ++++--- src/Data/Array/Accelerate/Array/Sugar.hs | 28 +- src/Data/Array/Accelerate/Language.hs | 67 +- src/Data/Array/Accelerate/Lift.hs | 2 +- src/Data/Array/Accelerate/Pattern.hs | 4 +- src/Data/Array/Accelerate/Smart.hs | 868 +++++++++++++---------- 7 files changed, 713 insertions(+), 524 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 137cb67cf..b290adae2 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -330,7 +330,7 @@ module Data.Array.Accelerate ( -- ** Pattern synonyms -- $pattern_synonyms -- - pattern Pattern, IsProduct, IsTuple, IsAtuple, + pattern Pattern, IsProduct, IsTuple, pattern T2, pattern T3, pattern T4, pattern T5, pattern T6, pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 47e7b1d34..7bbed7359 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -83,14 +83,15 @@ module Data.Array.Accelerate.AST ( -- * Typed de Bruijn indices - Idx(..), idxToInt, tupleIdxToInt, + Idx(..), idxToInt, tupleIdxToInt, ArrayVar(..), ArrayVars(..), -- * Valuation environment - Val(..), ValElt(..), prj, prjElt, + Val(..), ValElt(..), push, prj, prjElt, -- * Accelerated array expressions PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc, PreBoundary(..), Boundary, Stencil(..), StencilR(..), + LeftHandSide(..), HasArraysRepr(..), lhsToArraysR, -- * Accelerated sequences -- PreOpenSeq(..), Seq, @@ -111,6 +112,9 @@ module Data.Array.Accelerate.AST ( liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp, + -- Utilities + Exists(..), weakenWithLHS, (:>), + -- debugging showPreAccOp, showPreExpOp, @@ -180,9 +184,13 @@ tupleIdxToInt (SuccTupIdx idx) = 1 + tupleIdxToInt idx data Val env where Empty :: Val () Push :: Val env -> t -> Val (env, t) - deriving instance Typeable Val +push :: Val env -> (LeftHandSide arrs env env', arrs) -> Val env' +push env (LeftHandSideWildcard _, _ ) = env +push env (LeftHandSideArray , a ) = env `Push` a +push env (LeftHandSidePair l1 l2, (a, b)) = push env (l1, a) `push` (l2, b) + -- Valuation for an environment of array elements -- data ValElt env where @@ -214,8 +222,8 @@ prjElt _ _ = $internalError "prjElt" "inconsistent val -- | 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) + Abody :: acc aenv t -> PreOpenAfun acc aenv t + Alam :: LeftHandSide a aenv aenv' -> PreOpenAfun acc aenv' t -> PreOpenAfun acc aenv (a -> t) -- Function abstraction over vanilla open array computations -- @@ -240,6 +248,47 @@ type Acc = OpenAcc () deriving instance Typeable PreOpenAcc deriving instance Typeable OpenAcc +data LeftHandSide arrs env env' where + LeftHandSideArray + :: (Shape sh, Elt e) + => LeftHandSide (Array sh e) env (env, Array sh e) + + -- Note: a unit is represented as LeftHandSide ArraysRunit + LeftHandSideWildcard + :: ArraysR arrs + -> LeftHandSide arrs env env + + LeftHandSidePair + :: LeftHandSide arrs1 env env' + -> LeftHandSide arrs2 env' env'' + -> LeftHandSide (arrs1, arrs2) env env'' + +lhsToArraysR :: LeftHandSide arrs aenv aenv' -> ArraysR arrs +lhsToArraysR LeftHandSideArray = ArraysRarray +lhsToArraysR (LeftHandSideWildcard r) = r +lhsToArraysR (LeftHandSidePair as bs) = ArraysRpair (lhsToArraysR as) (lhsToArraysR bs) + +-- The type of shifting terms from one context into another +-- +type env :> env' = forall t'. Idx env t' -> Idx env' t' + +weakenWithLHS :: LeftHandSide arrs env env' -> env :> env' +weakenWithLHS (LeftHandSideWildcard _) = id +weakenWithLHS LeftHandSideArray = SuccIdx +weakenWithLHS (LeftHandSidePair lhs1 lhs2) = weakenWithLHS lhs2 . weakenWithLHS lhs1 + +-- Often useful when working with LeftHandSide, when you need to +-- existentially quantify on the resulting environment type. +data Exists f where + Exists :: f a -> Exists f + +data ArrayVar aenv arr where + ArrayVar :: (Shape sh, Elt e) => Idx aenv (Array sh e) -> ArrayVar aenv (Array sh e) + +data ArrayVars aenv arrs where + ArrayVarsArray :: ArrayVar aenv a -> ArrayVars aenv a + ArrayVarsNil :: ArrayVars aenv () + ArrayVarsPair :: ArrayVars aenv a -> ArrayVars aenv b -> ArrayVars aenv (a, b) -- | Collective array computations parametrised over array variables -- represented with de Bruijn indices. @@ -265,35 +314,30 @@ data PreOpenAcc acc aenv a where -- Local non-recursive binding to represent sharing and demand -- explicitly. Note 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 + Alet :: LeftHandSide bndArrs aenv aenv' + -> acc aenv bndArrs -- bound expression + -> acc aenv' 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 + Avar :: ArrayVar aenv (Array sh e) + -> PreOpenAcc acc aenv (Array sh e) -- Tuples of arrays -- - Atuple :: (Arrays arrs, IsAtuple arrs) - => Atuple (acc aenv) (TupleRepr arrs) - -> PreOpenAcc acc aenv arrs + Apair :: acc aenv as + -> acc aenv bs + -> PreOpenAcc acc aenv (as, bs) - Aprj :: (Arrays arrs, IsAtuple arrs, Arrays a) - => TupleIdx (TupleRepr arrs) a - -> acc aenv arrs - -> PreOpenAcc acc aenv a + Anil :: PreOpenAcc acc aenv () -- 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) + Apply :: PreOpenAfun acc aenv (arrs1 -> arrs2) -> acc aenv arrs1 -> PreOpenAcc acc aenv arrs2 @@ -302,23 +346,21 @@ data PreOpenAcc acc aenv a where -- 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 + => asm (as -> bs) -- The foreign function for a given backend + -> PreAfun acc (ArrRepr as -> ArrRepr bs) -- Fallback implementation(s) + -> acc aenv (ArrRepr as) -- Arguments to the function + -> PreOpenAcc acc aenv (ArrRepr bs) -- If-then-else for array-level computations -- - Acond :: Arrays arrs - => PreExp acc aenv Bool + Acond :: 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 + Awhile :: 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 @@ -327,8 +369,8 @@ data PreOpenAcc acc aenv a where -- Array inlet. Triggers (possibly) asynchronous host->device transfer if -- necessary. -- - Use :: Arrays arrs - => ArrRepr arrs + Use :: ArraysR arrs + -> arrs -> PreOpenAcc acc aenv arrs -- Capture a scalar (or a tuple of scalars) in a singleton array @@ -457,7 +499,7 @@ data PreOpenAcc acc aenv a where => 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) + -> PreOpenAcc acc aenv (ArrRepr (Array (sh:.Int) e, Array sh e)) -- Haskell-style scan without an initial value -- @@ -480,7 +522,7 @@ data PreOpenAcc acc aenv a where => 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) + -> PreOpenAcc acc aenv (ArrRepr (Array (sh:.Int) e, Array sh e)) -- Right-to-left version of 'Scanl1' -- @@ -801,7 +843,48 @@ instance (Stencil (sh:.Int) a row1, => 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 - +class HasArraysRepr f where + arraysRepr :: f aenv a -> ArraysR a + +instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where + arraysRepr (Alet _ _ body) = arraysRepr body + arraysRepr (Avar ArrayVar{}) = ArraysRarray + arraysRepr (Apair as bs) = ArraysRpair (arraysRepr as) (arraysRepr bs) + arraysRepr Anil = ArraysRunit + arraysRepr (Apply (Alam _ (Abody a)) _) = arraysRepr a + arraysRepr (Apply _ _) = error "Tomorrow will arive, on time" + arraysRepr (Aforeign _ (Alam _ (Abody a)) _) = arraysRepr a + arraysRepr (Aforeign _ (Abody _) _) = error "And what have you got, at the end of the day?" + arraysRepr (Aforeign _ (Alam _ (Alam _ _)) _) = error "A bottle of whisky. And a new set of lies." + arraysRepr (Acond _ whenTrue _) = arraysRepr whenTrue + arraysRepr (Awhile _ (Alam lhs _) _) = lhsToArraysR lhs + arraysRepr (Awhile _ _ _) = error "I want my, I want my MTV!" + arraysRepr (Use repr _) = repr + arraysRepr Unit{} = ArraysRarray + arraysRepr Reshape{} = ArraysRarray + arraysRepr Generate{} = ArraysRarray + arraysRepr Transform{} = ArraysRarray + arraysRepr Replicate{} = ArraysRarray + arraysRepr Slice{} = ArraysRarray + arraysRepr Map{} = ArraysRarray + arraysRepr ZipWith{} = ArraysRarray + arraysRepr Fold{} = ArraysRarray + arraysRepr Fold1{} = ArraysRarray + arraysRepr FoldSeg{} = ArraysRarray + arraysRepr Fold1Seg{} = ArraysRarray + arraysRepr Scanl{} = ArraysRarray + arraysRepr Scanl'{} = arraysRtuple2 + arraysRepr Scanl1{} = ArraysRarray + arraysRepr Scanr{} = ArraysRarray + arraysRepr Scanr'{} = arraysRtuple2 + arraysRepr Scanr1{} = ArraysRarray + arraysRepr Permute{} = ArraysRarray + arraysRepr Backpermute{} = ArraysRarray + arraysRepr Stencil{} = ArraysRarray + arraysRepr Stencil2{} = ArraysRarray + +instance HasArraysRepr OpenAcc where + arraysRepr (OpenAcc a) = arraysRepr a -- Embedded expressions -- -------------------- @@ -1134,7 +1217,7 @@ 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 +rnfPreOpenAfun rnfA (Alam lhs f) = rnfLHS lhs `seq` rnfPreOpenAfun rnfA f rnfPreOpenAcc :: forall acc aenv t. NFDataAcc acc -> PreOpenAcc acc aenv t -> () rnfPreOpenAcc rnfA pacc = @@ -1155,15 +1238,15 @@ rnfPreOpenAcc rnfA pacc = 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 + Alet lhs bnd body -> rnfLHS lhs `seq` rnfA bnd `seq` rnfA body + Avar (ArrayVar ix) -> rnfIdx ix + Apair as bs -> rnfA as `seq` rnfA bs + Anil -> () 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 @t) arrs + Use repr arrs -> rnfArrays repr arrs Unit x -> rnfE x Reshape sh a -> rnfE sh `seq` rnfA a Generate sh f -> rnfE sh `seq` rnfF f @@ -1188,10 +1271,15 @@ rnfPreOpenAcc rnfA pacc = Stencil2 f b1 a1 b2 a2 -> rnfF f `seq` rnfB b1 `seq` rnfB b2 `seq` rnfA a1 `seq` rnfA a2 -- Collect s -> rnfS s +rnfLHS :: LeftHandSide arrs aenv aenv' -> () +rnfLHS (LeftHandSideWildcard r) = rnfArraysR r +rnfLHS LeftHandSideArray = () +rnfLHS (LeftHandSidePair ar1 ar2) = rnfLHS ar1 `seq` rnfLHS ar2 -rnfAtuple :: NFDataAcc acc -> Atuple (acc aenv) t -> () -rnfAtuple _ NilAtup = () -rnfAtuple rnfA (SnocAtup tup a) = rnfAtuple rnfA tup `seq` rnfA a +rnfArraysR :: ArraysR arrs -> () +rnfArraysR ArraysRunit = () +rnfArraysR ArraysRarray = () +rnfArraysR (ArraysRpair ar1 ar2) = rnfArraysR ar1 `seq` rnfArraysR ar2 rnfArrays :: ArraysR arrs -> arrs -> () rnfArrays ArraysRunit () = () @@ -1460,8 +1548,8 @@ 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) ||] +liftPreOpenAfun liftA (Alam lhs f) = [|| Alam $$(liftLHS lhs) $$(liftPreOpenAfun liftA f) ||] +liftPreOpenAfun liftA (Abody b) = [|| Abody $$(liftA b) ||] liftPreOpenAcc :: forall acc aenv a. @@ -1482,20 +1570,17 @@ liftPreOpenAcc liftA pacc = 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) ||] + Alet lhs bnd body -> [|| Alet $$(liftLHS lhs) $$(liftA bnd) $$(liftA body) ||] + Avar (ArrayVar ix) -> [|| Avar (ArrayVar $$(liftIdx ix)) ||] + Apair as bs -> [|| Apair $$(liftA as) $$(liftA bs) ||] + Anil -> [|| Anil ||] 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 @a) a) ||] + Use repr a -> [|| Use $$(liftArraysR repr) $$(liftArrays repr a) ||] Unit e -> [|| Unit $$(liftE e) ||] Reshape sh a -> [|| Reshape $$(liftE sh) $$(liftA a) ||] Generate sh f -> [|| Generate $$(liftE sh) $$(liftF f) ||] @@ -1519,6 +1604,15 @@ liftPreOpenAcc liftA pacc = 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) ||] +liftLHS :: LeftHandSide arrs aenv aenv' -> Q (TExp (LeftHandSide arrs aenv aenv')) +liftLHS (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftArraysR r) ||] +liftLHS LeftHandSideArray = [|| LeftHandSideArray ||] +liftLHS (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftLHS a) $$(liftLHS b) ||] + +liftArraysR :: ArraysR arrs -> Q (TExp (ArraysR arrs)) +liftArraysR ArraysRunit = [|| ArraysRunit ||] +liftArraysR ArraysRarray = [|| ArraysRarray ||] +liftArraysR (ArraysRpair a b) = [|| ArraysRpair $$(liftArraysR a) $$(liftArraysR b) ||] liftPreOpenFun :: LiftAcc acc @@ -1839,41 +1933,41 @@ liftSingleType (NonNumSingleType t) = [|| NonNumSingleType $$(liftNonNumType t) -- ========= 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 Alet{} = "Alet" +showPreAccOp (Avar (ArrayVar ix)) = "Avar a" ++ show (idxToInt ix) +showPreAccOp (Use repr a) = "Use " ++ showArrays repr a +showPreAccOp Apply{} = "Apply" +showPreAccOp Aforeign{} = "Aforeign" +showPreAccOp Acond{} = "Acond" +showPreAccOp Awhile{} = "Awhile" +showPreAccOp Apair{} = "Apair" +showPreAccOp Anil = "Anil" +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 @arrs) . fromArr +showArrays :: forall arrs. ArraysR arrs -> arrs -> String +showArrays repr = display . collect repr where collect :: ArraysR a -> a -> [String] collect ArraysRunit _ = [] diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 17b4be42a..245009516 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -34,7 +34,7 @@ module Data.Array.Accelerate.Array.Sugar ( -- * Array representation Array(..), Scalar, Vector, Matrix, Segments, - Arrays(..), ArraysR(..), + Arrays(..), ArraysR(..), arraysRtuple2, -- * Class of supported surface element types and their mapping to representation types Elt(..), @@ -51,10 +51,9 @@ module Data.Array.Accelerate.Array.Sugar ( -- * Array shape query, indexing, and conversions shape, reshape, (!), (!!), allocateArray, fromFunction, fromFunctionM, fromList, toList, concatVectors, - -- * Tuples + -- * Tuples of expressions TupleR, TupleRepr, tuple, Tuple(..), IsTuple, fromTuple, toTuple, - Atuple(..), IsAtuple, fromAtuple, toAtuple, -- * Miscellaneous showShape, Foreign(..), sliceShape, enumSlices, @@ -450,7 +449,7 @@ class Typeable asm => Foreign asm where type TupleRepr a = ProdRepr a type TupleR a = ProdR Elt a type IsTuple = IsProduct Elt -type IsAtuple = IsProduct Arrays +-- type IsAtuple = IsProduct Arrays -- |We represent tuples as heterogeneous lists, typed by a type list. -- @@ -458,15 +457,6 @@ 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 -- @@ -479,12 +469,6 @@ fromTuple = fromProd @Elt toTuple :: IsTuple tup => TupleRepr tup -> tup toTuple = toProd @Elt -fromAtuple :: IsAtuple tup => tup -> TupleRepr tup -fromAtuple = fromProd @Arrays - -toAtuple :: IsAtuple tup => TupleRepr tup -> tup -toAtuple = toProd @Arrays - -- Arrays -- ------ @@ -621,10 +605,8 @@ data ArraysR arrs where 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 +arraysRtuple2 :: (Shape sh1, Elt e1, Shape sh2, Elt e2) => ArraysR (((), Array sh2 e2), Array sh1 e1) +arraysRtuple2 = ArraysRpair ArraysRunit ArraysRarray `ArraysRpair` ArraysRarray {-# RULES "fromArr/toArr" forall a. fromArr (toArr a) = a diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 49429fa44..946257a6e 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -161,13 +162,13 @@ import Prelude ( ($), (.) ) -- >>> let tup = use (vec, mat) :: Acc (Vector Int, Matrix Int) -- use :: Arrays arrays => arrays -> Acc arrays -use = Acc . Use +use = Acc . SmartAcc . 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 +unit = Acc . SmartAcc . Unit -- | Replicate an array across one or more dimensions as specified by the -- /generalised/ array index provided as the first argument. @@ -255,7 +256,7 @@ replicate => Exp slix -> Acc (Array (SliceShape slix) e) -> Acc (Array (FullShape slix) e) -replicate = Acc $$ Replicate +replicate = Acc $$ applyAcc Replicate -- | Construct a new array by applying a function to each index. -- @@ -291,7 +292,7 @@ generate => Exp sh -> (Exp sh -> Exp a) -> Acc (Array sh a) -generate = Acc $$ Generate +generate = Acc $$ applyAcc Generate -- Shape manipulation -- ------------------ @@ -310,7 +311,7 @@ reshape => Exp sh -> Acc (Array sh' e) -> Acc (Array sh e) -reshape = Acc $$ Reshape +reshape = Acc $$ applyAcc Reshape -- Extraction of sub-arrays -- ------------------------ @@ -384,7 +385,7 @@ slice :: (Slice slix, Elt e) => Acc (Array (FullShape slix) e) -> Exp slix -> Acc (Array (SliceShape slix) e) -slice = Acc $$ Slice +slice = Acc $$ applyAcc Slice -- Map-like functions -- ------------------ @@ -404,7 +405,7 @@ map :: (Shape sh, Elt a, Elt b) => (Exp a -> Exp b) -> Acc (Array sh a) -> Acc (Array sh b) -map = Acc $$ Map +map = Acc $$ applyAcc 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 @@ -437,7 +438,7 @@ zipWith :: (Shape sh, Elt a, Elt b, Elt c) -> Acc (Array sh a) -> Acc (Array sh b) -> Acc (Array sh c) -zipWith = Acc $$$ ZipWith +zipWith = Acc $$$ applyAcc ZipWith -- Reductions -- ---------- @@ -508,7 +509,7 @@ fold :: (Shape sh, Elt a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array sh a) -fold = Acc $$$ Fold +fold = Acc $$$ applyAcc Fold -- | Variant of 'fold' that requires the innermost dimension of the array to be -- non-empty and doesn't need an default value. @@ -524,7 +525,7 @@ fold1 :: (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array sh a) -fold1 = Acc $$ Fold1 +fold1 = Acc $$ applyAcc Fold1 -- | Segmented reduction along the innermost dimension of an array. The -- segment descriptor specifies the starting index (offset) along the @@ -546,7 +547,7 @@ foldSeg' -> Acc (Array (sh:.Int) a) -> Acc (Segments i) -> Acc (Array (sh:.Int) a) -foldSeg' = Acc $$$$ FoldSeg +foldSeg' = Acc $$$$ applyAcc 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 @@ -561,7 +562,7 @@ fold1Seg' -> Acc (Array (sh:.Int) a) -> Acc (Segments i) -> Acc (Array (sh:.Int) a) -fold1Seg' = Acc $$$ Fold1Seg +fold1Seg' = Acc $$$ applyAcc Fold1Seg -- Scan functions -- -------------- @@ -588,7 +589,7 @@ scanl :: (Shape sh, Elt a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanl = Acc $$$ Scanl +scanl = Acc $$$ applyAcc Scanl -- | Variant of 'scanl', where the last element (final reduction result) along -- each dimension is returned separately. Denotationally we have: @@ -621,7 +622,7 @@ scanl' :: (Shape sh, Elt a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a, Array sh a) -scanl' = Acc $$$ Scanl' +scanl' = Acc $$$ applyAcc 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 @@ -639,7 +640,7 @@ scanl1 :: (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanl1 = Acc $$ Scanl1 +scanl1 = Acc $$ applyAcc Scanl1 -- | Right-to-left variant of 'scanl'. -- @@ -648,7 +649,7 @@ scanr :: (Shape sh, Elt a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanr = Acc $$$ Scanr +scanr = Acc $$$ applyAcc Scanr -- | Right-to-left variant of 'scanl''. -- @@ -657,7 +658,7 @@ scanr' :: (Shape sh, Elt a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a, Array sh a) -scanr' = Acc $$$ Scanr' +scanr' = Acc $$$ applyAcc Scanr' -- | Right-to-left variant of 'scanl1'. -- @@ -665,7 +666,7 @@ scanr1 :: (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanr1 = Acc $$ Scanr1 +scanr1 = Acc $$ applyAcc Scanr1 -- Permutations -- ------------ @@ -769,7 +770,7 @@ permute -> (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 +permute = Acc $$$$ applyAcc Permute -- | Generalised backward permutation operation (array gather). -- @@ -820,7 +821,7 @@ backpermute -> (Exp sh' -> Exp sh) -- ^ index permutation function -> Acc (Array sh a) -- ^ source array -> Acc (Array sh' a) -backpermute = Acc $$$ Backpermute +backpermute = Acc $$$ applyAcc Backpermute -- Stencil operations @@ -933,7 +934,8 @@ stencil -> 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 +stencil f (Boundary b) (Acc a) + = Acc $ SmartAcc $ 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 @@ -947,7 +949,8 @@ stencil2 -> 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 +stencil2 f (Boundary b1) (Acc a1) (Boundary b2) (Acc a2) + = Acc $ SmartAcc $ 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. @@ -1150,12 +1153,12 @@ collect = Acc . Collect -- For an example see the package. -- foreignAcc - :: (Arrays as, Arrays bs, Foreign asm) + :: forall as bs asm. (Arrays as, Arrays bs, Foreign asm) => asm (as -> bs) -> (Acc as -> Acc bs) -> Acc as -> Acc bs -foreignAcc = Acc $$$ Aforeign +foreignAcc asm f (Acc as) = Acc $ SmartAcc $ Aforeign asm f as -- | Call a foreign scalar expression. -- @@ -1192,8 +1195,8 @@ foreignExp = Exp $$$ Foreign -- function. -- infixl 1 >-> -(>->) :: (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b) -> (Acc b -> Acc c) -> (Acc a -> Acc c) -(>->) = Acc $$$ Pipe +(>->) :: forall a b c. (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b) -> (Acc b -> Acc c) -> (Acc a -> Acc c) +(>->) = Acc $$$ applyAcc $ Pipe (arrays @a) (arrays @b) -- Flow control constructs @@ -1209,18 +1212,18 @@ acond :: Arrays a -> Acc a -- ^ then-array -> Acc a -- ^ else-array -> Acc a -acond = Acc $$$ Acond +acond = Acc $$$ applyAcc $ 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 +awhile :: forall a. 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 +awhile = Acc $$$ applyAcc $ Awhile $ arrays @a -- Shapes and indices @@ -1298,7 +1301,7 @@ while = Exp $$$ While -- infixl 9 ! (!) :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -> Exp e -(!) = Exp $$ Index +Acc a ! ix = Exp $ Index a ix -- | Extract the value from an array at the specified linear index. -- Multidimensional arrays in Accelerate are stored in row-major order with @@ -1318,12 +1321,12 @@ infixl 9 ! -- infixl 9 !! (!!) :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp Int -> Exp e -(!!) = Exp $$ LinearIndex +Acc a !! ix = Exp $ LinearIndex a ix -- | Extract the shape (extent) of an array. -- shape :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -shape = Exp . Shape +shape = Exp . Shape . unAcc -- | The number of elements in the array -- diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 549e07caa..3e271e46d 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -479,7 +479,7 @@ instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, instance (Shape sh, Elt e) => Lift Acc (Array sh e) where type Plain (Array sh e) = Array sh e - lift = Acc . Use + lift = Acc . SmartAcc . 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) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index c79d352b6..d29dbceb2 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -300,12 +300,10 @@ $(runQ $ do destruct _x = $(tupE (map (get [|_x|]) [(n-1), (n-2) .. 0])) |] - mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [| Atuple |] [| Aprj |] [| NilAtup |] [| SnocAtup |] mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] -- -- - as <- mapM mkAccPattern [0..16] es <- mapM mkExpPattern [0..16] - return (concat as ++ concat es) + return $ concat es ) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 8ed698a22..358868eba 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -27,7 +27,8 @@ module Data.Array.Accelerate.Smart ( -- * HOAS AST - Acc(..), PreAcc(..), Exp(..), PreExp(..), Boundary(..), PreBoundary(..), Stencil(..), Level, + Acc(..), SmartAcc(..), PreSmartAcc(..), PairIdx(..), Exp(..), PreExp(..), + Boundary(..), PreBoundary(..), Stencil(..), Level, -- * Smart constructors for literals constant, undef, @@ -63,7 +64,7 @@ module Data.Array.Accelerate.Smart ( mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkUnsafeCoerce, -- * Auxiliary functions - ($$), ($$$), ($$$$), ($$$$$), + ($$), ($$$), ($$$$), ($$$$$), unAcc, unAccFunction, ApplyAcc(..), -- Debugging showPreAccOp, showPreExpOp, @@ -272,7 +273,9 @@ import qualified Data.Array.Accelerate.AST as AST -- 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) +newtype Acc a = Acc (SmartAcc (ArrRepr a)) + +newtype SmartAcc a = SmartAcc (PreSmartAcc SmartAcc Exp a) deriving instance Typeable Acc @@ -283,160 +286,166 @@ type Level = Int -- | Array-valued collective computations without a recursive knot -- -data PreAcc acc exp as where +data PreSmartAcc acc exp as where -- Needed for conversion to de Bruijn form - Atag :: Arrays as + Atag :: Typeable as => Level -- environment size at defining occurrence - -> PreAcc acc exp as + -> PreSmartAcc acc exp as - Pipe :: (Arrays as, Arrays bs, Arrays cs) - => (Acc as -> acc bs) - -> (Acc bs -> acc cs) + Pipe :: (Typeable as, Typeable bs, Typeable cs) + => ArraysR as + -> ArraysR bs + -> (SmartAcc as -> acc bs) + -> (SmartAcc bs -> acc cs) -> acc as - -> PreAcc acc exp cs + -> PreSmartAcc acc exp cs - Aforeign :: (Arrays as, Arrays bs, Foreign asm) + Aforeign :: (Typeable (ArrRepr as), Typeable (ArrRepr bs), Arrays as, Arrays bs, Foreign asm) => asm (as -> bs) -> (Acc as -> Acc bs) - -> acc as - -> PreAcc acc exp bs + -> acc (ArrRepr as) + -> PreSmartAcc acc exp (ArrRepr bs) - Acond :: Arrays as + Acond :: Typeable as => exp Bool -> acc as -> acc as - -> PreAcc acc exp as + -> PreSmartAcc acc exp as - Awhile :: Arrays arrs - => (Acc arrs -> acc (Scalar Bool)) - -> (Acc arrs -> acc arrs) + Awhile :: Typeable arrs + => ArraysR arrs + -> (SmartAcc arrs -> acc (Scalar Bool)) + -> (SmartAcc arrs -> acc arrs) -> acc arrs - -> PreAcc acc exp arrs + -> PreSmartAcc acc exp arrs + + Anil :: PreSmartAcc acc exp () - Atuple :: (Arrays arrs, IsAtuple arrs) - => Atuple acc (TupleRepr arrs) - -> PreAcc acc exp arrs + Apair :: (Typeable arrs1, Typeable arrs2) + => acc arrs1 + -> acc arrs2 + -> PreSmartAcc acc exp (arrs1, arrs2) - Aprj :: (Arrays arrs, IsAtuple arrs, Arrays a) - => TupleIdx (TupleRepr arrs) a - -> acc arrs - -> PreAcc acc exp a + Aprj :: (Typeable arrs1, Typeable arrs2) + => PairIdx (arrs1, arrs2) arrs + -> acc (arrs1, arrs2) + -> PreSmartAcc acc exp arrs - Use :: Arrays arrs + Use :: (Arrays arrs, Typeable (ArrRepr arrs)) => arrs - -> PreAcc acc exp arrs + -> PreSmartAcc acc exp (ArrRepr arrs) Unit :: Elt e => exp e - -> PreAcc acc exp (Scalar e) + -> PreSmartAcc acc exp (Scalar e) Generate :: (Shape sh, Elt e) => exp sh -> (Exp sh -> exp e) - -> PreAcc acc exp (Array sh e) + -> PreSmartAcc acc exp (Array sh e) Reshape :: (Shape sh, Shape sh', Elt e) => exp sh -> acc (Array sh' e) - -> PreAcc acc exp (Array sh e) + -> PreSmartAcc acc exp (Array sh e) Replicate :: (Slice slix, Elt e) => exp slix -> acc (Array (SliceShape slix) e) - -> PreAcc acc exp (Array (FullShape slix) e) + -> PreSmartAcc 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) + -> PreSmartAcc 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') + -> PreSmartAcc 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) + -> PreSmartAcc 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) + -> PreSmartAcc 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) + -> PreSmartAcc 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) + -> PreSmartAcc 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) + -> PreSmartAcc 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) + -> PreSmartAcc 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) + -> PreSmartAcc acc exp (ArrRepr (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) + -> PreSmartAcc 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) + -> PreSmartAcc 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) + -> PreSmartAcc acc exp (ArrRepr (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) + -> PreSmartAcc 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) + -> PreSmartAcc 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) + -> PreSmartAcc 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) + -> PreSmartAcc 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) @@ -444,12 +453,15 @@ data PreAcc acc exp as where -> acc (Array sh a) -> PreBoundary acc exp (Array sh b) -> acc (Array sh b) - -> PreAcc acc exp (Array sh c) + -> PreSmartAcc acc exp (Array sh c) -- Collect :: Arrays arrs -- => seq arrs - -- -> PreAcc acc seq exp arrs + -- -> PreSmartAcc acc seq exp arrs +data PairIdx p a where + PairIdxLeft :: PairIdx (a, b) a + PairIdxRight :: PairIdx (a, b) b {-- data PreSeq acc seq exp arrs where @@ -580,7 +592,7 @@ deriving instance Typeable Seq -- efficiently on constrained hardware such as GPUs, and is thus currently -- unsupported. -- -newtype Exp t = Exp (PreExp Acc Exp t) +newtype Exp t = Exp (PreExp SmartAcc Exp t) deriving instance Typeable Exp @@ -702,467 +714,459 @@ data PreExp acc exp t where -- Smart constructors and destructors for array tuples -- --------------------------------------------------- +nilAtup :: SmartAcc () +nilAtup = SmartAcc Anil + +snocAtup :: (Typeable a, Arrays b) => SmartAcc a -> Acc b -> SmartAcc (a, ArrRepr b) +snocAtup a (Acc b) = SmartAcc $ Apair a b + atup2 :: (Arrays a, Arrays b) => (Acc a, Acc b) -> Acc (a, b) atup2 (a, b) = Acc - $ Atuple - $ NilAtup `SnocAtup` a - `SnocAtup` b + $ 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 + = Acc + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 ) +unatup2 (Acc e) = + ( aprj1 e + , aprj0 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 ) +unatup3 (Acc e) = + ( aprj2 e + , aprj1 e + , aprj0 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 ) +unatup4 (Acc e) = + ( aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup5 (Acc e) = + ( aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup6 (Acc e) = + ( aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup7 (Acc e) = + ( aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup8 (Acc e) = + ( aprj7 e + , aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup9 (Acc e) = + ( aprj8 e + , aprj7 e + , aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup10 (Acc e) = + ( aprj9 e + , aprj8 e + , aprj7 e + , aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup11 (Acc e) = + ( aprj10 e + , aprj9 e + , aprj8 e + , aprj7 e + , aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup12 (Acc e) = + ( aprj11 e + , aprj10 e + , aprj9 e + , aprj8 e + , aprj7 e + , aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup13 (Acc e) = + ( aprj12 e + , aprj11 e + , aprj10 e + , aprj9 e + , aprj8 e + , aprj7 e + , aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup14 (Acc e) = + ( aprj13 e + , aprj12 e + , aprj11 e + , aprj10 e + , aprj9 e + , aprj8 e + , aprj7 e + , aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup15 (Acc e) = + ( aprj14 e + , aprj13 e + , aprj12 e + , aprj11 e + , aprj10 e + , aprj9 e + , aprj8 e + , aprj7 e + , aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 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 ) +unatup16 (Acc e) = + ( aprj15 e + , aprj14 e + , aprj13 e + , aprj12 e + , aprj11 e + , aprj10 e + , aprj9 e + , aprj8 e + , aprj7 e + , aprj6 e + , aprj5 e + , aprj4 e + , aprj3 e + , aprj2 e + , aprj1 e + , aprj0 e ) -- Smart constructors for stencils @@ -1170,7 +1174,7 @@ unatup16 e = -- | Boundary condition specification for stencil operations -- -newtype Boundary t = Boundary (PreBoundary Acc Exp t) +newtype Boundary t = Boundary (PreBoundary SmartAcc Exp t) data PreBoundary acc exp t where Clamp :: PreBoundary acc exp t @@ -1358,105 +1362,178 @@ 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 +aprjTail :: (Typeable a, Typeable t) => SmartAcc (t, a) -> SmartAcc t +aprjTail = SmartAcc . Aprj PairIdxLeft + +aprj0 :: ( Arrays a, Typeable t) + => SmartAcc (t, ArrRepr a) -> Acc a +aprj0 = Acc . SmartAcc . Aprj PairIdxRight + +aprj1 :: ( Arrays a, Typeable t, Typeable s0) + => SmartAcc ((t, ArrRepr a), s0) -> Acc a +aprj1 = aprj0 . aprjTail + +aprj2 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1) + => SmartAcc (((t, ArrRepr a), s1), s0) -> Acc a +aprj2 = aprj1 . aprjTail + +aprj3 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2) + => SmartAcc ((((t, ArrRepr a), s2), s1), s0) -> Acc a +aprj3 = aprj2 . aprjTail + +aprj4 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3) + => SmartAcc (((((t, ArrRepr a), s3), s2), s1), s0) -> Acc a +aprj4 = aprj3 . aprjTail + +aprj5 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4) + => SmartAcc ((((((t, ArrRepr a), s4), s3), s2), s1), s0) -> Acc a +aprj5 = aprj4 . aprjTail + +aprj6 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5) + => SmartAcc (((((((t, ArrRepr a), s5), s4), s3), s2), s1), s0) -> Acc a +aprj6 = aprj5 . aprjTail + +aprj7 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6) + => SmartAcc ((((((((t, ArrRepr a), s6), s5), s4), s3), s2), s1), s0) -> Acc a +aprj7 = aprj6 . aprjTail + +aprj8 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7) + => SmartAcc (((((((((t, ArrRepr a), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a +aprj8 = aprj7 . aprjTail + +aprj9 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 + , Typeable s8) + => SmartAcc ((((((((((t, ArrRepr a), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a +aprj9 = aprj8 . aprjTail + +aprj10 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 + , Typeable s8, Typeable s9) + => SmartAcc (((((((((((t, ArrRepr a), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a +aprj10 = aprj9 . aprjTail + +aprj11 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 + , Typeable s8, Typeable s9, Typeable s10) + => SmartAcc ((((((((((((t, ArrRepr a), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a +aprj11 = aprj10 . aprjTail + +aprj12 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 + , Typeable s8, Typeable s9, Typeable s10, Typeable s11) + => SmartAcc (((((((((((((t, ArrRepr a), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a +aprj12 = aprj11 . aprjTail + +aprj13 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 + , Typeable s8, Typeable s9, Typeable s10, Typeable s11, Typeable s12) + => SmartAcc ((((((((((((((t, ArrRepr a), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a +aprj13 = aprj12 . aprjTail + +aprj14 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 + , Typeable s8, Typeable s9, Typeable s10, Typeable s11, Typeable s12, Typeable s13) + => SmartAcc (((((((((((((((t, ArrRepr a), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a +aprj14 = aprj13 . aprjTail + +aprj15 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 + , Typeable s8, Typeable s9, Typeable s10, Typeable s11, Typeable s12, Typeable s13, Typeable s14) + => SmartAcc ((((((((((((((((t, ArrRepr a), s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a +aprj15 = aprj14 . aprjTail {-- -- 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) +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) +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) + = 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 @@ -2235,17 +2312,52 @@ 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) +unAcc :: Arrays a => Acc a -> SmartAcc (ArrRepr a) +unAcc (Acc a) = a + +unAccFunction :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> SmartAcc (ArrRepr a) -> SmartAcc (ArrRepr b) +unAccFunction f = unAcc . f . Acc + +class ApplyAcc a where + type FromApplyAcc a + + applyAcc :: FromApplyAcc a -> a + +instance ApplyAcc (SmartAcc a) where + type FromApplyAcc (SmartAcc a) = PreSmartAcc SmartAcc Exp a + + applyAcc = SmartAcc + +instance (Arrays a, ApplyAcc t) => ApplyAcc (Acc a -> t) where + type FromApplyAcc (Acc a -> t) = SmartAcc (ArrRepr a) -> FromApplyAcc t + + applyAcc f a = applyAcc $ f (unAcc a) + +instance ApplyAcc t => ApplyAcc (Exp a -> t) where + type FromApplyAcc (Exp a -> t) = Exp a -> FromApplyAcc t + + applyAcc f a = applyAcc $ f a + +instance ApplyAcc t => ApplyAcc ((Exp a -> b) -> t) where + type FromApplyAcc ((Exp a -> b) -> t) = (Exp a -> b) -> FromApplyAcc t + + applyAcc f a = applyAcc $ f a + +instance (Arrays a, Arrays b, ApplyAcc t) => ApplyAcc ((Acc a -> Acc b) -> t) where + type FromApplyAcc ((Acc a -> Acc b) -> t) = (SmartAcc (ArrRepr a) -> SmartAcc (ArrRepr b)) -> FromApplyAcc t + applyAcc f a = applyAcc $ f (unAccFunction a) -- Debugging -- --------- -showPreAccOp :: forall acc exp arrs. PreAcc acc exp arrs -> String +showPreAccOp :: forall acc exp arrs. PreSmartAcc 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 Apair{} = "Apair" +showPreAccOp Anil{} = "Anil" showPreAccOp Aprj{} = "Aprj" showPreAccOp Unit{} = "Unit" showPreAccOp Generate{} = "Generate" From 9e35c3a8d0ff39fc3d881876f52432bd5d1af4f5 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 6 Nov 2019 14:55:22 +0100 Subject: [PATCH 099/316] Use new AST format --- src/Data/Array/Accelerate/Analysis/Hash.hs | 44 +- src/Data/Array/Accelerate/Analysis/Match.hs | 109 +++-- src/Data/Array/Accelerate/Analysis/Shape.hs | 82 +--- src/Data/Array/Accelerate/Analysis/Type.hs | 118 +---- src/Data/Array/Accelerate/Interpreter.hs | 51 +-- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 110 +++-- src/Data/Array/Accelerate/Pretty/Print.hs | 45 +- src/Data/Array/Accelerate/Trafo.hs | 14 +- src/Data/Array/Accelerate/Trafo/Base.hs | 119 ++++- src/Data/Array/Accelerate/Trafo/Fusion.hs | 390 ++++++++-------- src/Data/Array/Accelerate/Trafo/Sharing.hs | 427 ++++++++++-------- src/Data/Array/Accelerate/Trafo/Shrink.hs | 68 +-- .../Array/Accelerate/Trafo/Substitution.hs | 159 ++++--- 13 files changed, 876 insertions(+), 860 deletions(-) diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 40a941926..3428f8f62 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -140,8 +140,8 @@ encodePreOpenAcc -> Builder encodePreOpenAcc options encodeAcc pacc = let - travA :: forall aenv' a. Arrays a => acc aenv' a -> Builder - travA a = encodeArraysType (arrays @a) <> encodeAcc options a + travA :: forall aenv' a. acc aenv' a -> Builder + travA = encodeAcc options travAF :: PreOpenAfun acc aenv' f -> Builder travAF = encodePreOpenAfun options encodeAcc @@ -155,21 +155,18 @@ encodePreOpenAcc options encodeAcc pacc = travB :: PreBoundary acc aenv' (Array sh e) -> Builder travB = encodePreBoundary options encodeAcc - nacl :: Arrays arrs => Builder - nacl = encodeArraysType (arrays @arrs) - deep :: Builder -> Builder deep x | perfect options = x | otherwise = mempty in case pacc of - Alet bnd body -> intHost $(hashQ "Alet") <> travA bnd <> travA body - Avar v -> intHost $(hashQ "Avar") <> nacl <> deep (encodeIdx v) - Atuple t -> intHost $(hashQ "Atuple") <> nacl <> encodeAtuple options encodeAcc t - Aprj ix a -> intHost $(hashQ "Aprj") <> nacl <> encodeTupleIdx ix <> travA a - Apply f a -> intHost $(hashQ "Apply") <> nacl <> travAF f <> travA a - Aforeign _ f a -> intHost $(hashQ "Aforeign") <> nacl <> travAF f <> travA a - Use a -> intHost $(hashQ "Use") <> deep (encodeArrays (arrays @arrs) a) + Alet lhs bnd body -> intHost $(hashQ "Alet") <> encodeLeftHandSide lhs <> travA bnd <> travA body + Avar (ArrayVar v) -> intHost $(hashQ "Avar") <> deep (encodeIdx v) + Apair a1 a2 -> intHost $(hashQ "Apair") <> travA a1 <> travA a2 + Anil -> intHost $(hashQ "Anil") + Apply f a -> intHost $(hashQ "Apply") <> travAF f <> travA a + Aforeign _ f a -> intHost $(hashQ "Aforeign") <> travAF f <> travA a + Use repr a -> intHost $(hashQ "Use") <> deep (encodeArrays repr a) Awhile p f a -> intHost $(hashQ "Awhile") <> travAF f <> travAF p <> travA a Unit e -> intHost $(hashQ "Unit") <> travE e Generate e f -> intHost $(hashQ "Generate") <> deep (travE e) <> travF f @@ -260,9 +257,13 @@ encodeArraysType ArraysRarray = intHost $(hashQ "ArraysRarray") <> encode encodeArrayType :: forall array sh e. (array ~ Array sh e, Shape sh, Elt e) => Builder encodeArrayType = encodeTupleType (eltType @sh) <> encodeTupleType (eltType @e) -encodeAtuple :: HashOptions -> EncodeAcc acc -> Atuple (acc aenv) a -> Builder -encodeAtuple _ _ NilAtup = intHost $(hashQ "NilAtup") -encodeAtuple o travA (SnocAtup t a) = intHost $(hashQ "SnocAtup") <> encodeAtuple o travA t <> travA o a +encodeLeftHandSide :: forall a env env'. LeftHandSide a env env' -> Builder +encodeLeftHandSide (LeftHandSideWildcard r) = intHost $(hashQ "LeftHandSideWildcard") <> encodeArraysType r +encodeLeftHandSide (LeftHandSidePair r1 r2) = intHost $(hashQ "LeftHandSidePair") <> encodeLeftHandSide r1 <> encodeLeftHandSide r2 +encodeLeftHandSide LeftHandSideArray = intHost $(hashQ "LeftHandSideArray") <> encodeArrayType @a + where + encodeArrayType :: forall array sh e. (array ~ Array sh e, Shape sh, Elt e) => Builder + encodeArrayType = encodeTupleType (eltType @sh) <> encodeTupleType (eltType @e) encodePreOpenAfun :: forall acc aenv f. @@ -272,15 +273,14 @@ encodePreOpenAfun -> Builder encodePreOpenAfun options travA afun = let - travB :: forall aenv' a. Arrays a => acc aenv' a -> Builder - travB b = encodeArraysType (arrays @a) <> travA options b - - travL :: forall aenv' a b. Arrays a => PreOpenAfun acc (aenv',a) b -> Builder - travL l = encodeArraysType (arrays @a) <> encodePreOpenAfun options travA l + travL :: forall aenv1 aenv2 a b. LeftHandSide a aenv1 aenv2 -> PreOpenAfun acc aenv2 b -> Builder + travL lhs l = encodeArraysType repr <> encodePreOpenAfun options travA l + where + repr = lhsToArraysR lhs in case afun of - Abody b -> intHost $(hashQ "Abody") <> travB b - Alam l -> intHost $(hashQ "Alam") <> travL l + Abody b -> intHost $(hashQ "Abody") <> travA options b + Alam lhs l -> intHost $(hashQ "Alam") <> travL lhs l encodePreBoundary diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index ab60f9a23..5f0621f9f 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -29,8 +29,9 @@ module Data.Array.Accelerate.Analysis.Match ( matchPrimFun, matchPrimFun', -- auxiliary - matchIdx, matchTupleType, matchShapeType, + matchIdx, matchArrayVar, matchArrayVars, matchTupleType, matchShapeType, matchIntegralType, matchFloatingType, matchNumType, matchScalarType, + matchLeftHandSide, matchLeftHandSide', ) where @@ -76,21 +77,21 @@ matchPreOpenAcc matchAcc encodeAcc = match 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 + match (Alet lhs1 x1 a1) (Alet lhs2 x2 a2) + | Just Refl <- matchLeftHandSide lhs1 lhs2 + , Just Refl <- matchAcc x1 x2 , Just Refl <- matchAcc a1 a2 = Just Refl - match (Avar v1) (Avar v2) + match (Avar (ArrayVar v1)) (Avar (ArrayVar v2)) = matchIdx v1 v2 - match (Atuple t1) (Atuple t2) - | Just Refl <- matchAtuple matchAcc t1 t2 - = gcast Refl -- surface/representation type + match (Apair a1 a2) (Apair b1 b2) + | Just Refl <- matchAcc a1 b1 + , Just Refl <- matchAcc a2 b2 + = Just Refl - match (Aprj ix1 t1) (Aprj ix2 t2) - | Just Refl <- matchAcc t1 t2 - , Just Refl <- matchTupleIdx ix1 ix2 + match Anil Anil = Just Refl match (Apply f1 a1) (Apply f2 a2) @@ -118,9 +119,9 @@ matchPreOpenAcc matchAcc encodeAcc = match , Just Refl <- matchPreOpenAfun matchAcc f1 f2 = Just Refl - match (Use a1) (Use a2) - | Just Refl <- matchArrays (arrays @s) (arrays @t) a1 a2 - = gcast Refl + match (Use repr1 a1) (Use repr2 a2) + | Just Refl <- matchArrays repr1 repr2 a1 a2 + = Just Refl match (Unit e1) (Unit e2) | Just Refl <- matchExp e1 e2 @@ -255,23 +256,6 @@ matchPreOpenAcc matchAcc encodeAcc = match 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 -- {-# INLINEABLE matchPreOpenAfun #-} @@ -280,18 +264,39 @@ matchPreOpenAfun -> PreOpenAfun acc aenv s -> PreOpenAfun acc aenv t -> Maybe (s :~: t) -matchPreOpenAfun m (Alam s) (Alam t) - | Just Refl <- matchEnvTop s t +matchPreOpenAfun m (Alam lhs1 s) (Alam lhs2 t) + | Just Refl <- matchLeftHandSide lhs1 lhs2 , 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 +matchPreOpenAfun _ _ _ = Nothing + +matchLeftHandSide :: forall aenv aenv1 aenv2 arr1 arr2. LeftHandSide arr1 aenv aenv1 -> LeftHandSide arr2 aenv aenv2 -> Maybe (LeftHandSide arr1 aenv aenv1 :~: LeftHandSide arr2 aenv aenv2) +matchLeftHandSide (LeftHandSideWildcard repr1) (LeftHandSideWildcard repr2) + | Just Refl <- matchArraysR repr1 repr2 + = Just Refl +matchLeftHandSide LeftHandSideArray LeftHandSideArray + | Just Refl <- gcast @arr1 @arr2 Refl + = Just Refl +matchLeftHandSide (LeftHandSidePair a1 a2) (LeftHandSidePair b1 b2) + | Just Refl <- matchLeftHandSide a1 b1 + , Just Refl <- matchLeftHandSide a2 b2 + = Just Refl +matchLeftHandSide _ _ = Nothing +matchLeftHandSide' :: forall aenv aenv1 aenv2 arr1 arr2. LeftHandSide arr1 aenv1 aenv -> LeftHandSide arr2 aenv2 aenv -> Maybe (LeftHandSide arr1 aenv1 aenv :~: LeftHandSide arr2 aenv2 aenv) +matchLeftHandSide' (LeftHandSideWildcard repr1) (LeftHandSideWildcard repr2) + | Just Refl <- matchArraysR repr1 repr2 + = Just Refl +matchLeftHandSide' LeftHandSideArray LeftHandSideArray + | Just Refl <- gcast @arr1 @arr2 Refl + = Just Refl +matchLeftHandSide' (LeftHandSidePair a1 a2) (LeftHandSidePair b1 b2) + | Just Refl <- matchLeftHandSide' a2 b2 + , Just Refl <- matchLeftHandSide' a1 b1 + = Just Refl +matchLeftHandSide' _ _ = Nothing -- Match stencil boundaries -- @@ -415,6 +420,22 @@ matchArrays ArraysRarray ArraysRarray (Array _ ad1) (Array _ ad2) matchArrays _ _ _ _ = Nothing +matchArraysR :: ArraysR s -> ArraysR t -> Maybe (s :~: t) +matchArraysR ArraysRunit ArraysRunit + = Just Refl + +matchArraysR (ArraysRpair a1 b1) (ArraysRpair a2 b2) + | Just Refl <- matchArraysR a1 a2 + , Just Refl <- matchArraysR b1 b2 + = Just Refl + +matchArraysR ArraysRarray ArraysRarray + = gcast Refl + +matchArraysR _ _ + = Nothing + + -- Compute the congruence of two scalar expressions. Two nodes are congruent if -- either: @@ -628,6 +649,20 @@ matchIdx ZeroIdx ZeroIdx = Just Refl matchIdx (SuccIdx u) (SuccIdx v) = matchIdx u v matchIdx _ _ = Nothing +{-# INLINEABLE matchArrayVar #-} +matchArrayVar :: ArrayVar env s -> ArrayVar env t -> Maybe (s :~: t) +matchArrayVar (ArrayVar v1) (ArrayVar v2) = matchIdx v1 v2 + +{-# INLINEABLE matchArrayVars #-} +matchArrayVars :: ArrayVars env s -> ArrayVars env t -> Maybe (s :~: t) +matchArrayVars ArrayVarsNil ArrayVarsNil = Just Refl +matchArrayVars (ArrayVarsArray v1) (ArrayVarsArray v2) + | Just Refl <- matchArrayVar v1 v2 = Just Refl +matchArrayVars (ArrayVarsPair v w) (ArrayVarsPair x y) + | Just Refl <- matchArrayVars v x + , Just Refl <- matchArrayVars w y = Just Refl +matchArrayVars _ _ = Nothing + -- Tuple projection indices. Given the same tuple expression structure (tup), -- check that the indices project identical elements. diff --git a/src/Data/Array/Accelerate/Analysis/Shape.hs b/src/Data/Array/Accelerate/Analysis/Shape.hs index 141d34cee..14f7c549d 100644 --- a/src/Data/Array/Accelerate/Analysis/Shape.hs +++ b/src/Data/Array/Accelerate/Analysis/Shape.hs @@ -17,94 +17,20 @@ module Data.Array.Accelerate.Analysis.Shape ( -- * query AST dimensionality - AccDim, accDim, delayedDim, preAccDim, + accDim, 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 @(Array sh e) of - ArraysRarray -> rank @sh -#if __GLASGOW_HASKELL__ < 800 - _ -> error "halt, fiend!" -#endif - - Apply{} -> case arrays @(Array sh e) of - ArraysRarray -> rank @sh -#if __GLASGOW_HASKELL__ < 800 - _ -> error "umm, hello" -#endif - - Aforeign{} -> case arrays @(Array sh e) of - ArraysRarray -> rank @sh -#if __GLASGOW_HASKELL__ < 800 - _ -> error "I don't even like snails!" -#endif - - Atuple{} -> case arrays @(Array sh e) of - ArraysRarray -> rank @sh -#if __GLASGOW_HASKELL__ < 800 - _ -> error "can we keep him?" -#endif - - Aprj{} -> case arrays @(Array sh e) of - ArraysRarray -> rank @sh -#if __GLASGOW_HASKELL__ < 800 - _ -> error "inconceivable!" -#endif - - Use{} -> case arrays @(Array sh e) of - ArraysRarray -> rank @sh -#if __GLASGOW_HASKELL__ < 800 - _ -> error "ppbbbbbt~" -#endif - - Acond _ acc _ -> k acc - Awhile _ _ acc -> k acc - Unit _ -> 0 - Generate _ _ -> rank @sh - Transform _ _ _ _ -> rank @sh - Reshape _ _ -> rank @sh - Replicate _ _ _ -> rank @sh - Slice _ _ _ -> rank @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 _ _ _ -> rank @sh - Stencil _ _ acc -> k acc - Stencil2 _ _ acc _ _ -> k acc - +accDim :: forall acc aenv sh e. HasArraysRepr acc => acc aenv (Array sh e) -> Int +accDim acc = case arraysRepr acc of + ArraysRarray -> rank @sh -- |Reify dimensionality of a scalar expression yielding a shape -- diff --git a/src/Data/Array/Accelerate/Analysis/Type.hs b/src/Data/Array/Accelerate/Analysis/Type.hs index bbacc2674..4fb6cd509 100644 --- a/src/Data/Array/Accelerate/Analysis/Type.hs +++ b/src/Data/Array/Accelerate/Analysis/Type.hs @@ -24,9 +24,8 @@ module Data.Array.Accelerate.Analysis.Type ( - AccType, arrayType, - accType, expType, delayedAccType, delayedExpType, - preAccType, preExpType, + arrayType, + accType, expType, sizeOf, sizeOfScalarType, @@ -40,7 +39,6 @@ module Data.Array.Accelerate.Analysis.Type ( -- 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 @@ -59,110 +57,18 @@ arrayType _ = eltType @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 @(Array sh e) of - ArraysRarray -> eltType @e -#if __GLASGOW_HASKELL__ < 800 - _ -> error "When I get sad, I stop being sad and be AWESOME instead." -#endif - - Apply{} -> case arrays @(Array sh e) of - ArraysRarray -> eltType @e -#if __GLASGOW_HASKELL__ < 800 - _ -> error "TRUE STORY." -#endif - - Atuple{} -> case arrays @(Array sh e) of - ArraysRarray -> eltType @e -#if __GLASGOW_HASKELL__ < 800 - _ -> error "I made you a cookie, but I eated it." -#endif - - Aprj{} -> case arrays @(Array sh e) of - ArraysRarray -> eltType @e -#if __GLASGOW_HASKELL__ < 800 - _ -> error "Hey look! even the leaves are falling for you." -#endif - - Aforeign{} -> case arrays @(Array sh e) of - ArraysRarray -> eltType @e -#if __GLASGOW_HASKELL__ < 800 - _ -> error "Who on earth wrote all these weird error messages?" -#endif - - Use{} -> case arrays @(Array sh e) of - ArraysRarray -> eltType @e -#if __GLASGOW_HASKELL__ < 800 - _ -> error "rob you are terrible at this game" -#endif - - Acond _ acc _ -> k acc - Awhile _ _ acc -> k acc - Unit _ -> eltType @e - Generate _ _ -> eltType @e - Transform _ _ _ _ -> eltType @e - Reshape _ acc -> k acc - Replicate _ _ acc -> k acc - Slice _ acc _ -> k acc - Map _ _ -> eltType @e - ZipWith _ _ _ -> eltType @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 @e - Stencil2 _ _ _ _ _ -> eltType @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 +accType :: forall acc aenv sh e. HasArraysRepr acc => acc aenv (Array sh e) -> TupleType (EltRepr e) +accType acc = case arraysRepr acc of + ArraysRarray -> eltType @e -- |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 +expType :: forall acc aenv env t. + HasArraysRepr acc + => PreOpenExp acc aenv env t -> TupleType (EltRepr t) -preExpType k e = +expType e = case e of Let _ _ -> eltType @t Var _ -> eltType @t @@ -179,12 +85,12 @@ preExpType k e = IndexFull _ _ _ -> eltType @t ToIndex _ _ -> eltType @t FromIndex _ _ -> eltType @t - Cond _ t _ -> preExpType k t + Cond _ t _ -> expType t While _ _ _ -> eltType @t PrimConst _ -> eltType @t PrimApp _ _ -> eltType @t - Index acc _ -> k acc - LinearIndex acc _ -> k acc + Index acc _ -> accType acc + LinearIndex acc _ -> accType acc Shape _ -> eltType @t ShapeSize _ -> eltType @t Intersect _ _ -> eltType @t diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index ba0cac4ca..55f253201 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -100,7 +100,8 @@ run a = unsafePerformIO execute execute = do D.dumpGraph $!! acc D.dumpSimplStats - phase "execute" D.elapsed (evaluate (evalOpenAcc acc Empty)) + res <- phase "execute" D.elapsed $ evaluate $ evalOpenAcc acc Empty + return $ toArr res -- | This is 'runN' specialised to an array program of one argument. -- @@ -109,7 +110,7 @@ run1 = runN -- | Prepare and execute an embedded array program. -- -runN :: Afunction f => f -> AfunctionR f +runN :: forall f. Afunction f => f -> AfunctionR f runN f = go where !acc = convertAfun f @@ -117,12 +118,12 @@ runN f = go D.dumpGraph $!! acc D.dumpSimplStats return acc - !go = eval afun Empty + !go = eval (afunctionRepr @f) 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)) - + eval :: AfunctionRepr g (AfunctionR g) (AreprFunctionR g) -> DelayedOpenAfun aenv (AreprFunctionR g) -> Val aenv -> AfunctionR g + eval (AfunctionReprLam reprF) (Alam lhs f) aenv = \a -> eval reprF f $ aenv `push` (lhs, fromArr a) + eval AfunctionReprBody (Abody b) aenv = unsafePerformIO $ phase "execute" D.elapsed (toArr <$> evaluate (evalOpenAcc b aenv)) + eval _ _aenv _ = error "Two men say they're Jesus; one of them must be wrong" -- -- | Stream a lazily read list of input arrays through the given program, -- -- collecting results as we go @@ -161,8 +162,8 @@ 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 +evalOpenAfun (Alam lhs f) aenv = \a -> evalOpenAfun f $ aenv `push` (lhs, a) +evalOpenAfun (Abody b) aenv = evalOpenAcc b aenv -- The core interpreter for optimised array programs @@ -175,10 +176,11 @@ evalOpenAcc evalOpenAcc AST.Delayed{} _ = $internalError "evalOpenAcc" "expected manifest array" evalOpenAcc (AST.Manifest pacc) aenv = let - manifest :: forall a'. Arrays a' => DelayedOpenAcc aenv a' -> a' + manifest :: forall a'. DelayedOpenAcc aenv a' -> a' manifest acc = - let a' = evalOpenAcc acc aenv - in rnfArrays (arrays @a') (fromArr a') `seq` a' + let a' = evalOpenAcc acc aenv + repr = arraysRepr acc + in rnfArrays repr a' `seq` a' delayed :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e) -> Delayed (Array sh e) delayed AST.Delayed{..} = Delayed (evalE extentD) (evalF indexD) (evalF linearIndexD) @@ -194,10 +196,10 @@ evalOpenAcc (AST.Manifest pacc) aenv = 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 + Avar (ArrayVar ix) -> prj ix aenv + Alet lhs acc1 acc2 -> evalOpenAcc acc2 $ aenv `push` (lhs, manifest acc1) + Apair acc1 acc2 -> (manifest acc1, manifest acc2) + Anil -> () Apply afun acc -> evalOpenAfun afun aenv $ manifest acc Aforeign _ afun acc -> evalOpenAfun afun Empty $ manifest acc Acond p acc1 acc2 @@ -212,7 +214,7 @@ evalOpenAcc (AST.Manifest pacc) aenv = | p x ! Z = go (f x) | otherwise = x - Use arr -> toArr arr + Use _ arr -> arr Unit e -> unitOp (evalE e) -- Collect s -> evalSeq defaultSeqConfig s aenv @@ -244,13 +246,6 @@ evalOpenAcc (AST.Manifest pacc) aenv = 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 -- ---------------- @@ -479,9 +474,9 @@ scanl'Op => (e -> e -> e) -> e -> Delayed (Array (sh:.Int) e) - -> (Array (sh:.Int) e, Array sh e) + -> ArrRepr (Array (sh:.Int) e, Array sh e) scanl'Op f z (Delayed (sh :. n) ain _) - = aout `seq` asum `seq` ( Array (fromElt (sh:.n)) aout + = aout `seq` asum `seq` ( ( (), Array (fromElt (sh:.n)) aout ) , Array (fromElt sh) asum ) where f' = sinkFromElt2 f @@ -558,9 +553,9 @@ scanr'Op => (e -> e -> e) -> e -> Delayed (Array (sh:.Int) e) - -> (Array (sh:.Int) e, Array sh e) + -> ArrRepr (Array (sh:.Int) e, Array sh e) scanr'Op f z (Delayed (sh :. n) ain _) - = aout `seq` asum `seq` ( Array (fromElt (sh:.n)) aout + = aout `seq` asum `seq` ( ((), Array (fromElt (sh:.n)) aout ) , Array (fromElt sh) asum ) where f' = sinkFromElt2 f diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index ba50486c3..a0420bfb6 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -44,8 +44,8 @@ import qualified Data.HashSet as Set import qualified Data.Sequence as Seq -- friends -import Data.Array.Accelerate.AST ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), PreBoundary(..), Idx(..), tupleIdxToInt ) -import Data.Array.Accelerate.Array.Sugar ( Array, Elt, Tuple(..), Atuple(..), arrays, toElt, strForeign ) +import Data.Array.Accelerate.AST ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), PreBoundary(..), LeftHandSide(..), ArrayVar(..), Idx(..) ) +import Data.Array.Accelerate.Array.Sugar ( Array, Elt, Tuple(..), ArraysR(..), toElt, strForeign ) import Data.Array.Accelerate.Error import Data.Array.Accelerate.Pretty.Graphviz.Monad import Data.Array.Accelerate.Pretty.Graphviz.Type @@ -193,11 +193,11 @@ prettyDelayedOpenAcc _ _ _ Delayed{} = $internalError "pret prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = case pacc of Avar ix -> pnode (avar ix) - Alet bnd body -> do - bnd' <- prettyDelayedOpenAcc detail context0 aenv bnd - a <- mkLabel - ident <- mkNode bnd' (Just a) - body' <- prettyDelayedOpenAcc detail context0 (Apush aenv ident a) body + Alet lhs bnd body -> do + bnd'@(PNode ident _ _) <- prettyDelayedOpenAcc detail context0 aenv bnd + (aenv1, a) <- prettyLetLeftHandSide ident aenv lhs + _ <- mkNode bnd' (Just a) + body' <- prettyDelayedOpenAcc detail context0 aenv1 body return body' Acond p t e -> do @@ -223,14 +223,11 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = loop = nest 2 (sep ["awhile", pretty p', pretty f', xb ]) return $ PNode ident (Leaf (Nothing,loop)) fvs - Atuple atup -> prettyDelayedAtuple detail aenv atup + a@(Apair a1 a2) -> mkNodeId a >>= prettyDelayedApair detail aenv a1 a2 - Aprj ix atup -> do - ident <- mkNodeId atop - PNode _ (Leaf (p,d)) deps <- replant =<< prettyDelayedOpenAcc detail context0 aenv atup - return $ PNode ident (Leaf (p, d <+> pretty '#' <+> pretty (tupleIdxToInt ix))) deps + Anil -> "()" .$ [] - Use arrs -> "use" .$ [ return $ PDoc (prettyArrays (arrays @arrs) arrs) [] ] + Use repr arrs -> "use" .$ [ return $ PDoc (prettyArrays repr arrs) [] ] Unit e -> "unit" .$ [ ppE e ] Generate sh f -> "generate" .$ [ ppE sh, ppF f ] Transform sh ix f xs -> "transform" .$ [ ppE sh, ppF ix, ppF f, ppA xs ] @@ -282,8 +279,8 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = -- Free variables -- fvA :: FVAcc DelayedOpenAcc - fvA env (Manifest (Avar ix)) = [ Vertex (fst $ aprj ix env) Nothing ] - fvA _ _ = $internalError "graphviz" "expected array variable" + fvA env (Manifest (Avar (ArrayVar ix))) = [ Vertex (fst $ aprj ix env) Nothing ] + fvA _ _ = $internalError "graphviz" "expected array variable" fvF :: DelayedFun aenv t -> [Vertex] fvF = fvPreOpenFun fvA Empty aenv @@ -293,9 +290,9 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = -- Pretty-printing -- - avar :: Idx aenv t -> PDoc - avar ix = let (ident, v) = aprj ix aenv - in PDoc (pretty v) [Vertex ident Nothing] + avar :: ArrayVar aenv t -> PDoc + avar (ArrayVar ix) = let (ident, v) = aprj ix aenv + in PDoc (pretty v) [Vertex ident Nothing] aenv' :: Val aenv aenv' = avalToVal aenv @@ -333,9 +330,9 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = ppE = return . uncurry PDoc . (prettyDelayedExp 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 + lift Delayed{} = $internalError "prettyDelayedOpenAcc" "expected manifest array" + lift (Manifest (Avar (ArrayVar ix))) = return $ Vertex (fst (aprj ix aenv)) Nothing + lift acc = do acc' <- prettyDelayedOpenAcc detail context0 aenv acc ident <- mkNode acc' Nothing return $ Vertex ident Nothing @@ -383,37 +380,66 @@ prettyDelayedAfun detail aenv afun = do 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, pretty a)) []) Nothing - go (Apush aenv' ident a) f + go aenv' (Alam lhs f) = do + aenv'' <- prettyLambdaLeftHandSide aenv' lhs + go aenv'' f collect :: Aval aenv' -> HashSet NodeId collect Aempty = Set.empty collect (Apush a i _) = Set.insert i (collect a) +prettyLetLeftHandSide + :: forall repr aenv aenv'. + NodeId + -> Aval aenv + -> LeftHandSide repr aenv aenv' + -> Dot (Aval aenv', Label) +prettyLetLeftHandSide _ aenv (LeftHandSideWildcard repr) = return (aenv, doc) + where + doc = case repr of + ArraysRunit -> "()" + _ -> "_" +prettyLetLeftHandSide ident aenv LeftHandSideArray = do + a <- mkLabel + return (Apush aenv ident a, a) +prettyLetLeftHandSide ident aenv (LeftHandSidePair lhs1 lhs2) = do + (aenv1, d1) <- prettyLetLeftHandSide ident aenv lhs1 + (aenv2, d2) <- prettyLetLeftHandSide ident aenv1 lhs2 + return (aenv2, "(" <> d1 <> ", " <> d2 <> ")") + +prettyLambdaLeftHandSide + :: forall repr aenv aenv'. + Aval aenv + -> LeftHandSide repr aenv aenv' + -> Dot (Aval aenv') +prettyLambdaLeftHandSide aenv (LeftHandSideWildcard _) = return aenv +prettyLambdaLeftHandSide aenv lhs@LeftHandSideArray = do + a <- mkLabel + ident <- mkNodeId lhs + _ <- mkNode (PNode ident (Leaf (Nothing, pretty a)) []) Nothing + return $ Apush aenv ident a +prettyLambdaLeftHandSide aenv (LeftHandSidePair lhs1 lhs2) = do + aenv1 <- prettyLambdaLeftHandSide aenv lhs1 + prettyLambdaLeftHandSide aenv1 lhs2 -- Display array tuples. This is a little tricky... -- -prettyDelayedAtuple - :: forall aenv atup. +prettyDelayedApair + :: forall aenv a1 a2. Detail -> Aval aenv - -> Atuple (DelayedOpenAcc aenv) atup + -> DelayedOpenAcc aenv a1 + -> DelayedOpenAcc aenv a2 + -> NodeId -> Dot PNode -prettyDelayedAtuple detail 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) +prettyDelayedApair detail aenv a1 a2 ident = do + PNode id1 t1 v1 <- prettyElem a1 + PNode id2 t2 v2 <- prettyElem a2 + modify $ \s -> s { dotEdges = fmap (redirect ident [id1, id2]) (dotEdges s) } + return $ PNode ident (forest [t1, t2]) (v1 ++ v2) where - collect :: [PNode] -> Atuple (DelayedOpenAcc aenv) t -> Dot [PNode] - collect acc NilAtup = return acc - collect acc (SnocAtup tup a) = do - a' <- replant =<< prettyDelayedOpenAcc detail context0 aenv a - tup' <- collect (a':acc) tup - return tup' + prettyElem :: DelayedOpenAcc aenv a -> Dot PNode + prettyElem a = replant =<< prettyDelayedOpenAcc detail context0 aenv a -- Redirect any edges that pointed into one of the nodes now part of this -- tuple, to instead point to the container node. @@ -488,8 +514,8 @@ prettyDelayedOpenExp prettyDelayedOpenExp context = prettyPreOpenExp context pp ex where pp :: PrettyAcc DelayedOpenAcc - pp _ aenv (Manifest (Avar ix)) = prj ix aenv - pp _ _ _ = $internalError "prettyDelayedOpenExp" "expected array variable" + pp _ aenv (Manifest (Avar (ArrayVar ix))) = prj ix aenv + pp _ _ _ = $internalError "prettyDelayedOpenExp" "expected array variable" ex :: ExtractAcc DelayedOpenAcc ex (Manifest pacc) = pacc diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 20334e648..a5e12e1a3 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -111,9 +111,10 @@ prettyPreOpenAfun prettyAcc aenv0 = next (pretty '\\') aenv0 where next :: Adoc -> Val aenv' -> PreOpenAfun acc aenv' f' -> Adoc next vs aenv (Abody body) = hang shiftwidth (sep [vs <> "->", prettyAcc context0 aenv body]) - next vs aenv (Alam lam) = - let a = pretty 'a' <> pretty (sizeEnv aenv) - in next (vs <> a <> space) (aenv `Push` a) lam + next vs aenv (Alam lhs lam) = + let + (aenv', lhs') = prettyLHS aenv lhs + in next (vs <> lhs' <> space) aenv' lam prettyPreOpenAcc :: forall acc aenv arrs. @@ -125,19 +126,15 @@ prettyPreOpenAcc -> Adoc prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = case pacc of - Avar idx -> prj idx aenv + Avar (ArrayVar idx) -> prj idx aenv Alet{} -> prettyAlet ctx prettyAcc extractAcc aenv pacc - Atuple tup -> prettyAtuple prettyAcc aenv tup + Apair a1 a2 -> "(" <> prettyAcc context0 aenv a1 <> ", " <> prettyAcc context0 aenv a2 <> ")" + Anil -> "()" Apply f a -> apply where op = Operator ">->" Infix L 1 apply = sep [ ppAF f, group (sep [opName op, ppA a]) ] - Aprj tix a -> parensIf (needsParens ctx op) aprj - where - op = Operator "#" Infix L 8 - aprj = sep [ prettyAcc (arg op L) aenv a, group (sep [opName op, pretty (tupleIdxToInt tix)])] - Acond p t e -> flatAlt multi single where p' = ppE p @@ -153,7 +150,7 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = Aforeign ff _f a -> "aforeign" .$ [ pretty (strForeign ff), ppA a ] Awhile p f a -> "awhile" .$ [ ppAF p, ppAF f, ppA a ] - Use arrs -> "use" .$ [ prettyArrays (arrays @arrs) arrs ] + Use repr arrs -> "use" .$ [ prettyArrays repr arrs ] Unit e -> "unit" .$ [ ppE e ] Reshape sh a -> "reshape" .$ [ ppE sh, ppA a ] Generate sh f -> "generate" .$ [ ppE sh, ppF f ] @@ -219,9 +216,8 @@ prettyAlet ctx prettyAcc extractAcc aenv0 collect :: Val aenv' -> PreOpenAcc acc aenv' a -> ([Adoc], Adoc) collect aenv = \case - Alet a1 a2 -> - let aenv' = aenv `Push` v - v = pretty 'a' <> pretty (sizeEnv aenv) + Alet lhs a1 a2 -> + let (aenv', v) = prettyLHS aenv lhs a1' = ppA aenv a1 bnd | isAlet a1 = nest shiftwidth (vsep [v <+> equals, a1']) | otherwise = v <+> align (equals <+> a1') @@ -248,19 +244,16 @@ prettyAlet ctx prettyAcc extractAcc aenv0 , body ] -prettyAtuple - :: forall acc aenv t. - PrettyAcc acc - -> Val aenv - -> Atuple (acc aenv) t - -> Adoc -prettyAtuple prettyAcc aenv = tupled . collect [] +prettyLHS :: Val aenv -> LeftHandSide arrs aenv aenv' -> (Val aenv', Adoc) +prettyLHS aenv (LeftHandSideWildcard ArraysRunit) = (aenv, "()") +prettyLHS aenv (LeftHandSideWildcard _) = (aenv, "_") +prettyLHS aenv LeftHandSideArray = (aenv `Push` v, v) where - collect :: [Adoc] -> Atuple (acc aenv) s -> [Adoc] - collect acc = - \case - NilAtup -> acc - SnocAtup atup a -> collect (prettyAcc context0 aenv a : acc) atup + v = pretty 'a' <> pretty (sizeEnv aenv) +prettyLHS aenv (LeftHandSidePair a b) = (aenv2, "(" <> doc1 <> ", " <> doc2 <> ")") + where + (aenv1, doc1) = prettyLHS aenv a + (aenv2, doc2) = prettyLHS aenv1 b prettyArrays :: ArraysR arrs -> arrs -> Adoc prettyArrays arrs = tupled . collect arrs diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index c2e9717a8..579c75fe0 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -25,7 +25,7 @@ module Data.Array.Accelerate.Trafo ( convertAcc, convertAccWith, -- ** Array functions - Afunction, AfunctionR, + Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr, convertAfun, convertAfunWith, -- ** Sequence computations @@ -57,11 +57,11 @@ import Control.DeepSeq import Data.Typeable import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Array.Sugar ( Arrays, Elt ) +import Data.Array.Accelerate.Array.Sugar ( Arrays, Elt, ArrRepr ) import Data.Array.Accelerate.Trafo.Base ( Match(..), matchDelayedOpenAcc, encodeDelayedOpenAcc ) import Data.Array.Accelerate.Trafo.Config import Data.Array.Accelerate.Trafo.Fusion ( DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun, DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun ) -import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, Afunction, AfunctionR ) +import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr ) import Data.Array.Accelerate.Trafo.Substitution import qualified Data.Array.Accelerate.AST as AST import qualified Data.Array.Accelerate.Trafo.Fusion as Fusion @@ -83,10 +83,10 @@ import Data.Array.Accelerate.Debug.Timed -- | 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 :: Arrays arrs => Acc arrs -> DelayedAcc (ArrRepr arrs) convertAcc = convertAccWith defaultOptions -convertAccWith :: Arrays arrs => Config -> Acc arrs -> DelayedAcc arrs +convertAccWith :: Arrays arrs => Config -> Acc arrs -> DelayedAcc (ArrRepr arrs) convertAccWith config acc = phase "array-fusion" (Fusion.convertAccWith config) -- phase "vectorise-sequences" Vectorise.vectoriseSeqAcc `when` vectoriseSequences @@ -97,10 +97,10 @@ convertAccWith config acc -- | Convert a unary function over array computations, incorporating sharing -- observation and array fusion -- -convertAfun :: Afunction f => f -> DelayedAfun (AfunctionR f) +convertAfun :: Afunction f => f -> DelayedAfun (AreprFunctionR f) convertAfun = convertAfunWith defaultOptions -convertAfunWith :: Afunction f => Config -> f -> DelayedAfun (AfunctionR f) +convertAfunWith :: Afunction f => Config -> f -> DelayedAfun (AreprFunctionR f) convertAfunWith config acc = phase "array-fusion" (Fusion.convertAfunWith config) -- phase "vectorise-sequences" Vectorise.vectoriseSeqAfun `when` vectoriseSequences diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index 31de0ff79..d2dd72f88 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -7,7 +7,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ <= 708 @@ -30,7 +32,7 @@ module Data.Array.Accelerate.Trafo.Base ( -- Toolkit Kit(..), Match(..), (:~:)(..), - avarIn, kmap, + avarIn, avarsIn, kmap, extractArrayVars, -- Delayed Arrays DelayedAcc, DelayedOpenAcc(..), @@ -42,10 +44,16 @@ module Data.Array.Accelerate.Trafo.Base ( -- Environments Gamma(..), incExp, prjExp, pushExp, - Extend(..), append, bind, + Extend(..), pushArrayEnv, append, bind, Sink(..), sink, sink1, Supplement(..), bindExps, + leftHandSideChangeEnv, + + -- Adding new variables to the environment + declareArrays, DeclareArrays(..), compileVars, + + aletBodyIsTrivial, ) where -- standard library @@ -62,7 +70,7 @@ import Prelude hiding ( until ) 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.Array.Sugar ( Array, Arrays, ArraysR(..), Shape, Elt ) import Data.Array.Accelerate.Error import Data.Array.Accelerate.Trafo.Substitution @@ -75,7 +83,7 @@ import Data.Array.Accelerate.Debug.Stats as Stats -- The bat utility belt of operations required to manipulate terms parameterised -- by the recursive closure. -- -class (RebuildableAcc acc, Sink acc) => Kit acc where +class (HasArraysRepr acc, RebuildableAcc acc, Sink acc) => Kit acc where inject :: PreOpenAcc acc aenv a -> acc aenv a extract :: acc aenv a -> Maybe (PreOpenAcc acc aenv a) -- @@ -96,12 +104,47 @@ encodeOpenAcc options (OpenAcc pacc) = encodePreOpenAcc options encodeAcc pacc matchOpenAcc :: MatchAcc OpenAcc matchOpenAcc (OpenAcc pacc1) (OpenAcc pacc2) = matchPreOpenAcc matchAcc encodeAcc pacc1 pacc2 -avarIn :: (Kit acc, Arrays arrs) => Idx aenv arrs -> acc aenv arrs -avarIn = inject . Avar +avarIn :: forall acc aenv a. Kit acc => ArrayVar aenv a -> acc aenv a +avarIn v@ArrayVar{} = inject $ Avar v + +avarsIn :: forall acc aenv arrs. Kit acc => ArrayVars aenv arrs -> acc aenv arrs +avarsIn ArrayVarsNil = inject Anil +avarsIn (ArrayVarsArray v) = avarIn v +avarsIn (ArrayVarsPair a b) = inject $ avarsIn a `Apair` avarsIn b kmap :: Kit acc => (PreOpenAcc acc aenv a -> PreOpenAcc acc aenv b) -> acc aenv a -> acc aenv b kmap f = inject . f . fromJust . extract +extractArrayVars :: Kit acc => acc aenv a -> Maybe (ArrayVars aenv a) +extractArrayVars (extract -> Just acc) = case acc of + Apair (extractArrayVars -> Just a) (extractArrayVars -> Just b) + -> Just $ ArrayVarsPair a b + Anil + -> Just ArrayVarsNil + Avar v + -> Just $ ArrayVarsArray v + _ -> Nothing +extractArrayVars _ = Nothing + +data DeclareArrays arrs aenv where + DeclareArrays + :: LeftHandSide arrs aenv aenv' + -> (aenv :> aenv') + -> (forall aenv''. aenv' :> aenv'' -> ArrayVars aenv'' arrs) + -> DeclareArrays arrs aenv + +declareArrays :: ArraysR arrs -> DeclareArrays arrs aenv +declareArrays ArraysRarray + = DeclareArrays LeftHandSideArray SuccIdx $ \k -> ArrayVarsArray $ ArrayVar $ k ZeroIdx +declareArrays ArraysRunit + = DeclareArrays (LeftHandSideWildcard ArraysRunit) id $ const $ ArrayVarsNil +declareArrays (ArraysRpair r1 r2) = case declareArrays r1 of + DeclareArrays lhs1 subst1 a1 -> case declareArrays r2 of + DeclareArrays lhs2 subst2 a2 -> + DeclareArrays (LeftHandSidePair lhs1 lhs2) (subst2 . subst1) $ \k -> a1 (k . subst2) `ArrayVarsPair` a2 k + + + -- fromOpenAfun :: Kit acc => OpenAfun aenv f -> PreOpenAfun acc aenv f -- fromOpenAfun (Abody a) = Abody $ fromOpenAcc a -- fromOpenAfun (Alam f) = Alam $ fromOpenAfun f @@ -116,6 +159,12 @@ instance Match (Idx env) where {-# INLINEABLE match #-} match = matchIdx +instance Match (ArrayVar env) where + {-# INLINEABLE match #-} + match (ArrayVar a) (ArrayVar b) + | Just Refl <- match a b = Just Refl + | otherwise = Nothing + instance Kit acc => Match (PreOpenExp acc env aenv) where {-# INLINEABLE match #-} match = matchPreOpenExp matchAcc encodeAcc @@ -165,6 +214,10 @@ data DelayedOpenAcc aenv a where , linearIndexD :: PreFun DelayedOpenAcc aenv (Int -> e) } -> DelayedOpenAcc aenv (Array sh e) +instance HasArraysRepr DelayedOpenAcc where + arraysRepr (Manifest a) = arraysRepr a + arraysRepr Delayed{} = ArraysRarray + instance Rebuildable DelayedOpenAcc where type AccClo DelayedOpenAcc = DelayedOpenAcc {-# INLINEABLE rebuildPartial #-} @@ -175,7 +228,7 @@ instance Rebuildable DelayedOpenAcc where <*> rebuildPartial v linearIndexD instance Sink DelayedOpenAcc where - weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) + weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) instance Kit DelayedOpenAcc where {-# INLINEABLE encodeAcc #-} @@ -336,14 +389,19 @@ sinkGamma ext (PushExp env e) = PushExp (sinkGamma ext env) (sink ext e) 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) + PushEnv :: Extend acc aenv aenv' + -> LeftHandSide arrs aenv' aenv'' + -> acc aenv' arrs + -> Extend acc aenv aenv'' + +pushArrayEnv :: (Shape sh, Elt e) => Extend acc aenv aenv' -> acc aenv' (Array sh e) -> Extend acc aenv (aenv', Array sh e) +pushArrayEnv env a = PushEnv env LeftHandSideArray 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 +append x BaseEnv = x +append x (PushEnv lhs as a) = x `append` PushEnv lhs as 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). @@ -352,8 +410,8 @@ 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 +bind BaseEnv = id +bind (PushEnv env lhs a) = bind env . Alet lhs 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 @@ -363,16 +421,20 @@ 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 + k BaseEnv = Stats.substitution "sink" id + k (PushEnv e (LeftHandSideWildcard _) _) = k e + k (PushEnv e (LeftHandSideArray) _) = SuccIdx . k e + k (PushEnv e (LeftHandSidePair l1 l2) _) = k (PushEnv (PushEnv e l1 undefined) l2 undefined) 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 - -- + k BaseEnv = Stats.substitution "sink1" id + k (PushEnv e (LeftHandSideWildcard _) _) = k e + k (PushEnv e (LeftHandSideArray) _) = split . k e + k (PushEnv e (LeftHandSidePair l1 l2) _) = k (PushEnv (PushEnv e l1 undefined) l2 undefined) + split :: Idx (env,s) t -> Idx ((env,u),s) t split ZeroIdx = ZeroIdx split (SuccIdx ix) = SuccIdx (SuccIdx ix) @@ -395,3 +457,24 @@ bindExps :: (Kit acc, Elt e) bindExps BaseSup = id bindExps (PushSup g b) = bindExps g . Let b +leftHandSideChangeEnv :: LeftHandSide arrs env1 env2 -> Exists (LeftHandSide arrs env3) +leftHandSideChangeEnv (LeftHandSideWildcard repr) = Exists $ LeftHandSideWildcard repr +leftHandSideChangeEnv LeftHandSideArray = Exists $ LeftHandSideArray +leftHandSideChangeEnv (LeftHandSidePair l1 l2) = case leftHandSideChangeEnv l1 of + Exists l1' -> case leftHandSideChangeEnv l2 of + Exists l2' -> Exists $ LeftHandSidePair l1' l2' + +compileVars :: ArrayVars env t -> OpenAcc env t +compileVars ArrayVarsNil = OpenAcc Anil +compileVars (ArrayVarsArray ix@ArrayVar{}) = OpenAcc $ Avar ix +compileVars (ArrayVarsPair v1 v2) = OpenAcc $ compileVars v1 `Apair` compileVars v2 + +aletBodyIsTrivial :: forall acc aenv aenv' a b. Kit acc => LeftHandSide a aenv aenv' -> acc aenv' b -> Maybe (a :~: b) +aletBodyIsTrivial lhs rhs = case extractArrayVars rhs of + Just vars -> case declareArrays @a @aenv (lhsToArraysR lhs) of + DeclareArrays lhs' _ value + | Just Refl <- matchLeftHandSide lhs lhs' + , Just Refl <- matchArrayVars vars $ value id + -> Just Refl + _ -> Nothing + Nothing -> Nothing diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index a5152b3b3..6f5ba689b 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -59,10 +59,8 @@ 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.Array.Sugar ( Array, ArraysR(..), arraysRtuple2 + , Elt, EltRepr, Shape, Tuple(..), eltType ) import Data.Array.Accelerate.Type import Data.Array.Accelerate.Debug.Flags ( array_fusion ) @@ -77,10 +75,10 @@ import System.IO.Unsafe -- for debugging -- | Apply the fusion transformation to a closed de Bruijn AST -- -convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc arrs +convertAcc :: Acc arrs -> DelayedAcc arrs convertAcc = convertAccWith defaultOptions -convertAccWith :: Arrays arrs => Config -> Acc arrs -> DelayedAcc arrs +convertAccWith :: Config -> Acc arrs -> DelayedAcc arrs convertAccWith config = withSimplStats . convertOpenAcc config -- | Apply the fusion transformation to a function of array arguments @@ -123,7 +121,7 @@ withSimplStats x = x -- manifest, and the two helper functions are even named as such! We should -- encode this property in the type somehow... -- -convertOpenAcc :: Arrays arrs => Config -> OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs +convertOpenAcc :: Config -> OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs convertOpenAcc config = manifest config . computeAcc . embedOpenAcc config -- Convert array computations into an embeddable delayed representation. @@ -135,7 +133,7 @@ delayed :: (Shape sh, Elt e) => Config -> OpenAcc aenv (Array sh e) -> DelayedOp delayed config (embedOpenAcc config -> Embed env cc) | BaseEnv <- env = case simplify cc of - Done v -> avarIn v + Done v -> avarsIn 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) @@ -163,13 +161,13 @@ manifest config (OpenAcc pacc) = -- Non-fusible terms -- ----------------- Avar ix -> Avar ix - Use arr -> Use arr + Use repr arr -> Use repr arr Unit e -> Unit (cvtE e) - Alet bnd body -> alet (manifest config bnd) (manifest config body) + Alet lhs bnd body -> alet lhs (manifest config bnd) (manifest config body) Acond p t e -> Acond (cvtE p) (manifest config t) (manifest config e) Awhile p f a -> Awhile (cvtAF p) (cvtAF f) (manifest config a) - Atuple tup -> Atuple (cvtAT tup) - Aprj ix tup -> Aprj ix (manifest config tup) + Apair a1 a2 -> Apair (manifest config a1) (manifest config a2) + Anil -> Anil Apply f a -> apply (cvtAF f) (manifest config a) Aforeign ff f a -> Aforeign ff (cvtAF f) (manifest config a) @@ -217,17 +215,17 @@ manifest config (OpenAcc pacc) = -- Flatten needless let-binds, which can be introduced by the -- conversion to the internal embeddable representation. -- - alet :: (Arrays a, Arrays b) - => DelayedOpenAcc aenv a - -> DelayedOpenAcc (aenv,a) b + alet :: LeftHandSide a aenv aenv' + -> DelayedOpenAcc aenv a + -> DelayedOpenAcc aenv' b -> PreOpenAcc DelayedOpenAcc aenv b - alet bnd body - | Manifest (Avar ZeroIdx) <- body - , Manifest x <- bnd + alet lhs bnd body + | Just Refl <- aletBodyIsTrivial lhs body + , Manifest x <- bnd = x -- | otherwise - = Alet bnd body + = Alet lhs bnd body -- Eliminate redundant application to an identity function. This -- arises in the use of pipe to avoid fusion and force its argument @@ -236,26 +234,21 @@ manifest config (OpenAcc pacc) = -- > compute :: Acc a -> Acc a -- > compute = id >-> id -- - apply :: (Arrays a, Arrays b) - => PreOpenAfun DelayedOpenAcc aenv (a -> b) + apply :: PreOpenAfun DelayedOpenAcc aenv (a -> b) -> DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv b apply afun x - | Alam (Abody body) <- afun - , Manifest (Avar ZeroIdx) <- body + | Alam lhs (Abody body) <- afun + , Just Refl <- aletBodyIsTrivial lhs body , Manifest x' <- x = Stats.ruleFired "applyD/identity" x' -- | otherwise = Apply afun x - cvtAT :: Atuple (OpenAcc aenv) a -> Atuple (DelayedOpenAcc aenv) a - cvtAT NilAtup = NilAtup - cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` manifest config a - cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f - cvtAF (Alam f) = Alam (cvtAF f) - cvtAF (Abody b) = Abody (manifest config b) + cvtAF (Alam lhs f) = Alam lhs (cvtAF f) + cvtAF (Abody b) = Abody (manifest config b) -- cvtS :: PreOpenSeq OpenAcc aenv senv s -> PreOpenSeq DelayedOpenAcc aenv senv s -- cvtS = convertOpenSeq config @@ -322,7 +315,7 @@ convertOpenExp config exp = convertOpenAfun :: Config -> OpenAfun aenv f -> DelayedOpenAfun aenv f -convertOpenAfun c (Alam f) = Alam (convertOpenAfun c f) +convertOpenAfun c (Alam lhs f) = Alam lhs (convertOpenAfun c f) convertOpenAfun c (Abody b) = Abody (convertOpenAcc c b) {-- @@ -370,10 +363,10 @@ convertOpenSeq config s = -- 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 EmbedAcc acc = forall aenv 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 => Config -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs +embedOpenAcc :: Config -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs embedOpenAcc config (OpenAcc pacc) = embedPreAcc config (embedOpenAcc config) elimOpenAcc pacc where @@ -396,7 +389,7 @@ embedOpenAcc config (OpenAcc pacc) = embedPreAcc - :: forall acc aenv arrs. (Kit acc, Arrays arrs) + :: forall acc aenv arrs. Kit acc => Config -> EmbedAcc acc -> ElimAcc acc @@ -415,18 +408,18 @@ embedPreAcc config embedAcc elimAcc pacc -- want to fuse past array let bindings, as this would imply work -- duplication. SEE: [Sharing vs. Fusion] -- - Alet bnd body -> aletD embedAcc elimAcc bnd body - Aprj ix tup -> aprjD embedAcc ix tup + Alet lhs bnd body -> aletD embedAcc elimAcc lhs bnd body + Anil -> done $ Anil Acond p at ae -> acondD embedAcc (cvtE p) at ae Apply f a -> done $ Apply (cvtAF f) (cvtA a) Awhile p f a -> done $ Awhile (cvtAF p) (cvtAF f) (cvtA a) - Atuple tup -> done $ Atuple (cvtAT tup) + Apair a1 a2 -> done $ Apair (cvtA a1) (cvtA a2) 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 + Use repr arrs -> done $ Use repr arrs Unit e -> done $ Unit (cvtE e) -- Producers @@ -469,19 +462,19 @@ embedPreAcc config embedAcc elimAcc pacc -- 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 -> embed (into2 stencil1 (cvtF f) (cvtB x)) a - Stencil2 f x a y b -> embed2 (into3 stencil2 (cvtF f) (cvtB x) (cvtB y)) a b + Fold f z a -> embed ArraysRarray (into2 Fold (cvtF f) (cvtE z)) a + Fold1 f a -> embed ArraysRarray (into Fold1 (cvtF f)) a + FoldSeg f z a s -> embed2 ArraysRarray (into2 FoldSeg (cvtF f) (cvtE z)) a s + Fold1Seg f a s -> embed2 ArraysRarray (into Fold1Seg (cvtF f)) a s + Scanl f z a -> embed ArraysRarray (into2 Scanl (cvtF f) (cvtE z)) a + Scanl1 f a -> embed ArraysRarray (into Scanl1 (cvtF f)) a + Scanl' f z a -> embed arraysRtuple2 (into2 Scanl' (cvtF f) (cvtE z)) a + Scanr f z a -> embed ArraysRarray (into2 Scanr (cvtF f) (cvtE z)) a + Scanr1 f a -> embed ArraysRarray (into Scanr1 (cvtF f)) a + Scanr' f z a -> embed arraysRtuple2 (into2 Scanr' (cvtF f) (cvtE z)) a + Permute f d p a -> embed2 ArraysRarray (into2 permute (cvtF f) (cvtF p)) d a + Stencil f x a -> embed ArraysRarray (into2 stencil1 (cvtF f) (cvtB x)) a + Stencil2 f x a y b -> embed2 ArraysRarray (into3 stencil2 (cvtF f) (cvtB x) (cvtB y)) a b where -- If fusion is not enabled, force terms to the manifest representation @@ -490,19 +483,18 @@ embedPreAcc config embedAcc elimAcc pacc unembed x | array_fusion `member` options config = x | Embed env cc <- x - = case compute cc of - Avar v -> Embed env (Done v) - pacc -> Embed (env `PushEnv` inject pacc) (Done ZeroIdx) - - cvtA :: Arrays a => acc aenv' a -> acc aenv' a + , pacc <- compute cc + = case extractArrayVars $ inject pacc of + Just vars -> Embed env $ Done vars + _ + | DeclareArrays lhs _ value <- declareArrays (arraysRepr pacc) + -> Embed (PushEnv env lhs $ inject pacc) $ Done $ value id + + cvtA :: 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 (Alam lhs f) = Alam lhs (cvtAF f) cvtAF (Abody a) = Abody (cvtA a) -- Helpers to shuffle the order of arguments to a constructor @@ -554,14 +546,12 @@ embedPreAcc config embedAcc elimAcc pacc -- directly on the delayed representation. See also: [Representing -- delayed arrays] -- - fuse :: Arrays as - => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs) + fuse :: (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) + fuse2 :: (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 @@ -602,29 +592,39 @@ embedPreAcc config embedAcc elimAcc pacc -- useful for the 'permute' operation to know when it can in-place -- update the array of default values. -- - embed :: (Arrays as, Arrays bs) - => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs) + embed :: ArraysR bs + -> (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs) -> acc aenv as -> Embed acc aenv bs - embed op (embedAcc -> Embed env cc) - | Done{} <- cc = Embed (BaseEnv `PushEnv` inject (op BaseEnv (computeAcc (Embed env cc)))) (Done ZeroIdx) - | otherwise = Embed (env `PushEnv` inject (op env (inject (compute cc)))) (Done ZeroIdx) + embed reprBs op (embedAcc -> Embed env cc) + | Done{} <- cc + , DeclareArrays lhs _ value <- declareArrays reprBs + = Embed (PushEnv BaseEnv lhs $ inject (op BaseEnv (computeAcc (Embed env cc)))) $ Done $ value id + | otherwise + -- Next line is duplicated for both branches, as the type variable for the environment is instantiated differently + , DeclareArrays lhs _ value <- declareArrays reprBs + = Embed (PushEnv env lhs $ inject (op env (inject (compute cc)))) $ Done $ value id - embed2 :: (Arrays as, Arrays bs, Arrays cs) - => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs) + embed2 :: ArraysR 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 op (embedAcc -> Embed env1 cc1) a0 + embed2 reprCs op (embedAcc -> Embed env1 cc1) a0 | Done{} <- cc1 , a1 <- computeAcc (Embed env1 cc1) - = embed (\env0 -> op env0 (sink env0 a1)) a0 + = embed reprCs (\env0 -> op env0 (sink env0 a1)) a0 -- | Embed env0 cc0 <- embedAcc (sink env1 a0) , env <- env1 `append` env0 = case cc0 of - Done{} -> Embed (env1 `PushEnv` inject (op env1 (inject (compute cc1)) (computeAcc (Embed env0 cc0)))) (Done ZeroIdx) - _ -> Embed (env `PushEnv` inject (op env (inject (compute (sink env0 cc1))) (inject (compute cc0)))) (Done ZeroIdx) + Done{} + | DeclareArrays lhs _ value <- declareArrays reprCs + -> Embed (PushEnv env1 lhs $ inject (op env1 (inject (compute cc1)) (computeAcc (Embed env0 cc0)))) $ Done $ value id + _ + -- Next line is duplicated for both branches, as the type variable for the environment is instantiated differently + | DeclareArrays lhs _ value <- declareArrays reprCs + -> Embed (PushEnv env lhs $ inject (op env (inject (compute (sink env0 cc1))) (inject (compute cc0)))) $ Done $ value id -- trav1 :: (Arrays as, Arrays bs) -- => (forall aenv'. Embed acc aenv' as -> Embed acc aenv' as) @@ -632,7 +632,7 @@ embedPreAcc config embedAcc elimAcc pacc -- -> 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) + -- = Embed (env `pushArrayEnv` inject (op env (inject (compute cc)))) doneZeroIdx -- trav2 :: (Arrays as, Arrays bs, Arrays cs) -- => (forall aenv'. Embed acc aenv' as -> Embed acc aenv' as) @@ -645,19 +645,19 @@ embedPreAcc config embedAcc elimAcc pacc -- | env <- env1 `append` env0 -- , acc1 <- inject . compute $ sink env0 cc1 -- , acc0 <- inject . compute $ cc0 - -- = Embed (env `PushEnv` inject (op env acc1 acc0)) (Done ZeroIdx) + -- = Embed (env `pushArrayEnv` inject (op env acc1 acc0)) doneZeroIdx -- 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) + -- | otherwise = Embed (env `pushArrayEnv` inject (compute cc)) doneZeroIdx -- -- 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) + -- = Embed (env `pushArrayEnv` inject (Collect s')) doneZeroIdx {-- @@ -791,12 +791,10 @@ 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. + -- non-recursive in 'acc'. -- - Done :: Arrays a - => Idx aenv a - -> Cunctation acc aenv a + Done :: ArrayVars aenv arrs + -> Cunctation acc aenv arrs -- We can represent an array by its shape and a function to compute an element -- at each index. @@ -816,10 +814,9 @@ data Cunctation acc aenv a where => PreExp acc aenv sh' -> PreFun acc aenv (sh' -> sh) -> PreFun acc aenv (a -> b) - -> Idx aenv (Array sh a) + -> ArrayVar aenv (Array sh a) -> Cunctation acc aenv (Array sh' b) - instance Kit acc => Simplify (Cunctation acc aenv a) where simplify = \case Done v -> Done v @@ -827,17 +824,20 @@ instance Kit acc => Simplify (Cunctation acc aenv a) where Step (simplify -> sh) (simplify -> p) (simplify -> f) v | Just Refl <- match sh (arrayShape v) , Just Refl <- isIdentity p - , Just Refl <- isIdentity f -> Done v + , Just Refl <- isIdentity f -> Done $ ArrayVarsArray v | otherwise -> Step sh p 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 :: 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) + | Just vars <- extractArrayVars $ inject pacc = Embed BaseEnv (Done vars) + | otherwise = case declareArrays (arraysRepr pacc) of + DeclareArrays lhs _ value -> Embed (PushEnv BaseEnv lhs $ inject pacc) $ Done $ value id +doneZeroIdx :: (Shape sh, Elt e) => Cunctation acc (aenv, Array sh e) (Array sh e) +doneZeroIdx = Done $ ArrayVarsArray $ ArrayVar ZeroIdx -- Recast a cunctation into a mapping from indices to elements. -- @@ -846,11 +846,9 @@ yield :: Kit acc -> 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" + Yield{} -> cc + Step sh p f v -> Yield sh (f `compose` indexArray v `compose` p) + Done (ArrayVarsArray v@ArrayVar{}) -> Yield (arrayShape v) (indexArray v) -- Recast a cunctation into transformation step form. Not possible if the source @@ -861,11 +859,9 @@ step :: Kit acc -> 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" + Yield{} -> Nothing + Step{} -> Just cc + Done (ArrayVarsArray v@ArrayVar{}) -> Just $ Step (arrayShape v) identity identity v -- Get the shape of a delayed array @@ -876,12 +872,6 @@ shape cc | 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 @a - - -- Environment manipulation -- ======================== @@ -950,45 +940,51 @@ instance Kit acc => Sink (SinkSeq acc senv) where -- We do a bit of extra work to (try to) maintain that terms should be left -- at their lowest common use site. SEE: [Fusion and the lowest common use site] -- -computeAcc :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> acc aenv arrs -computeAcc (Embed BaseEnv cc) = inject (compute cc) -computeAcc (Embed env@(PushEnv bot top) cc) = +computeAcc :: Kit acc => Embed acc aenv arrs -> acc aenv arrs +computeAcc (Embed BaseEnv cc) = inject (compute cc) +computeAcc (Embed env@(PushEnv bot lhs top) cc) = case simplify cc of - Done v -> bindA env (avarIn v) + Done v -> bindA env (avarsIn v) Yield sh f -> bindA env (inject (Generate sh f)) - Step sh p f v + Step sh p f v@(ArrayVar ix) | Just Refl <- match sh (arrayShape v) , Just Refl <- isIdentity p - -> case v of + -> case ix of ZeroIdx - | Just g <- strengthen noTop f -> bindA bot (inject (Map g top)) + | LeftHandSideArray <- lhs + , Just g <- strengthen noTop f -> bindA bot (inject (Map g top)) _ -> bindA env (inject (Map f (avarIn v))) | Just Refl <- isIdentity f - -> case v of + -> case ix of ZeroIdx - | Just q <- strengthen noTop p + | LeftHandSideArray <- lhs + , Just q <- strengthen noTop p , Just sz <- strengthen noTop sh -> bindA bot (inject (Backpermute sz q top)) _ -> bindA env (inject (Backpermute sh p (avarIn v))) | otherwise - -> case v of + -> case ix of ZeroIdx - | Just g <- strengthen noTop f + | LeftHandSideArray <- lhs + , Just g <- strengthen noTop f , Just q <- strengthen noTop p , Just sz <- strengthen noTop sh -> bindA bot (inject (Transform sz q g top)) _ -> bindA env (inject (Transform sh p f (avarIn v))) where - bindA :: (Kit acc, Arrays a) + bindA :: Kit acc => Extend acc aenv aenv' -> acc aenv' a -> acc aenv a - bindA BaseEnv b = b - bindA (PushEnv env a) b = - case extract b of - Just (Avar ZeroIdx) -> bindA env a - _ -> bindA env (inject (Alet a b)) + bindA BaseEnv b = b + bindA (PushEnv env lhs a) b = + -- If the freshly bound value is directly, returned, we don't have to bind it in a + -- let. We can do this if the left hand side does not contain wildcards (other than + -- wildcards for unit / nil) and if the value contains the same variables. + case aletBodyIsTrivial lhs b of + Just Refl -> bindA env a + Nothing -> bindA env (inject (Alet lhs a b)) noTop :: (aenv, a) :?> aenv noTop ZeroIdx = Nothing @@ -998,9 +994,11 @@ computeAcc (Embed env@(PushEnv bot top) cc) = -- Convert 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) => Cunctation acc aenv arrs -> PreOpenAcc acc aenv arrs +compute :: Kit acc => Cunctation acc aenv arrs -> PreOpenAcc acc aenv arrs compute cc = case simplify cc of - Done v -> Avar v + Done ArrayVarsNil -> Anil + Done (ArrayVarsArray v@ArrayVar{}) -> Avar v + Done (ArrayVarsPair v1 v2) -> avarsIn v1 `Apair` avarsIn v2 Yield sh f -> Generate sh f Step sh p f v | Just Refl <- match sh (arrayShape v) @@ -1063,17 +1061,17 @@ 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 + a' = avarsIn v in - Just $ Embed (env `PushEnv` inject (Map f' a')) (Done ZeroIdx) + Just $ Embed (env `pushArrayEnv` inject (Map f' a')) doneZeroIdx | 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' + a' = avarsIn v' in - Just $ Embed (env' `PushEnv` inject (Map f' a')) (Done ZeroIdx) + Just $ Embed (env' `pushArrayEnv` inject (Map f' a')) doneZeroIdx unzipD _ _ = Nothing @@ -1165,7 +1163,7 @@ reshapeD -> 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) + = Embed (env `pushArrayEnv` inject (Reshape sl (avarsIn v))) doneZeroIdx | otherwise = Stats.ruleFired "reshapeD" @@ -1292,13 +1290,14 @@ zipWithD f cc1 cc0 -- in -- in -- -aletD :: (Kit acc, Arrays arrs, Arrays brrs) +aletD :: Kit acc => EmbedAcc acc -> ElimAcc acc - -> acc aenv arrs - -> acc (aenv,arrs) brrs - -> Embed acc aenv brrs -aletD embedAcc elimAcc (embedAcc -> Embed env1 cc1) acc0 + -> LeftHandSide arrs aenv aenv' + -> acc aenv arrs + -> acc aenv' brrs + -> Embed acc aenv brrs +aletD embedAcc elimAcc lhs (embedAcc -> Embed env1 cc1) acc0 -- let-floating -- ------------ @@ -1307,24 +1306,26 @@ aletD embedAcc elimAcc (embedAcc -> Embed env1 cc1) acc0 -- 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 + | LeftHandSideArray <- lhs + , Done (ArrayVarsArray v1@ArrayVar{}) <- 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' embedAcc elimAcc lhs (Embed env1 cc1) (embedAcc acc0) -aletD' :: forall acc aenv arrs brrs. (Kit acc, Arrays arrs, Arrays brrs) +aletD' :: forall acc aenv aenv' arrs brrs. Kit acc => 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) + -> LeftHandSide arrs aenv aenv' + -> Embed acc aenv arrs + -> Embed acc aenv' brrs + -> Embed acc aenv brrs +aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) -- let-binding -- ----------- @@ -1337,7 +1338,7 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) | acc1 <- computeAcc (Embed env1 cc1) , False <- elimAcc acc1 acc0 = Stats.ruleFired "aletD/bind" - $ Embed (BaseEnv `PushEnv` acc1 `append` env0) cc0 + $ Embed (BaseEnv `pushArrayEnv` acc1 `append` env0) cc0 -- let-elimination -- --------------- @@ -1352,22 +1353,23 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) Yield{} -> eliminate env1 cc1 acc0' where - acc0 :: acc (aenv, arrs) brrs + acc0 :: acc aenv' 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) + eliminate :: forall aenv aenv' sh e brrs. (Shape sh, Elt e) => 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 + | Done v1 <- cc1 + , ArrayVarsArray v1' <- v1 = 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 @@ -1376,7 +1378,7 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) 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 env0' cc0' <- embedAcc $ rebuildA (subAtop bnd) $ kmap (replaceA sh1' f1' $ ArrayVar ZeroIdx) body = Embed (env1 `append` env0') cc0' -- As part of let-elimination, we need to replace uses of array variables in @@ -1388,8 +1390,8 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) -- 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) + replaceE :: forall env aenv sh e t. + PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> ArrayVar aenv (Array sh e) -> PreOpenExp acc env aenv t -> PreOpenExp acc env aenv t replaceE sh' f' avar exp = @@ -1444,8 +1446,8 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) 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) + replaceF :: forall env aenv sh e t. + PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> ArrayVar aenv (Array sh e) -> PreOpenFun acc env aenv t -> PreOpenFun acc env aenv t replaceF sh' f' avar fun = @@ -1453,8 +1455,8 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) 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) + replaceA :: forall aenv sh e a. + PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> ArrayVar aenv (Array sh e) -> PreOpenAcc acc aenv a -> PreOpenAcc acc aenv a replaceA sh' f' avar pacc = @@ -1463,17 +1465,19 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) | Just Refl <- match v avar -> Avar avar | otherwise -> Avar v - Alet bnd body -> - let sh'' = weaken SuccIdx sh' - f'' = weaken SuccIdx f' + Alet lhs bnd (body :: acc aenv1 a) -> + let w :: aenv :> aenv1 + w = weakenWithLHS lhs + sh'' = weaken w sh' + f'' = weaken w f' in - Alet (cvtA bnd) (kmap (replaceA sh'' f'' (SuccIdx avar)) body) + Alet lhs (cvtA bnd) (kmap (replaceA sh'' f'' (weaken w avar)) body) - Use arrs -> Use arrs + Use repr arrs -> Use repr 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) + Anil -> Anil + Apair a1 a2 -> Apair (cvtA a1) (cvtA a2) 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 @@ -1517,22 +1521,30 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) 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) + PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> ArrayVar 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 + cvt sh'' f'' avar' (Alam lhs (af :: PreOpenAfun acc aenv1 b)) = + Alam lhs $ cvt (weaken w sh'') + (weaken w f'') + (weaken w avar') + af + where + w :: aenv :> aenv1 + w = weakenWithLHS lhs + +-- Do not fuse bindings of multiple variables +aletD' _ _ lhs (Embed env1 cc1) (Embed env0 cc0) + = Stats.ruleFired "aletD/bind" + $ Embed (PushEnv BaseEnv lhs acc1 `append` env0) cc0 + where + acc1 = computeAcc $ Embed env1 cc1 + {-- cvtSeq :: PreOpenSeq acc aenv senv s -> PreOpenSeq acc aenv senv s @@ -1575,7 +1587,7 @@ aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0) -- both branches. This would result in redundant work processing the bindings -- for the branch not taken. -- -acondD :: (Kit acc, Arrays arrs) +acondD :: Kit acc => EmbedAcc acc -> PreExp acc aenv Bool -> acc aenv arrs @@ -1589,26 +1601,6 @@ acondD embedAcc p t e (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 - | Just (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 -- ------------------ @@ -1646,12 +1638,12 @@ restrict :: (Kit acc, Shape sh, Shape sl, Elt 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 = simplify . Shape . avarIn +arrayShape :: (Kit acc) => ArrayVar aenv (Array sh e) -> PreExp acc aenv sh +arrayShape v@ArrayVar{} = simplify $ Shape $ avarIn v -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))) +indexArray :: (Kit acc) => ArrayVar aenv (Array sh e) -> PreFun acc aenv (sh -> e) +indexArray v@ArrayVar{} = 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))) +linearIndex :: (Kit acc) => ArrayVar aenv (Array sh e) -> PreFun acc aenv (Int -> e) +linearIndex v@ArrayVar{} = Lam (Body (LinearIndex (avarIn v) (Var ZeroIdx))) diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 5566d010a..37db5831c 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -31,7 +34,7 @@ module Data.Array.Accelerate.Trafo.Sharing ( -- * HOAS to de Bruijn conversion convertAcc, convertAccWith, - Afunction, AfunctionR, + Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr, convertAfun, convertAfunWith, Function, FunctionR, @@ -62,6 +65,7 @@ import Prelude import Data.BitSet ( (\\), member ) import Data.Array.Accelerate.Error import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Trafo.Base import Data.Array.Accelerate.Trafo.Config import Data.Array.Accelerate.Array.Sugar as Sugar hiding ( (!!) ) import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc @@ -84,6 +88,15 @@ data Layout env env' where EmptyLayout :: Layout env () PushLayout :: Typeable t => Layout env env' -> Idx env t -> Layout env (env', t) +data ArrayLayout env env' where + ArrayEmptyLayout :: ArrayLayout env () + ArrayPushLayout + :: Typeable t + => ArrayLayout env env1 + -> LeftHandSide t env1 env2 + -> ArrayVars env t + -> ArrayLayout env env2 + -- Project the nth index out of an environment layout. -- -- The first argument provides context information for error messages in the @@ -108,6 +121,24 @@ prjIdx context = go no :: String -> a no reason = $internalError "prjIdx" (printf "%s\nin the context: %s" reason context) +prjArrayIdx :: Typeable t + => String + -> Int + -> ArrayLayout env env' + -> AST.OpenAcc env t +prjArrayIdx context = go + where + go :: forall env env' t. Typeable t => Int -> ArrayLayout env env' -> AST.OpenAcc env t + go _ ArrayEmptyLayout = no "environment does not contain index" + go 0 (ArrayPushLayout _ _ (ix :: ArrayVars env0 s)) + | Just ix' <- gcast ix = compileVars ix' + | otherwise = no $ printf "couldn't match expected type `%s' with actual type `%s'" + (show (typeOf (undefined::t))) + (show (typeOf (undefined::s))) + go n (ArrayPushLayout l _ _) = go (n-1) l + + no :: String -> a + no reason = $internalError "prjArrayIdx" (printf "%s\nin the context: %s" reason context) -- Add an entry to a layout, incrementing all indices -- @@ -115,10 +146,22 @@ incLayout :: Layout env env' -> Layout (env, t) env' incLayout EmptyLayout = EmptyLayout incLayout (PushLayout lyt ix) = PushLayout (incLayout lyt) (SuccIdx ix) +incArrayLayoutWith :: env1 :> env2 -> ArrayLayout env1 env' -> ArrayLayout env2 env' +incArrayLayoutWith _ ArrayEmptyLayout = ArrayEmptyLayout +incArrayLayoutWith k (ArrayPushLayout lyt lhs t) = ArrayPushLayout (incArrayLayoutWith k lyt) lhs (incVarsWith k t) + sizeLayout :: Layout env env' -> Int sizeLayout EmptyLayout = 0 sizeLayout (PushLayout lyt _) = 1 + sizeLayout lyt +sizeArrayLayout :: ArrayLayout env env' -> Int +sizeArrayLayout ArrayEmptyLayout = 0 +sizeArrayLayout (ArrayPushLayout lyt _ _) = 1 + sizeArrayLayout lyt + +incVarsWith :: env1 :> env2 -> ArrayVars env1 t -> ArrayVars env2 t +incVarsWith _ ArrayVarsNil = ArrayVarsNil +incVarsWith k (ArrayVarsArray (ArrayVar idx)) = ArrayVarsArray $ ArrayVar $ k idx +incVarsWith k (ArrayVarsPair v1 v2) = incVarsWith k v1 `ArrayVarsPair` incVarsWith k v2 -- Conversion from HOAS to de Bruijn computation AST -- ================================================= @@ -129,22 +172,30 @@ sizeLayout (PushLayout lyt _) = 1 + sizeLayout lyt -- | Convert a closed array expression to de Bruijn form while also incorporating sharing -- information. -- -convertAcc :: Arrays arrs => Acc arrs -> AST.Acc arrs +convertAcc :: Arrays arrs => Acc arrs -> AST.Acc (ArrRepr arrs) convertAcc = convertAccWith defaultOptions -convertAccWith :: Arrays arrs => Config -> Acc arrs -> AST.Acc arrs -convertAccWith config = convertOpenAcc config EmptyLayout +convertAccWith :: Arrays arrs => Config -> Acc arrs -> AST.Acc (ArrRepr arrs) +convertAccWith config (Acc acc) = convertOpenAcc config ArrayEmptyLayout acc -- | Convert a closed function over array computations, while incorporating -- sharing information. -- -convertAfun :: Afunction f => f -> AST.Afun (AfunctionR f) +convertAfun :: Afunction f => f -> AST.Afun (AreprFunctionR f) convertAfun = convertAfunWith defaultOptions -convertAfunWith :: Afunction f => Config -> f -> AST.Afun (AfunctionR f) -convertAfunWith config = convertOpenAfun config EmptyLayout +convertAfunWith :: Afunction f => Config -> f -> AST.Afun (AreprFunctionR f) +convertAfunWith config = convertOpenAfun config ArrayEmptyLayout +data AfunctionRepr f ar areprr where + AfunctionReprBody + :: Arrays b => AfunctionRepr (Acc b) b (ArrRepr b) + + AfunctionReprLam + :: Arrays a + => AfunctionRepr b br breprr + -> AfunctionRepr (Acc a -> b) (a -> br) (ArrRepr a -> breprr) -- Convert a HOAS fragment into de Bruijn form, binding variables into the typed -- environment layout one binder at a time. @@ -155,31 +206,40 @@ convertAfunWith config = convertOpenAfun config EmptyLayout -- class Afunction f where type AfunctionR f - convertOpenAfun :: Config -> Layout aenv aenv -> f -> AST.OpenAfun aenv (AfunctionR f) + type AreprFunctionR f + afunctionRepr :: AfunctionRepr f (AfunctionR f) (AreprFunctionR f) + convertOpenAfun :: Config -> ArrayLayout aenv aenv -> f -> AST.OpenAfun aenv (AreprFunctionR f) instance (Arrays a, Afunction r) => Afunction (Acc a -> r) where type AfunctionR (Acc a -> r) = a -> AfunctionR r - convertOpenAfun config alyt f = - let a = Acc $ Atag (sizeLayout alyt) - alyt' = incLayout alyt `PushLayout` ZeroIdx - in Alam $ convertOpenAfun config alyt' (f a) + type AreprFunctionR (Acc a -> r) = ArrRepr a -> AreprFunctionR r + + afunctionRepr = AfunctionReprLam $ afunctionRepr @r + convertOpenAfun config alyt f = case declareArrays $ arrays @a of + DeclareArrays lhs k value -> + let + a = Acc $ SmartAcc $ Atag $ sizeArrayLayout alyt + alyt' = ArrayPushLayout (incArrayLayoutWith k alyt) lhs (value id) + in Alam lhs $ convertOpenAfun config alyt' $ f a instance Arrays b => Afunction (Acc b) where type AfunctionR (Acc b) = b - convertOpenAfun config alyt body = Abody $ convertOpenAcc config alyt body + type AreprFunctionR (Acc b) = ArrRepr b + afunctionRepr = AfunctionReprBody + convertOpenAfun config alyt (Acc body) = Abody $ convertOpenAcc config alyt body -- | Convert an open array expression to de Bruijn form while also incorporating sharing -- information. -- convertOpenAcc - :: Arrays arrs + :: Typeable arrs => Config - -> Layout aenv aenv - -> Acc arrs + -> ArrayLayout aenv aenv + -> SmartAcc arrs -> AST.OpenAcc aenv arrs convertOpenAcc config alyt acc = - let lvl = sizeLayout alyt + let lvl = sizeArrayLayout alyt fvs = [lvl-1, lvl-2 .. 0] (sharingAcc, initialEnv) = recoverSharingAcc config lvl fvs acc in @@ -194,15 +254,15 @@ convertOpenAcc config alyt acc = -- in reverse chronological order (outermost variable is at the end of the list). -- convertSharingAcc - :: forall aenv arrs. Arrays arrs + :: forall aenv arrs. Typeable arrs => Config - -> Layout aenv aenv + -> ArrayLayout 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) + = prjArrayIdx (ctxt ++ "; i = " ++ show i) i alyt | null aenv' = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++ show (hashStableNameHeight sa) ++ ")" @@ -213,19 +273,25 @@ convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa)) 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 (AletSharing sa@(StableSharingAcc (_ :: StableAccName as) boundAcc) bodyAcc)) + = case declareArrays $ arraysRepr bound of + DeclareArrays lhs k value -> + let + alyt' = ArrayPushLayout (incArrayLayoutWith k alyt) lhs (value id) + in + AST.OpenAcc $ AST.Alet + lhs + bound + (convertSharingAcc config alyt' (sa:aenv') bodyAcc) + where + aenv' = lams ++ aenv + bound = convertSharingAcc config alyt aenv' (ScopedAcc [] boundAcc) convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) = AST.OpenAcc $ let aenv' = lams ++ aenv - cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a + cvtA :: Typeable a => ScopedAcc a -> AST.OpenAcc aenv a cvtA = convertSharingAcc config alyt aenv' cvtE :: Elt t => ScopedExp t -> AST.Exp aenv t @@ -237,32 +303,49 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) 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 :: (Typeable a, Typeable b) => ArraysR a -> (SmartAcc a -> ScopedAcc b) -> AST.OpenAfun aenv (a -> b) cvtAfun1 = convertSharingAfun1 config alyt aenv' + + cvtAprj :: forall a b c. (Typeable a, Typeable b) => PairIdx (a, b) c -> ScopedAcc (a, b) -> AST.OpenAcc aenv c + cvtAprj ix a = cvtAprj' ix $ cvtA a + + cvtAprj' :: forall a b c aenv1. (Typeable a, Typeable b) => PairIdx (a, b) c -> AST.OpenAcc aenv1 (a, b) -> AST.OpenAcc aenv1 c + cvtAprj' PairIdxLeft (AST.OpenAcc (AST.Apair a _)) = a + cvtAprj' PairIdxRight (AST.OpenAcc (AST.Apair _ b)) = b + cvtAprj' ix a = case declareArrays $ arraysRepr a of + DeclareArrays lhs _ value -> + AST.OpenAcc $ AST.Alet lhs a $ cvtAprj' ix $ compileVars $ value id 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) + -> let AST.OpenAcc a = prjArrayIdx ("de Bruijn conversion tag " ++ show i) i alyt + in a + + Pipe reprA reprB (afun1 :: SmartAcc as -> ScopedAcc bs) (afun2 :: SmartAcc bs -> ScopedAcc cs) acc + -> + let + noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ()) + boundAcc = AST.Apply (cvtAfun1 reprA afun1) (cvtA acc) + in case declareArrays reprB of + DeclareArrays lhs k value -> + let + alyt' = ArrayPushLayout (incArrayLayoutWith k alyt) lhs (value id) + bodyAcc = AST.Apply + (convertSharingAfun1 config alyt' (noStableSharing : aenv') reprB afun2) + (compileVars $ value id) + in AST.Alet lhs (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) Aforeign ff afun acc -> AST.Aforeign ff (convertAfunWith config 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) + Awhile reprA pred iter init -> AST.Awhile (cvtAfun1 reprA pred) (cvtAfun1 reprA iter) (cvtA init) + Anil -> AST.Anil + Apair acc1 acc2 -> AST.Apair (cvtA acc1) (cvtA acc2) + Aprj ix a -> let AST.OpenAcc a' = cvtAprj ix a + in a' + Use (array :: a) -> AST.Use (arrays @a) (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) @@ -294,7 +377,6 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) (cvtA acc2) -- Collect seq -> AST.Collect (convertSharingSeq config alyt EmptyLayout aenv' [] seq) - {-- -- Sequence expressions -- -------------------- @@ -444,17 +526,20 @@ convertSharingSeq config alyt slyt aenv senv s --} convertSharingAfun1 - :: forall aenv a b. (Arrays a, Arrays b) + :: forall aenv a b. (Typeable a, Typeable b) => Config - -> Layout aenv aenv + -> ArrayLayout aenv aenv -> [StableSharingAcc] - -> (Acc a -> ScopedAcc b) + -> ArraysR a + -> (SmartAcc 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 +convertSharingAfun1 config alyt aenv reprA f = case declareArrays reprA of + DeclareArrays lhs k value -> + let + alyt' = ArrayPushLayout (incArrayLayoutWith k alyt) lhs (value id) + body = f undefined + in + Alam lhs (Abody (convertSharingAcc config alyt' aenv body)) {-- convertSharingAfun2 @@ -484,26 +569,12 @@ convertSharingAfun3 config alyt aenv f 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 + -> ArrayLayout aenv aenv -> [StableSharingAcc] -> PreBoundary ScopedAcc ScopedExp t -> AST.PreBoundary AST.OpenAcc aenv t @@ -602,7 +673,7 @@ convertOpenExp config lyt exp = fvs = [lvl-1, lvl-2 .. 0] (sharingExp, initialEnv) = recoverSharingExp config lvl fvs exp in - convertSharingExp config lyt EmptyLayout initialEnv [] sharingExp + convertSharingExp config lyt ArrayEmptyLayout initialEnv [] sharingExp -- | Convert an open expression with given environment layouts and sharing information into @@ -616,7 +687,7 @@ convertSharingExp :: forall t env aenv. Elt t => Config -> Layout env env -- scalar environment - -> Layout aenv aenv -- array environment + -> ArrayLayout 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 @@ -706,7 +777,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp Foreign ff f e -> AST.Foreign ff (convertFunWith config f) (cvt e) Coerce e -> AST.Coerce (cvt e) - cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a + cvtA :: Typeable a => ScopedAcc a -> AST.OpenAcc aenv a cvtA = convertSharingAcc config alyt aenv cvtT :: Tuple ScopedExp tup -> Tuple (AST.OpenExp env aenv) tup @@ -732,7 +803,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp convertSharingTuple :: Config -> Layout env env - -> Layout aenv aenv + -> ArrayLayout aenv aenv -> [StableSharingExp] -- currently bound scalar sharing-variables -> [StableSharingAcc] -- currently bound array sharing-variables -> Tuple ScopedExp t @@ -748,7 +819,7 @@ convertSharingTuple config lyt alyt env aenv tup = convertSharingFun1 :: forall a b aenv. (Elt a, Elt b) => Config - -> Layout aenv aenv + -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables -> (Exp a -> ScopedExp b) -> AST.Fun aenv (a -> b) @@ -765,7 +836,7 @@ convertSharingFun1 config alyt aenv f = Lam (Body openF) convertSharingFun2 :: forall a b c aenv. (Elt a, Elt b, Elt c) => Config - -> Layout aenv aenv + -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables -> (Exp a -> Exp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c) @@ -786,7 +857,7 @@ 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 + -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables -> (stencil -> ScopedExp b) -> AST.Fun aenv (StencilRepr sh stencil -> b) @@ -811,7 +882,7 @@ convertSharingStencilFun2 => 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 + -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables -> (stencil1 -> stencil2 -> ScopedExp c) -> AST.Fun aenv (StencilRepr sh stencil1 -> StencilRepr sh stencil2 -> c) @@ -996,7 +1067,7 @@ lookupWithASTName oc sa@(StableASTName sn) -- 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 :: OccMap SmartAcc -> StableSharingAcc -> Int lookupWithSharingAcc oc (StableSharingAcc (StableNameHeight sn _) _) = lookupWithASTName oc (StableASTName sn) @@ -1008,23 +1079,23 @@ lookupWithSharingExp oc (StableSharingExp (StableNameHeight sn _) _) = lookupWithASTName oc (StableASTName sn) --- Stable 'Acc' nodes +-- Stable 'SmartAcc' nodes -- ------------------ --- Stable name for 'Acc' nodes including the height of the AST. +-- Stable name for 'SmartAcc' nodes including the height of the AST. -- -type StableAccName arrs = StableNameHeight (Acc arrs) +type StableAccName arrs = StableNameHeight (SmartAcc 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 + AvarSharing :: Typeable arrs + => StableAccName arrs -> SharingAcc acc exp arrs + AletSharing :: StableSharingAcc -> acc arrs -> SharingAcc acc exp arrs + AccSharing :: Typeable arrs + => StableAccName arrs -> PreSmartAcc 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 @@ -1038,7 +1109,7 @@ data ScopedAcc t = ScopedAcc [StableSharingAcc] (SharingAcc ScopedAcc ScopedExp -- Stable name for an array computation associated with its sharing-annotated version. -- data StableSharingAcc where - StableSharingAcc :: Arrays arrs + StableSharingAcc :: Typeable arrs => StableAccName arrs -> SharingAcc ScopedAcc ScopedExp arrs -> StableSharingAcc @@ -1094,11 +1165,11 @@ data UnscopedExp t = UnscopedExp [Int] (SharingExp UnscopedAcc UnscopedExp t) -- lambdas. data ScopedExp t = ScopedExp [StableSharingExp] (SharingExp ScopedAcc ScopedExp t) --- Expressions rooted in 'Acc' computations. +-- Expressions rooted in 'SmartAcc' computations. -- --- * When counting occurrences, the root of every expression embedded in an 'Acc' is annotated by +-- * When counting occurrences, the root of every expression embedded in an 'SmartAcc' is annotated by -- an occurrence map for that one expression (excluding any subterms that are rooted in embedded --- 'Acc's.) +-- 'SmartAcc's.) -- data RootExp t = RootExp (OccMap Exp) (UnscopedExp t) @@ -1198,12 +1269,12 @@ matchStableSeq sn1 (StableSharingSeq sn2 _) -- 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). +-- Compute the 'SmartAcc' occurrence map, marks all nodes (both 'Seq' and 'Exp' nodes) with stable names, +-- and drop repeated occurrences of shared 'SmartAcc' 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. +-- We compute a single 'SmartAcc' occurrence map for the whole AST, but one 'Exp' occurrence map for each +-- sub-expression rooted in an 'SmartAcc' operation. This is as we cannot float 'Exp' subtrees across +-- 'SmartAcc' operations, but we can float 'SmartAcc' subtrees out of 'Exp' expressions. -- -- Note [Traversing functions and side effects] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1227,8 +1298,8 @@ makeOccMapAcc :: Typeable arrs => Config -> Level - -> Acc arrs - -> IO (UnscopedAcc arrs, OccMap Acc) + -> SmartAcc arrs + -> IO (UnscopedAcc arrs, OccMap SmartAcc) makeOccMapAcc config lvl acc = do traceLine "makeOccMapAcc" "Enter" accOccMap <- newASTHashTable @@ -1241,9 +1312,9 @@ makeOccMapAcc config lvl acc = do makeOccMapSharingAcc :: Typeable arrs => Config - -> OccMapHash Acc + -> OccMapHash SmartAcc -> Level - -> Acc arrs + -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) makeOccMapSharingAcc config accOccMap = traverseAcc where @@ -1256,7 +1327,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc -> 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 :: (Typeable a, Typeable b) => Level -> (SmartAcc a -> SmartAcc b) -> IO (SmartAcc a -> UnscopedAcc b, Int) traverseAfun1 = makeOccMapAfun1 config accOccMap traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int) @@ -1264,7 +1335,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc traverseBoundary :: Level - -> PreBoundary Acc Exp t + -> PreBoundary SmartAcc Exp t -> IO (PreBoundary UnscopedAcc RootExp t, Int) traverseBoundary lvl bndy = case bndy of @@ -1281,8 +1352,8 @@ makeOccMapSharingAcc config accOccMap = traverseAcc -- -> 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) + traverseAcc :: forall arrs. Typeable arrs => Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) + traverseAcc lvl acc@(SmartAcc pacc) = mfix $ \ ~(_, height) -> do -- Compute stable name and enter it into the occurrence map -- @@ -1303,8 +1374,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc -- 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) + let reconstruct :: IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) -> IO (UnscopedAcc arrs, Int) reconstruct newAcc = case heightIfRepeatedOccurrence of @@ -1315,11 +1385,12 @@ makeOccMapSharingAcc config accOccMap = traverseAcc case pacc of Atag i -> reconstruct $ return (Atag i, 0) -- height is 0! - Pipe afun1 afun2 acc -> reconstruct $ do + Pipe repr1 repr2 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' + return (Pipe repr1 repr2 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 @@ -1327,16 +1398,18 @@ makeOccMapSharingAcc config accOccMap = traverseAcc (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 + Awhile repr 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' + return (Awhile repr pred' iter' init' , h1 `max` h2 `max` h3 + 1) - Atuple tup -> reconstruct $ do - (tup', h) <- travAtup tup - return (Atuple tup', h) + Anil -> reconstruct $ return (Anil, 0) + Apair acc1 acc2 -> reconstruct $ do + (a', h1) <- traverseAcc lvl acc1 + (b', h2) <- traverseAcc lvl acc2 + return (Apair a' b', h1 `max` h2 + 1) Aprj ix a -> reconstruct $ travA (Aprj ix) a Use arr -> reconstruct $ return (Use arr, 1) @@ -1403,17 +1476,17 @@ makeOccMapSharingAcc config accOccMap = traverseAcc where - travA :: Arrays arrs' - => (UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs) - -> Acc arrs' -> IO (PreAcc UnscopedAcc RootExp arrs, Int) + travA :: Typeable arrs' + => (UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> SmartAcc arrs' -> IO (PreSmartAcc 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 :: (Typeable arrs', Typeable b) + => (RootExp b -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> Exp b -> SmartAcc arrs' -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travEA c exp acc = do (exp', h1) <- traverseExp lvl exp @@ -1422,9 +1495,9 @@ makeOccMapSharingAcc config accOccMap = traverseAcc 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) + -> PreSmartAcc UnscopedAcc RootExp arrs) + -> (Exp b -> Exp c -> Exp d) -> SmartAcc arrs' + -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travF2A c fun acc = do (fun', h1) <- traverseFun2 lvl fun @@ -1432,9 +1505,9 @@ makeOccMapSharingAcc config accOccMap = traverseAcc 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) + => ((Exp b -> Exp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> (Exp b -> Exp c -> Exp d) -> Exp e -> SmartAcc arrs' + -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travF2EA c fun exp acc = do (fun', h1) <- traverseFun2 lvl fun @@ -1443,9 +1516,9 @@ makeOccMapSharingAcc config accOccMap = traverseAcc 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) + => ((Exp b -> Exp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreSmartAcc UnscopedAcc RootExp arrs) + -> (Exp b -> Exp c -> Exp d) -> SmartAcc arrs1 -> SmartAcc arrs2 + -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travF2A2 c fun acc1 acc2 = do (fun' , h1) <- traverseFun2 lvl fun @@ -1453,22 +1526,14 @@ makeOccMapSharingAcc config accOccMap = traverseAcc (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) +makeOccMapAfun1 :: (Typeable a, Typeable b) => Config - -> OccMapHash Acc + -> OccMapHash SmartAcc -> Level - -> (Acc a -> Acc b) - -> IO (Acc a -> UnscopedAcc b, Int) + -> (SmartAcc a -> SmartAcc b) + -> IO (SmartAcc a -> UnscopedAcc b, Int) makeOccMapAfun1 config accOccMap lvl f = do - let x = Acc (Atag lvl) + let x = SmartAcc (Atag lvl) -- (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+1) (f x) return (const (UnscopedAcc [lvl] body), height) @@ -1510,7 +1575,7 @@ makeOccMapAfun3 config accOccMap lvl f = do makeOccMapExp :: Typeable e => Config - -> OccMapHash Acc + -> OccMapHash SmartAcc -> Level -> Exp e -> IO (RootExp e, Int) @@ -1519,7 +1584,7 @@ makeOccMapExp config accOccMap lvl = makeOccMapRootExp config accOccMap lvl [] makeOccMapFun1 :: (Elt a, Typeable b) => Config - -> OccMapHash Acc + -> OccMapHash SmartAcc -> Level -> (Exp a -> Exp b) -> IO (Exp a -> RootExp b, Int) @@ -1532,7 +1597,7 @@ makeOccMapFun1 config accOccMap lvl f = do makeOccMapFun2 :: (Elt a, Elt b, Typeable c) => Config - -> OccMapHash Acc + -> OccMapHash SmartAcc -> Level -> (Exp a -> Exp b -> Exp c) -> IO (Exp a -> Exp b -> RootExp c, Int) @@ -1546,8 +1611,8 @@ makeOccMapFun2 config accOccMap lvl f = do makeOccMapStencil1 :: forall sh a b stencil. (Stencil sh a stencil, Typeable b) => Config - -> OccMapHash Acc - -> Acc (Array sh a) {- dummy -} + -> OccMapHash SmartAcc + -> SmartAcc (Array sh a) {- dummy -} -> Level -> (stencil -> Exp b) -> IO (stencil -> RootExp b, Int) @@ -1561,9 +1626,9 @@ makeOccMapStencil1 config accOccMap _ lvl stencil = do 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 -} + -> OccMapHash SmartAcc + -> SmartAcc (Array sh a) {- dummy -} + -> SmartAcc (Array sh b) {- dummy -} -> Level -> (stencil1 -> stencil2 -> Exp c) -> IO (stencil1 -> stencil2 -> RootExp c, Int) @@ -1586,7 +1651,7 @@ makeOccMapStencil2 config accOccMap _ _ lvl stencil = do makeOccMapRootExp :: Typeable e => Config - -> OccMapHash Acc + -> OccMapHash SmartAcc -> Level -- The level of currently bound scalar variables -> [Int] -- The tags of newly introduced free scalar variables in this expression -> Exp e @@ -1605,7 +1670,7 @@ makeOccMapRootExp config accOccMap lvl fvs exp = do makeOccMapSharingExp :: Typeable e => Config - -> OccMapHash Acc + -> OccMapHash SmartAcc -> OccMapHash Exp -> Level -- The level of currently bound variables -> Exp e @@ -1679,7 +1744,7 @@ makeOccMapSharingExp config accOccMap expOccMap = travE Coerce e -> reconstruct $ travE1 Coerce e where - traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int) + traverseAcc :: Typeable arrs => Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) traverseAcc = makeOccMapSharingAcc config accOccMap traverseFun1 :: (Elt a, Typeable b) @@ -1721,7 +1786,7 @@ makeOccMapSharingExp config accOccMap expOccMap = travE (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 + travA :: Typeable b => (UnscopedAcc b -> PreExp UnscopedAcc UnscopedExp a) -> SmartAcc b -> IO (PreExp UnscopedAcc UnscopedExp a, Int) travA c acc = do @@ -1730,7 +1795,7 @@ makeOccMapSharingExp config accOccMap expOccMap = travE travAE :: (Typeable b, Typeable c) => (UnscopedAcc b -> UnscopedExp c -> PreExp UnscopedAcc UnscopedExp a) - -> Acc b -> Exp c + -> SmartAcc b -> Exp c -> IO (PreExp UnscopedAcc UnscopedExp a, Int) travAE c acc e = do @@ -1885,8 +1950,8 @@ makeOccMapSharingSeq config accOccMap seqOccMap = traverseSeq -- - 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. +-- - All 'Exp' node counts precede all 'SmartAcc' node counts as we don't share 'Exp' nodes across 'SmartAcc' +-- nodes. Similarly, all 'Seq' nodes precede 'SmartAcc' 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') @@ -1983,7 +2048,7 @@ nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeNam -- -- * 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 +-- * In the same manner, we assume that all 'Exp' node counts precede 'SmartAcc' 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. @@ -2115,7 +2180,7 @@ determineScopesAcc :: Typeable a => Config -> [Level] - -> OccMap Acc + -> OccMap SmartAcc -> UnscopedAcc a -> (ScopedAcc a, [StableSharingAcc]) determineScopesAcc config fvs accOccMap rootAcc @@ -2129,7 +2194,7 @@ determineScopesAcc config fvs accOccMap rootAcc determineScopesSharingAcc :: Config - -> OccMap Acc + -> OccMap SmartAcc -> UnscopedAcc a -> (ScopedAcc a, NodeCounts) determineScopesSharingAcc config accOccMap = scopesAcc @@ -2144,12 +2209,13 @@ determineScopesSharingAcc config accOccMap = scopesAcc scopesAcc (UnscopedAcc _ (AccSharing sn pacc)) = case pacc of Atag i -> reconstruct (Atag i) noNodeCounts - Pipe afun1 afun2 acc -> let + Pipe repr1 repr2 afun1 afun2 acc + -> let (afun1', accCount1) = scopesAfun1 afun1 (afun2', accCount2) = scopesAfun1 afun2 (acc', accCount3) = scopesAcc acc in - reconstruct (Pipe afun1' afun2' acc') + reconstruct (Pipe repr1 repr2 afun1' afun2' acc') (accCount1 +++ accCount2 +++ accCount3) Aforeign ff afun acc -> let @@ -2164,16 +2230,21 @@ determineScopesSharingAcc config accOccMap = scopesAcc reconstruct (Acond e' acc1' acc2') (accCount1 +++ accCount2 +++ accCount3) - Awhile pred iter init -> let + Awhile repr pred iter init + -> let (pred', accCount1) = scopesAfun1 pred (iter', accCount2) = scopesAfun1 iter (init', accCount3) = scopesAcc init in - reconstruct (Awhile pred' iter' init') + reconstruct (Awhile repr pred' iter' init') (accCount1 +++ accCount2 +++ accCount3) - Atuple tup -> let (tup', accCount) = travAtup tup - in reconstruct (Atuple tup') accCount + Anil -> reconstruct Anil noNodeCounts + Apair a1 a2 -> let + (a1', accCount1) = scopesAcc a1 + (a2', accCount2) = scopesAcc a2 + in + reconstruct (Apair a1' a2') (accCount1 +++ accCount2) Aprj ix a -> travA (Aprj ix) a Use arr -> reconstruct (Use arr) noNodeCounts @@ -2249,7 +2320,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- reconstruct (Collect seq') accCount1 where - travEA :: (ScopedExp e -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs) + travEA :: (ScopedExp e -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) -> RootExp e -> UnscopedAcc arrs' -> (ScopedAcc arrs, NodeCounts) @@ -2260,7 +2331,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc travF2A :: (Elt a, Elt b) => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs' - -> PreAcc ScopedAcc ScopedExp arrs) + -> PreSmartAcc ScopedAcc ScopedExp arrs) -> (Exp a -> Exp b -> RootExp c) -> UnscopedAcc arrs' -> (ScopedAcc arrs, NodeCounts) @@ -2271,7 +2342,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc travF2EA :: (Elt a, Elt b) => ((Exp a -> Exp b -> ScopedExp c) -> ScopedExp e - -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs) + -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) -> (Exp a -> Exp b -> RootExp c) -> RootExp e -> UnscopedAcc arrs' @@ -2284,7 +2355,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc travF2A2 :: (Elt a, Elt b) => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs1 - -> ScopedAcc arrs2 -> PreAcc ScopedAcc ScopedExp arrs) + -> ScopedAcc arrs2 -> PreSmartAcc ScopedAcc ScopedExp arrs) -> (Exp a -> Exp b -> RootExp c) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 @@ -2296,15 +2367,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc (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) + travA :: (ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) -> UnscopedAcc arrs' -> (ScopedAcc arrs, NodeCounts) travA c acc = reconstruct (c acc') accCount @@ -2328,7 +2391,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- In either case, any completed 'NodeCounts' are injected as bindings using 'AletSharing' -- node. -- - reconstruct :: PreAcc ScopedAcc ScopedExp arrs + reconstruct :: PreSmartAcc ScopedAcc ScopedExp arrs -> NodeCounts -> (ScopedAcc arrs, NodeCounts) reconstruct newAcc@(Atag _) _subCount @@ -2400,8 +2463,8 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- 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)) + scopesAfun1 :: (SmartAcc a1 -> UnscopedAcc a2) -> (SmartAcc a1 -> ScopedAcc a2, NodeCounts) + scopesAfun1 f = (const (ScopedAcc ssa body'), (counts', graph)) where body@(UnscopedAcc fvs _) = f undefined (ScopedAcc [] body', (counts,graph)) = scopesAcc body @@ -2467,7 +2530,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc determineScopesExp :: Config - -> OccMap Acc + -> OccMap SmartAcc -> RootExp t -> (ScopedExp t, NodeCounts) -- Root (closed) expression plus Acc node counts determineScopesExp config accOccMap (RootExp expOccMap exp@(UnscopedExp fvs _)) @@ -2483,7 +2546,7 @@ determineScopesExp config accOccMap (RootExp expOccMap exp@(UnscopedExp fvs _)) determineScopesSharingExp :: Config - -> OccMap Acc + -> OccMap SmartAcc -> OccMap Exp -> UnscopedExp t -> (ScopedExp t, NodeCounts) @@ -2859,7 +2922,7 @@ recoverSharingAcc => Config -> Level -- The level of currently bound array variables -> [Level] -- The tags of newly introduced free array variables - -> Acc a + -> SmartAcc a -> (ScopedAcc a, [StableSharingAcc]) recoverSharingAcc config alvl avars acc = let (acc', occMap) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index c56cd30c5..607a09d72 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -30,7 +30,7 @@ module Data.Array.Accelerate.Trafo.Shrink ( -- Shrinking Shrink(..), - ShrinkAcc, shrinkPreAcc, basicReduceAcc, + ShrinkAcc, -- Occurrence counting UsesOfAcc, usesOfPreAcc, usesOfExp, @@ -63,7 +63,6 @@ instance Kit acc => Shrink (PreOpenExp acc env aenv e) where instance Kit acc => Shrink (PreOpenFun acc env aenv f) where shrink' = shrinkFun - -- Shrinking -- ========= @@ -146,6 +145,8 @@ shrinkFun (Body b) = Body <$> shrinkExp b -- 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 @@ -156,21 +157,21 @@ shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrinkA" shrinkA where shrinkA :: PreOpenAcc acc aenv' a -> PreOpenAcc acc aenv' a shrinkA pacc = case pacc of - Alet bnd body + Alet lhs bnd body | Just reduct <- reduceAcc bnd' body' -> shrinkA reduct - | otherwise -> Alet bnd' body' + | otherwise -> Alet lhs 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) + Apair a1 a2 -> Apair (shrinkAcc a1) (shrinkAcc a2) + Anil -> Anil + Apply repr f a -> Apply repr (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 + Use repr a -> Use repr a Unit e -> Unit (shrinkE e) Reshape e a -> Reshape (shrinkE e) (shrinkAcc a) Generate e f -> Generate (shrinkE e) (shrinkF f) @@ -263,41 +264,10 @@ shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrinkA" shrinkA 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 (Alam lhs f) = Alam lhs (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 -- =================== @@ -348,7 +318,6 @@ usesOfExp idx = countE 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. @@ -371,16 +340,16 @@ usesOfPreAcc withShape countAcc idx = count count :: PreOpenAcc acc aenv a -> Int count pacc = case pacc of - Avar this -> countIdx this + Avar (ArrayVar this) -> countIdx this -- - Alet bnd body -> countA bnd + countAcc withShape (SuccIdx idx) body - Atuple tup -> countAT tup - Aprj _ a -> countA a -- special case discount? + Alet lhs bnd body -> countA bnd + countAcc withShape (weakenWithLHS lhs idx) body + Apair a1 a2 -> countA a1 + countA a2 + Anil -> 0 Apply _ a -> countA a Aforeign _ _ a -> countA a Acond p t e -> countE p + countA t + countA e Awhile _ _ a -> countA a - Use _ -> 0 + Use _ _ -> 0 Unit e -> countE e Reshape e a -> countE e + countA a Generate e f -> countE e + countF f @@ -454,10 +423,6 @@ usesOfPreAcc withShape countAcc idx = count 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 = @@ -487,4 +452,3 @@ usesOfPreAcc withShape countAcc idx = count countCT NilAtup = 0 countCT (SnocAtup t c) = countCT t + countC c --} - diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 287cc8d0e..453f62e22 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Substitution @@ -33,7 +34,7 @@ module Data.Array.Accelerate.Trafo.Substitution ( -- ** Rebuilding terms RebuildAcc, Rebuildable(..), RebuildableAcc, - RebuildableExp(..), RebuildTup(..) + RebuildableExp(..), RebuildTup(..), rebuildWeakenVar ) where @@ -42,7 +43,7 @@ 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 Data.Array.Accelerate.Array.Sugar ( Elt, Tuple(..), Array ) import qualified Data.Array.Accelerate.Debug.Stats as Stats @@ -113,9 +114,9 @@ subTop :: Elt t => PreOpenExp acc env aenv s -> Idx (env, s) t -> PreOpenExp acc 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 +subAtop :: PreOpenAcc acc aenv t -> ArrayVar (aenv, t) (Array sh2 e2) -> PreOpenAcc acc aenv (Array sh2 e2) +subAtop t (ArrayVar ZeroIdx ) = t +subAtop _ (ArrayVar (SuccIdx idx)) = Avar $ ArrayVar idx data Identity a = Identity { runIdentity :: a } @@ -136,13 +137,13 @@ class Rebuildable f where type AccClo f :: Type -> Type -> Type rebuildPartial :: (Applicative f', SyntacticAcc fa) - => (forall a'. Arrays a' => Idx aenv a' -> f' (fa (AccClo f) aenv' a')) + => (forall sh e. ArrayVar aenv (Array sh e) -> f' (fa (AccClo f) aenv' (Array sh e))) -> f aenv a -> f' (f aenv' a) {-# INLINEABLE rebuildA #-} rebuildA :: (SyntacticAcc fa) - => (forall a'. Arrays a' => Idx aenv a' -> fa (AccClo f) aenv' a') + => (forall sh e. ArrayVar aenv (Array sh e) -> fa (AccClo f) aenv' (Array sh e)) -> f aenv a -> f aenv' a rebuildA av = runIdentity . rebuildPartial (Identity . av) @@ -224,10 +225,6 @@ instance RebuildableAcc acc => RebuildableExp (PreOpenFun acc) where -- 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 @@ -236,34 +233,47 @@ class Sink f where -- -- {-# INLINEABLE weaken #-} -- default weaken :: Rebuildable f => env :> env' -> f env t -> f env' t - -- weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) + -- weaken k = Stats.substitution "weaken" . rebuildA rebuildWeakenVar --instance Rebuildable f => Sink f where -- undecidable, incoherent --- weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) +-- weaken k = Stats.substitution "weaken" . rebuildA rebuildWeakenVar instance Sink Idx where {-# INLINEABLE weaken #-} weaken k = k +instance Sink ArrayVar where + {-# INLINEABLE weaken #-} + weaken k (ArrayVar ix) = ArrayVar (k ix) + +instance Sink ArrayVars where + {-# INLINEABLE weaken #-} + weaken _ ArrayVarsNil = ArrayVarsNil + weaken k (ArrayVarsArray v) = ArrayVarsArray $ weaken k v + weaken k (ArrayVarsPair v w) = ArrayVarsPair (weaken k v) (weaken k w) + +rebuildWeakenVar :: env :> env' -> ArrayVar env (Array sh e) -> PreOpenAcc acc env' (Array sh e) +rebuildWeakenVar k (ArrayVar idx) = Avar $ ArrayVar $ k idx + instance RebuildableAcc acc => Sink (PreOpenAcc acc) where {-# INLINEABLE weaken #-} - weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) + weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) instance RebuildableAcc acc => Sink (PreOpenAfun acc) where {-# INLINEABLE weaken #-} - weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) + weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) instance RebuildableAcc acc => Sink (PreOpenExp acc env) where {-# INLINEABLE weaken #-} - weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) + weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) instance RebuildableAcc acc => Sink (PreOpenFun acc env) where {-# INLINEABLE weaken #-} - weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) + weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) instance RebuildableAcc acc => Sink (RebuildTup acc env) where {-# INLINEABLE weaken #-} - weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) + weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) instance RebuildableAcc acc => Sink (PreBoundary acc) where {-# INLINEABLE weaken #-} @@ -277,7 +287,7 @@ instance RebuildableAcc acc => Sink (PreBoundary acc) where instance Sink OpenAcc where {-# INLINEABLE weaken #-} - weaken k = Stats.substitution "weaken" . rebuildA (Avar . k) + weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar 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. @@ -321,8 +331,8 @@ instance RebuildableAcc acc => SinkExp (PreOpenFun acc) where 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 x = Stats.substitution "strengthen" $ rebuildPartial (fmap IA . k) x +strengthen :: forall f env env' t. Rebuildable f => env :?> env' -> f env t -> Maybe (f env' t) +strengthen k x = Stats.substitution "strengthen" $ rebuildPartial @f @Maybe @IdxA (\(ArrayVar idx) -> fmap (IA . ArrayVar) $ k idx) x -- (\(ArrayVar idx) -> fmap (IA . ArrayVar) $ k idx) {-# INLINEABLE strengthenE #-} strengthenE :: RebuildableExp f => env :?> env' -> f env aenv t -> Maybe (f env' aenv t) @@ -372,7 +382,7 @@ 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')) + -> RebuildAvar f fa acc aenv aenv' -> PreOpenExp acc env aenv t -> f (PreOpenExp acc env' aenv' t) rebuildPreOpenExp k v av exp = @@ -410,7 +420,7 @@ 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')) + -> RebuildAvar f fa acc aenv aenv' -> Tuple (PreOpenExp acc env aenv) t -> f (Tuple (PreOpenExp acc env' aenv') t) rebuildTup k v av tup = @@ -423,7 +433,7 @@ 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')) + -> RebuildAvar f fa acc aenv aenv' -> PreOpenFun acc env aenv t -> f (PreOpenFun acc env' aenv' t) rebuildFun k v av fun = @@ -436,41 +446,56 @@ rebuildFun k v av fun = 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 + => RebuildAvar f fa acc aenv aenv' + -> 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 :: Type -> Type -> Type) aenv t = IA { unIA :: ArrayVar aenv t } -newtype IdxA (acc :: Type -> Type -> Type) aenv t = IA { unIA :: Idx aenv t } +class SyntacticAcc f where + avarIn :: ArrayVar aenv (Array sh e) -> f acc aenv (Array sh e) + accOut :: f acc aenv (Array sh e) -> PreOpenAcc acc aenv (Array sh e) + weakenAcc :: RebuildAcc acc -> f acc aenv (Array sh e) -> f acc (aenv, s) (Array sh e) instance SyntacticAcc IdxA where - avarIn = IA - accOut = Avar . unIA - weakenAcc _ = IA . SuccIdx . unIA + avarIn = IA + accOut = Avar . unIA + weakenAcc _ (IA (ArrayVar idx)) = IA $ ArrayVar $ SuccIdx idx instance SyntacticAcc PreOpenAcc where avarIn = Avar accOut = id weakenAcc k = runIdentity . rebuildPreOpenAcc k (Identity . weakenAcc k . IA) +type RebuildAvar f (fa :: (* -> * -> *) -> * -> * -> *) acc aenv aenv' = + forall sh e. ArrayVar aenv (Array sh e) -> f (fa acc aenv' (Array sh e)) + {-# INLINEABLE shiftA #-} shiftA - :: (Applicative f, SyntacticAcc fa, Arrays t) + :: (Applicative f, SyntacticAcc fa) => 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 + -> RebuildAvar f fa acc aenv aenv' + -> ArrayVar (aenv, s) (Array sh e) + -> f (fa acc (aenv', s) (Array sh e)) +shiftA _ _ (ArrayVar ZeroIdx) = pure $ avarIn $ ArrayVar ZeroIdx +shiftA k v (ArrayVar (SuccIdx ix)) = weakenAcc k <$> v (ArrayVar ix) + +shiftA' + :: (Applicative f, SyntacticAcc fa) + => LeftHandSide t aenv1 aenv1' + -> LeftHandSide t aenv2 aenv2' + -> RebuildAcc acc + -> RebuildAvar f fa acc aenv1 aenv2 + -> RebuildAvar f fa acc aenv1' aenv2' +shiftA' (LeftHandSideWildcard _) (LeftHandSideWildcard _) _ v = v +shiftA' LeftHandSideArray LeftHandSideArray k v = shiftA k v +shiftA' (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k v = shiftA' b1 b2 k $ shiftA' a1 a2 k v +shiftA' _ _ _ _ = error "Substitution: left hand sides do not match" {-# INLINEABLE rebuildOpenAcc #-} rebuildOpenAcc :: (Applicative f, SyntacticAcc fa) - => (forall t'. Arrays t' => Idx aenv t' -> f (fa OpenAcc aenv' t')) + => (forall sh e. ArrayVar aenv (Array sh e) -> f (fa OpenAcc aenv' (Array sh e))) -> OpenAcc aenv t -> f (OpenAcc aenv' t) rebuildOpenAcc av (OpenAcc acc) = OpenAcc <$> rebuildPreOpenAcc rebuildOpenAcc av acc @@ -479,16 +504,16 @@ rebuildOpenAcc av (OpenAcc acc) = OpenAcc <$> rebuildPreOpenAcc rebuildOpenAcc a rebuildPreOpenAcc :: (Applicative f, SyntacticAcc fa) => RebuildAcc acc - -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t')) + -> RebuildAvar f fa acc aenv aenv' -> 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 + Use repr a -> pure (Use repr a) + Alet lhs a b -> rebuildAlet k av lhs a b Avar ix -> accOut <$> av ix - Atuple tup -> Atuple <$> rebuildAtup k av tup - Aprj tup a -> Aprj tup <$> k av a + Apair as bs -> Apair <$> k av as <*> k av bs + Anil -> pure Anil 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 @@ -521,31 +546,39 @@ rebuildPreOpenAcc k av acc = rebuildAfun :: (Applicative f, SyntacticAcc fa) => RebuildAcc acc - -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t')) + -> RebuildAvar f fa acc aenv aenv' -> 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 + Abody b -> Abody <$> k av b + Alam lhs1 f -> case rebuildLHS lhs1 of + Exists lhs2 -> Alam lhs2 <$> rebuildAfun k (shiftA' lhs1 lhs2 k av) f -{-# INLINEABLE rebuildAtup #-} -rebuildAtup - :: (Applicative f, SyntacticAcc fa) +rebuildAlet + :: forall f fa acc aenv1 aenv1' aenv2 bndArrs arrs. (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 + -> RebuildAvar f fa acc aenv1 aenv2 + -> LeftHandSide bndArrs aenv1 aenv1' + -> acc aenv1 bndArrs + -> acc aenv1' arrs + -> f (PreOpenAcc acc aenv2 arrs) +rebuildAlet k av lhs1 bind1 body1 = case rebuildLHS lhs1 of + Exists lhs2 -> Alet lhs2 <$> k av bind1 <*> k (shiftA' lhs1 lhs2 k av) body1 + +{-# INLINEABLE rebuildLHS #-} +rebuildLHS :: LeftHandSide arr aenv1 aenv1' -> Exists (LeftHandSide arr aenv2) +rebuildLHS (LeftHandSideWildcard r) = Exists $ LeftHandSideWildcard r +rebuildLHS LeftHandSideArray = Exists $ LeftHandSideArray +rebuildLHS (LeftHandSidePair as bs) = case rebuildLHS as of + Exists as' -> case rebuildLHS bs of + Exists bs' -> Exists $ LeftHandSidePair as' bs' {-# INLINEABLE rebuildBoundary #-} rebuildBoundary :: (Applicative f, SyntacticAcc fa) => RebuildAcc acc - -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t')) + -> RebuildAvar f fa acc aenv aenv' -> PreBoundary acc aenv t -> f (PreBoundary acc aenv' t) rebuildBoundary k av bndy = @@ -561,7 +594,7 @@ rebuildBoundary k av bndy = rebuildSeq :: (SyntacticAcc fa, Applicative f) => RebuildAcc acc - -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t')) + -> RebuildAvar f fa acc aenv aenv' -> PreOpenSeq acc aenv senv t -> f (PreOpenSeq acc aenv' senv t) rebuildSeq k v seq = @@ -573,7 +606,7 @@ rebuildSeq k v seq = {-# INLINEABLE rebuildP #-} rebuildP :: (SyntacticAcc fa, Applicative f) => RebuildAcc acc - -> (forall t'. Arrays t' => Idx aenv t' -> f (fa acc aenv' t')) + -> RebuildAvar f fa acc aenv aenv' -> Producer acc aenv senv a -> f (Producer acc aenv' senv a) rebuildP k v p = @@ -588,7 +621,7 @@ rebuildP k v p = {-# 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')) + -> RebuildAvar f fa acc aenv aenv' -> Consumer acc aenv senv a -> f (Consumer acc aenv' senv a) rebuildC k v c = From 14f14959c84e4365323ba6aad986f7c60139a216 Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Thu, 7 Nov 2019 12:09:02 +0100 Subject: [PATCH 100/316] Mark nofib test as non-buildable if flag is missing --- accelerate.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/accelerate.cabal b/accelerate.cabal index fb4dcb6e4..8b3751055 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -562,6 +562,9 @@ test-suite nofib-interpreter hs-source-dirs: test/nofib main-is: Main.hs + if !flag(nofib) + buildable: False + build-depends: base >= 4.9 , accelerate From 79c073ea8c8bbed41ebbd2a32ca8c551ca459f02 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Thu, 7 Nov 2019 12:57:51 +0100 Subject: [PATCH 101/316] Reimplement patterns of Acc tuples --- src/Data/Array/Accelerate/Pattern.hs | 74 ++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index d29dbceb2..1083ea990 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -307,3 +307,77 @@ $(runQ $ do return $ concat es ) +-- IsPattern instances for Acc +instance (Arrays a, Arrays b) => IsPattern Acc (a, b) (Acc a, Acc b) where + construct = atup2 + destruct = unatup2 + +instance (Arrays a, Arrays b, Arrays c) + => IsPattern Acc (a, b, c) (Acc a, Acc b, Acc c) where + construct = atup3 + destruct = unatup3 + +instance (Arrays a, Arrays b, Arrays c, Arrays d) + => IsPattern Acc (a, b, c, d) (Acc a, Acc b, Acc c, Acc d) where + construct = atup4 + destruct = unatup4 + +instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) + => IsPattern Acc (a, b, c, d, e) (Acc a, Acc b, Acc c, Acc d, Acc e) where + construct = atup5 + destruct = unatup5 + +instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f) + => IsPattern Acc (a, b, c, d, e, f) (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) where + construct = atup6 + destruct = unatup6 + +instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g) + => IsPattern Acc (a, b, c, d, e, f, g) (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) where + construct = atup7 + destruct = unatup7 + +instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h) + => IsPattern 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) where + construct = atup8 + destruct = unatup8 + +instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i) + => IsPattern 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) where + construct = atup9 + destruct = unatup9 + +instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j) + => IsPattern 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) where + construct = atup10 + destruct = unatup10 + +instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k) + => IsPattern 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) where + construct = atup11 + destruct = unatup11 + +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) + => IsPattern 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) where + construct = atup12 + destruct = unatup12 + +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) + => IsPattern 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) where + construct = atup13 + destruct = unatup13 + +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) + => IsPattern 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) where + construct = atup14 + destruct = unatup14 + +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) + => IsPattern 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) where + construct = atup15 + destruct = unatup15 + +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) + => IsPattern 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) where + construct = atup16 + destruct = unatup16 From 529ae8f3152f38db8ebb9af6e9f29206997de7d7 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 8 Nov 2019 10:59:24 +0100 Subject: [PATCH 102/316] Fix infinite loop, remove duplicate function --- src/Data/Array/Accelerate/Trafo/Base.hs | 11 +++-------- src/Data/Array/Accelerate/Trafo/Fusion.hs | 2 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 6 +++--- 3 files changed, 7 insertions(+), 12 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index d2dd72f88..c16ca3961 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -51,7 +51,7 @@ module Data.Array.Accelerate.Trafo.Base ( leftHandSideChangeEnv, -- Adding new variables to the environment - declareArrays, DeclareArrays(..), compileVars, + declareArrays, DeclareArrays(..), aletBodyIsTrivial, ) where @@ -400,8 +400,8 @@ pushArrayEnv env a = PushEnv env LeftHandSideArray 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 lhs as a) = x `append` PushEnv lhs as a +append x BaseEnv = x +append x (PushEnv e lhs a) = PushEnv (append x e) lhs 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). @@ -464,11 +464,6 @@ leftHandSideChangeEnv (LeftHandSidePair l1 l2) = case leftHandSideChangeEnv l Exists l1' -> case leftHandSideChangeEnv l2 of Exists l2' -> Exists $ LeftHandSidePair l1' l2' -compileVars :: ArrayVars env t -> OpenAcc env t -compileVars ArrayVarsNil = OpenAcc Anil -compileVars (ArrayVarsArray ix@ArrayVar{}) = OpenAcc $ Avar ix -compileVars (ArrayVarsPair v1 v2) = OpenAcc $ compileVars v1 `Apair` compileVars v2 - aletBodyIsTrivial :: forall acc aenv aenv' a b. Kit acc => LeftHandSide a aenv aenv' -> acc aenv' b -> Maybe (a :~: b) aletBodyIsTrivial lhs rhs = case extractArrayVars rhs of Just vars -> case declareArrays @a @aenv (lhsToArraysR lhs) of diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 6f5ba689b..978709bbb 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -1307,7 +1307,7 @@ aletD embedAcc elimAcc lhs (embedAcc -> Embed env1 cc1) acc0 -- that must be later eliminated by shrinking. -- | LeftHandSideArray <- lhs - , Done (ArrayVarsArray v1@ArrayVar{}) <- cc1 + , Done (ArrayVarsArray v1@ArrayVar{}) <- cc1 , Embed env0 cc0 <- embedAcc $ rebuildA (subAtop (Avar v1) . sink1 env1) acc0 = Stats.ruleFired "aletD/float" $ Embed (env1 `append` env0) cc0 diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 37db5831c..cefde4a45 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -131,7 +131,7 @@ prjArrayIdx context = go go :: forall env env' t. Typeable t => Int -> ArrayLayout env env' -> AST.OpenAcc env t go _ ArrayEmptyLayout = no "environment does not contain index" go 0 (ArrayPushLayout _ _ (ix :: ArrayVars env0 s)) - | Just ix' <- gcast ix = compileVars ix' + | Just ix' <- gcast ix = avarsIn ix' | otherwise = no $ printf "couldn't match expected type `%s' with actual type `%s'" (show (typeOf (undefined::t))) (show (typeOf (undefined::s))) @@ -314,7 +314,7 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) cvtAprj' PairIdxRight (AST.OpenAcc (AST.Apair _ b)) = b cvtAprj' ix a = case declareArrays $ arraysRepr a of DeclareArrays lhs _ value -> - AST.OpenAcc $ AST.Alet lhs a $ cvtAprj' ix $ compileVars $ value id + AST.OpenAcc $ AST.Alet lhs a $ cvtAprj' ix $ avarsIn $ value id in case preAcc of @@ -333,7 +333,7 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) alyt' = ArrayPushLayout (incArrayLayoutWith k alyt) lhs (value id) bodyAcc = AST.Apply (convertSharingAfun1 config alyt' (noStableSharing : aenv') reprB afun2) - (compileVars $ value id) + (avarsIn $ value id) in AST.Alet lhs (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) Aforeign ff afun acc From 25ea4be56a76db1ce8d3e33f50b06c9abea29aea Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Mon, 11 Nov 2019 16:21:34 +0100 Subject: [PATCH 103/316] Change Use to only contain a single array Use Apair and Anil to build a structure of arrays --- src/Data/Array/Accelerate/AST.hs | 34 +++++-------------- src/Data/Array/Accelerate/Analysis/Hash.hs | 8 ++--- src/Data/Array/Accelerate/Analysis/Match.hs | 19 ++++------- src/Data/Array/Accelerate/Interpreter.hs | 2 +- src/Data/Array/Accelerate/Language.hs | 20 +++++++++-- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 2 +- src/Data/Array/Accelerate/Pretty/Print.hs | 12 ++----- src/Data/Array/Accelerate/Smart.hs | 21 +++--------- src/Data/Array/Accelerate/Trafo/Fusion.hs | 6 ++-- src/Data/Array/Accelerate/Trafo/Sharing.hs | 2 +- src/Data/Array/Accelerate/Trafo/Shrink.hs | 2 +- .../Array/Accelerate/Trafo/Substitution.hs | 2 +- 12 files changed, 49 insertions(+), 81 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 7bbed7359..dd5363e7a 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -108,7 +108,7 @@ module Data.Array.Accelerate.AST ( -- TemplateHaskell LiftAcc, - liftIdx, liftTupleIdx, liftArrays, + liftIdx, liftTupleIdx, liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp, @@ -123,7 +123,6 @@ module Data.Array.Accelerate.AST ( --standard library import Control.DeepSeq import Control.Monad.ST -import Data.List import Data.Typeable import Foreign.ForeignPtr import Foreign.Marshal @@ -369,9 +368,9 @@ data PreOpenAcc acc aenv a where -- Array inlet. Triggers (possibly) asynchronous host->device transfer if -- necessary. -- - Use :: ArraysR arrs - -> arrs - -> PreOpenAcc acc aenv arrs + Use :: (Shape sh, Elt e) + => Array sh e + -> PreOpenAcc acc aenv (Array sh e) -- Capture a scalar (or a tuple of scalars) in a singleton array -- @@ -859,7 +858,7 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr (Acond _ whenTrue _) = arraysRepr whenTrue arraysRepr (Awhile _ (Alam lhs _) _) = lhsToArraysR lhs arraysRepr (Awhile _ _ _) = error "I want my, I want my MTV!" - arraysRepr (Use repr _) = repr + arraysRepr Use{} = ArraysRarray arraysRepr Unit{} = ArraysRarray arraysRepr Reshape{} = ArraysRarray arraysRepr Generate{} = ArraysRarray @@ -1246,7 +1245,7 @@ rnfPreOpenAcc rnfA pacc = 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 repr arrs -> rnfArrays repr arrs + Use arr -> rnf arr Unit x -> rnfE x Reshape sh a -> rnfE sh `seq` rnfA a Generate sh f -> rnfE sh `seq` rnfF f @@ -1580,7 +1579,7 @@ liftPreOpenAcc liftA pacc = 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 repr a -> [|| Use $$(liftArraysR repr) $$(liftArrays repr a) ||] + Use a -> [|| Use $$(liftArray a) ||] Unit e -> [|| Unit $$(liftE e) ||] Reshape sh a -> [|| Reshape $$(liftE sh) $$(liftA a) ||] Generate sh f -> [|| Generate $$(liftE sh) $$(liftF f) ||] @@ -1668,11 +1667,6 @@ liftPreOpenExp liftA pexp = 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. (Shape sh, Elt e) => Array sh e -> Q (TExp (Array sh e)) liftArray (Array sh adata) = [|| Array $$(liftConst (eltType @sh) sh) $$(go arrayElt adata) ||] `sigE` typeRepToType (typeOf (undefined::Array sh e)) @@ -1935,7 +1929,7 @@ liftSingleType (NonNumSingleType t) = [|| NonNumSingleType $$(liftNonNumType t) showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String showPreAccOp Alet{} = "Alet" showPreAccOp (Avar (ArrayVar ix)) = "Avar a" ++ show (idxToInt ix) -showPreAccOp (Use repr a) = "Use " ++ showArrays repr a +showPreAccOp (Use a) = "Use " ++ showShortendArr a showPreAccOp Apply{} = "Apply" showPreAccOp Aforeign{} = "Aforeign" showPreAccOp Acond{} = "Acond" @@ -1966,18 +1960,6 @@ showPreAccOp Stencil{} = "Stencil" showPreAccOp Stencil2{} = "Stencil2" -- showPreAccOp Collect{} = "Collect" -showArrays :: forall arrs. ArraysR arrs -> arrs -> String -showArrays repr = display . collect repr - 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 :: (Shape sh, Elt e) => Array sh e -> String showShortendArr arr diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 3428f8f62..ac3f29f25 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -166,7 +166,7 @@ encodePreOpenAcc options encodeAcc pacc = Anil -> intHost $(hashQ "Anil") Apply f a -> intHost $(hashQ "Apply") <> travAF f <> travA a Aforeign _ f a -> intHost $(hashQ "Aforeign") <> travAF f <> travA a - Use repr a -> intHost $(hashQ "Use") <> deep (encodeArrays repr a) + Use a -> intHost $(hashQ "Use") <> deep (encodeArray a) Awhile p f a -> intHost $(hashQ "Awhile") <> travAF f <> travAF p <> travA a Unit e -> intHost $(hashQ "Unit") <> travE e Generate e f -> intHost $(hashQ "Generate") <> deep (travE e) <> travF f @@ -244,10 +244,8 @@ encodeIdx = intHost . idxToInt encodeTupleIdx :: TupleIdx tup e -> Builder encodeTupleIdx = intHost . tupleIdxToInt -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 +encodeArray :: (Shape sh, Elt e) => Array sh e -> Builder +encodeArray ad = intHost . unsafePerformIO $! hashStableName <$> makeStableName ad encodeArraysType :: forall a. ArraysR a -> Builder encodeArraysType ArraysRunit = intHost $(hashQ "ArraysRunit") diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index 5f0621f9f..ecbae8dde 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -119,8 +119,8 @@ matchPreOpenAcc matchAcc encodeAcc = match , Just Refl <- matchPreOpenAfun matchAcc f1 f2 = Just Refl - match (Use repr1 a1) (Use repr2 a2) - | Just Refl <- matchArrays repr1 repr2 a1 a2 + match (Use a1) (Use a2) + | Just Refl <- matchArray a1 a2 = Just Refl match (Unit e1) (Unit e2) @@ -401,23 +401,16 @@ matchSeq m h = match -- 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) +matchArray :: (Shape sh1, Elt e1, Shape sh2, Elt e2) + => Array sh1 e1 -> Array sh2 e2 -> Maybe (Array sh1 e1 :~: Array sh2 e2) +matchArray (Array _ ad1) (Array _ ad2) | unsafePerformIO $ do sn1 <- makeStableName ad1 sn2 <- makeStableName ad2 return $! hashStableName sn1 == hashStableName sn2 = gcast Refl -matchArrays _ _ _ _ +matchArray _ _ = Nothing matchArraysR :: ArraysR s -> ArraysR t -> Maybe (s :~: t) diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 55f253201..e75d0c357 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -214,7 +214,7 @@ evalOpenAcc (AST.Manifest pacc) aenv = | p x ! Z = go (f x) | otherwise = x - Use _ arr -> arr + Use arr -> arr Unit e -> unitOp (evalE e) -- Collect s -> evalSeq defaultSeqConfig s aenv diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 946257a6e..14ece2974 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -120,6 +121,7 @@ import Data.Array.Accelerate.Classes.Ord -- standard libraries import Prelude ( ($), (.) ) +import Data.Typeable -- $setup -- >>> :seti -XFlexibleContexts @@ -161,8 +163,22 @@ import Prelude ( ($), (.) ) -- >>> 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 . SmartAcc . Use +use :: forall arrays. Arrays arrays => arrays -> Acc arrays +use arrs = Acc acc + where + HasTypeable acc = use' (arrays @arrays) $ fromArr arrs + + use' :: ArraysR a -> a -> HasTypeable a + use' ArraysRunit () = HasTypeable $ SmartAcc $ Anil + use' ArraysRarray a = HasTypeable $ SmartAcc $ Use a + use' (ArraysRpair r1 r2) (a1, a2) + | HasTypeable acc1 <- use' r1 a1 + , HasTypeable acc2 <- use' r2 a2 = HasTypeable $ SmartAcc $ acc1 `Apair` acc2 + +-- Internal data type for 'use' to capture the 'Typeable' type class +data HasTypeable a where + HasTypeable :: Typeable a => SmartAcc a -> HasTypeable a + -- | Construct a singleton (one element) array from a scalar value (or tuple of -- scalar values). diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index a0420bfb6..8a1123651 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -227,7 +227,7 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = Anil -> "()" .$ [] - Use repr arrs -> "use" .$ [ return $ PDoc (prettyArrays repr arrs) [] ] + Use arr -> "use" .$ [ return $ PDoc (prettyArray arr) [] ] Unit e -> "unit" .$ [ ppE e ] Generate sh f -> "generate" .$ [ ppE sh, ppF f ] Transform sh ix f xs -> "transform" .$ [ ppE sh, ppF ix, ppF f, ppA xs ] diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index a5e12e1a3..f28b226fb 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -27,7 +27,7 @@ module Data.Array.Accelerate.Pretty.Print ( prettyPreOpenAfun, prettyPreOpenExp, prettyPreOpenFun, - prettyArrays, + prettyArray, prettyConst, -- ** Internals @@ -150,7 +150,7 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = Aforeign ff _f a -> "aforeign" .$ [ pretty (strForeign ff), ppA a ] Awhile p f a -> "awhile" .$ [ ppAF p, ppAF f, ppA a ] - Use repr arrs -> "use" .$ [ prettyArrays repr arrs ] + Use arr -> "use" .$ [ prettyArray arr ] Unit e -> "unit" .$ [ ppE e ] Reshape sh a -> "reshape" .$ [ ppE sh, ppA a ] Generate sh f -> "generate" .$ [ ppE sh, ppF f ] @@ -255,14 +255,6 @@ prettyLHS aenv (LeftHandSidePair a b) = (aenv2, "(" <> doc1 <> ", " <> doc2 <> " (aenv1, doc1) = prettyLHS aenv a (aenv2, doc2) = prettyLHS aenv1 b -prettyArrays :: ArraysR arrs -> arrs -> Adoc -prettyArrays arrs = tupled . collect arrs - where - collect :: ArraysR arrs -> arrs -> [Adoc] - collect ArraysRunit _ = [] - collect ArraysRarray arr = [prettyArray arr] - collect (ArraysRpair r1 r2) (a1, a2) = collect r1 a1 ++ collect r2 a2 - prettyArray :: (Shape sh, Elt e) => Array sh e -> Adoc prettyArray = viaShow diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 358868eba..942373136 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -74,7 +74,6 @@ module Data.Array.Accelerate.Smart ( -- standard library import Prelude hiding ( exp ) import Data.Kind -import Data.List import Data.Typeable -- friends @@ -331,9 +330,9 @@ data PreSmartAcc acc exp as where -> acc (arrs1, arrs2) -> PreSmartAcc acc exp arrs - Use :: (Arrays arrs, Typeable (ArrRepr arrs)) - => arrs - -> PreSmartAcc acc exp (ArrRepr arrs) + Use :: (Shape sh, Elt e) + => Array sh e + -> PreSmartAcc acc exp (Array sh e) Unit :: Elt e => exp e @@ -2352,7 +2351,7 @@ instance (Arrays a, Arrays b, ApplyAcc t) => ApplyAcc ((Acc a -> Acc b) -> t) wh showPreAccOp :: forall acc exp arrs. PreSmartAcc acc exp arrs -> String showPreAccOp (Atag i) = "Atag " ++ show i -showPreAccOp (Use a) = "Use " ++ showArrays a +showPreAccOp (Use a) = "Use " ++ showShortendArr a showPreAccOp Pipe{} = "Pipe" showPreAccOp Acond{} = "Acond" showPreAccOp Awhile{} = "Awhile" @@ -2395,18 +2394,6 @@ showPreSeqOp (FoldSeqFlatten{}) = "FoldSeqFlatten" showPreSeqOp (Stuple{}) = "Stuple" --} -showArrays :: forall arrs. Arrays arrs => arrs -> String -showArrays = display . collect (arrays @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 :: (Shape sh, Elt e) => Array sh e -> String showShortendArr arr diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 978709bbb..38a0d7404 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -161,7 +161,7 @@ manifest config (OpenAcc pacc) = -- Non-fusible terms -- ----------------- Avar ix -> Avar ix - Use repr arr -> Use repr arr + Use arr -> Use arr Unit e -> Unit (cvtE e) Alet lhs bnd body -> alet lhs (manifest config bnd) (manifest config body) Acond p t e -> Acond (cvtE p) (manifest config t) (manifest config e) @@ -419,7 +419,7 @@ embedPreAcc config embedAcc elimAcc pacc -- Array injection Avar v -> done $ Avar v - Use repr arrs -> done $ Use repr arrs + Use arrs -> done $ Use arrs Unit e -> done $ Unit (cvtE e) -- Producers @@ -1473,7 +1473,7 @@ aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) in Alet lhs (cvtA bnd) (kmap (replaceA sh'' f'' (weaken w avar)) body) - Use repr arrs -> Use repr arrs + Use arrs -> Use arrs Unit e -> Unit (cvtE e) Acond p at ae -> Acond (cvtE p) (cvtA at) (cvtA ae) Anil -> Anil diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index cefde4a45..7e4cdc048 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -345,7 +345,7 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) Apair acc1 acc2 -> AST.Apair (cvtA acc1) (cvtA acc2) Aprj ix a -> let AST.OpenAcc a' = cvtAprj ix a in a' - Use (array :: a) -> AST.Use (arrays @a) (fromArr array) + Use array -> AST.Use 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) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 607a09d72..0dfa875b9 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -349,7 +349,7 @@ usesOfPreAcc withShape countAcc idx = count Aforeign _ _ a -> countA a Acond p t e -> countE p + countA t + countA e Awhile _ _ a -> countA a - Use _ _ -> 0 + Use _ -> 0 Unit e -> countE e Reshape e a -> countE e + countA a Generate e f -> countE e + countF f diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 453f62e22..336859925 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -509,7 +509,7 @@ rebuildPreOpenAcc -> f (PreOpenAcc acc aenv' t) rebuildPreOpenAcc k av acc = case acc of - Use repr a -> pure (Use repr a) + Use a -> pure (Use a) Alet lhs a b -> rebuildAlet k av lhs a b Avar ix -> accOut <$> av ix Apair as bs -> Apair <$> k av as <*> k av bs From 52ee6eadc0f4f75de8c6e16cf2e611a8f94fd8f1 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Tue, 12 Nov 2019 22:46:41 +0100 Subject: [PATCH 104/316] Export liftLHS & liftArray for accelerate-llvm --- src/Data/Array/Accelerate/AST.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index dd5363e7a..a0c4004f3 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -111,6 +111,7 @@ module Data.Array.Accelerate.AST ( liftIdx, liftTupleIdx, liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp, + liftLHS, liftArray, -- Utilities Exists(..), weakenWithLHS, (:>), From e63ddbc990c954c4a47290d3401f511bff7d5ee8 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 15 Nov 2019 16:07:19 +0100 Subject: [PATCH 105/316] Move comments to correct flags --- src/Data/Array/Accelerate/Debug/Flags.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index a1e5dd6fc..0bc6eb2a1 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -180,10 +180,10 @@ exp_sharing = Flag 2 -- recover sharing of scalar expressions array_fusion = Flag 3 -- fuse array expressions simplify = Flag 4 -- simplify scalar expressions inplace = Flag 5 -- allow (safe) in-place array updates -fast_math = Flag 6 -- delete persistent compilation cache(s) +fast_math = Flag 6 -- use faster, less precise math library operations fast_permute_const = Flag 7 -- allow non-atomic permute const for product types -flush_cache = Flag 8 -- force recompilation of array programs -force_recomp = Flag 9 -- use faster, less precise math library operations +flush_cache = Flag 8 -- delete persistent compilation cache(s) +force_recomp = Flag 9 -- force recompilation of array programs -- These debugging flags are disable by default and are enabled with @-d@ -- From 8d86d6e9691efb2ad5917d9160ffb9e184615ed6 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 20 Nov 2019 12:45:40 +0100 Subject: [PATCH 106/316] Disable non-deep hashing, add array type hash This fixes some failing test cases --- src/Data/Array/Accelerate/Analysis/Hash.hs | 35 +++++++++++----------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index ac3f29f25..da2cb1e5b 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -156,8 +156,12 @@ encodePreOpenAcc options encodeAcc pacc = travB = encodePreBoundary options encodeAcc deep :: Builder -> Builder - deep x | perfect options = x - | otherwise = mempty + -- deep x | perfect options = x + -- | otherwise = mempty + deep = id + + arrayHash :: (Shape sh, Elt e, arrs ~ Array sh e) => Builder + arrayHash = encodeArrayType @arrs in case pacc of Alet lhs bnd body -> intHost $(hashQ "Alet") <> encodeLeftHandSide lhs <> travA bnd <> travA body @@ -166,18 +170,18 @@ encodePreOpenAcc options encodeAcc pacc = Anil -> intHost $(hashQ "Anil") Apply f a -> intHost $(hashQ "Apply") <> travAF f <> travA a Aforeign _ f a -> intHost $(hashQ "Aforeign") <> travAF f <> travA a - Use a -> intHost $(hashQ "Use") <> deep (encodeArray a) + Use a -> intHost $(hashQ "Use") <> arrayHash <> deep (encodeArray a) Awhile p f a -> intHost $(hashQ "Awhile") <> travAF f <> travAF p <> travA a Unit e -> intHost $(hashQ "Unit") <> travE e - Generate e f -> intHost $(hashQ "Generate") <> deep (travE e) <> travF f + Generate e f -> intHost $(hashQ "Generate") <> arrayHash <> deep (travE e) <> travF f Acond e a1 a2 -> intHost $(hashQ "Acond") <> deep (travE e) <> travA a1 <> travA a2 - Reshape sh a -> intHost $(hashQ "Reshape") <> deep (travE sh) <> travA a - Backpermute sh f a -> intHost $(hashQ "Backpermute") <> deep (travE sh) <> travF f <> travA a - Transform sh f1 f2 a -> intHost $(hashQ "Transform") <> deep (travE sh) <> travF f1 <> travF f2 <> travA a - Replicate spec ix a -> intHost $(hashQ "Replicate") <> deep (travE ix) <> travA a <> encodeSliceIndex spec - Slice spec a ix -> intHost $(hashQ "Slice") <> deep (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 + Reshape sh a -> intHost $(hashQ "Reshape") <> arrayHash <> deep (travE sh) <> travA a + Backpermute sh f a -> intHost $(hashQ "Backpermute") <> arrayHash <> deep (travE sh) <> travF f <> travA a + Transform sh f1 f2 a -> intHost $(hashQ "Transform") <> arrayHash <> deep (travE sh) <> travF f1 <> travF f2 <> travA a + Replicate spec ix a -> intHost $(hashQ "Replicate") <> arrayHash <> deep (travE ix) <> travA a <> encodeSliceIndex spec + Slice spec a ix -> intHost $(hashQ "Slice") <> arrayHash <> deep (travE ix) <> travA a <> encodeSliceIndex spec + Map f a -> intHost $(hashQ "Map") <> arrayHash <> travF f <> travA a + ZipWith f a1 a2 -> intHost $(hashQ "ZipWith") <> arrayHash <> 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 @@ -251,17 +255,14 @@ 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 @a - where - encodeArrayType :: forall array sh e. (array ~ Array sh e, Shape sh, Elt e) => Builder - encodeArrayType = encodeTupleType (eltType @sh) <> encodeTupleType (eltType @e) encodeLeftHandSide :: forall a env env'. LeftHandSide a env env' -> Builder encodeLeftHandSide (LeftHandSideWildcard r) = intHost $(hashQ "LeftHandSideWildcard") <> encodeArraysType r encodeLeftHandSide (LeftHandSidePair r1 r2) = intHost $(hashQ "LeftHandSidePair") <> encodeLeftHandSide r1 <> encodeLeftHandSide r2 encodeLeftHandSide LeftHandSideArray = intHost $(hashQ "LeftHandSideArray") <> encodeArrayType @a - where - encodeArrayType :: forall array sh e. (array ~ Array sh e, Shape sh, Elt e) => Builder - encodeArrayType = encodeTupleType (eltType @sh) <> encodeTupleType (eltType @e) + +encodeArrayType :: forall array sh e. (array ~ Array sh e, Shape sh, Elt e) => Builder +encodeArrayType = encodeTupleType (eltType @sh) <> encodeTupleType (eltType @e) encodePreOpenAfun :: forall acc aenv f. From db2567360d3623e23e341386e49f5a944ce3af5f Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 22 Nov 2019 10:10:06 +0100 Subject: [PATCH 107/316] Fixes to hashing - Re-enable non-deep hashing in Hash.hs - For non-deep hashing, add the hash of the arrays type --- src/Data/Array/Accelerate/Analysis/Hash.hs | 12 +++++------- src/Data/Array/Accelerate/Trafo/Base.hs | 8 ++++---- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index da2cb1e5b..59d366d34 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -31,6 +31,7 @@ module Data.Array.Accelerate.Analysis.Hash ( encodePreOpenAcc, encodePreOpenExp, encodePreOpenFun, + encodeArraysType, hashQ, ) where @@ -156,16 +157,15 @@ encodePreOpenAcc options encodeAcc pacc = travB = encodePreBoundary options encodeAcc deep :: Builder -> Builder - -- deep x | perfect options = x - -- | otherwise = mempty - deep = id + deep | perfect options = id + | otherwise = const mempty arrayHash :: (Shape sh, Elt e, arrs ~ Array sh e) => Builder arrayHash = encodeArrayType @arrs in case pacc of Alet lhs bnd body -> intHost $(hashQ "Alet") <> encodeLeftHandSide lhs <> travA bnd <> travA body - Avar (ArrayVar v) -> intHost $(hashQ "Avar") <> deep (encodeIdx v) + Avar (ArrayVar v) -> intHost $(hashQ "Avar") <> arrayHash <> deep (encodeIdx v) Apair a1 a2 -> intHost $(hashQ "Apair") <> travA a1 <> travA a2 Anil -> intHost $(hashQ "Anil") Apply f a -> intHost $(hashQ "Apply") <> travAF f <> travA a @@ -273,9 +273,7 @@ encodePreOpenAfun encodePreOpenAfun options travA afun = let travL :: forall aenv1 aenv2 a b. LeftHandSide a aenv1 aenv2 -> PreOpenAfun acc aenv2 b -> Builder - travL lhs l = encodeArraysType repr <> encodePreOpenAfun options travA l - where - repr = lhsToArraysR lhs + travL lhs l = encodeLeftHandSide lhs <> encodePreOpenAfun options travA l in case afun of Abody b -> intHost $(hashQ "Abody") <> travA options b diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index c16ca3961..036744f69 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -261,12 +261,12 @@ encodeDelayedOpenAcc options acc = travA :: PreOpenAcc DelayedOpenAcc aenv a -> Builder travA = encodePreOpenAcc options encodeDelayedOpenAcc - deep :: Builder -> Builder - deep x | perfect options = x - | otherwise = mempty + deepA :: forall aenv' a. PreOpenAcc DelayedOpenAcc aenv' a -> Builder + deepA | perfect options = travA + | otherwise = encodeArraysType . arraysRepr in case acc of - Manifest pacc -> intHost $(hashQ ("Manifest" :: String)) <> deep (travA pacc) + Manifest pacc -> intHost $(hashQ ("Manifest" :: String)) <> deepA pacc Delayed sh f g -> intHost $(hashQ ("Delayed" :: String)) <> travE sh <> travF f <> travF g {-# INLINEABLE matchDelayedOpenAcc #-} From eaaede8bae8e6a7f08b8acf290d90903c5f65789 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 22 Nov 2019 14:51:26 +0100 Subject: [PATCH 108/316] Improve shallow hashing of expressions Only hash the type of the expression. We do not have to hash the result type of the Acc any more --- src/Data/Array/Accelerate/Analysis/Hash.hs | 25 ++++++++++++++-------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 59d366d34..9da93010a 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -160,6 +160,11 @@ encodePreOpenAcc options encodeAcc pacc = deep | perfect options = id | otherwise = const mempty + deepE :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder + deepE e + | perfect options = travE e + | otherwise = encodeTupleType (eltType @e) + arrayHash :: (Shape sh, Elt e, arrs ~ Array sh e) => Builder arrayHash = encodeArrayType @arrs in @@ -173,15 +178,17 @@ encodePreOpenAcc options encodeAcc pacc = Use a -> intHost $(hashQ "Use") <> arrayHash <> deep (encodeArray a) Awhile p f a -> intHost $(hashQ "Awhile") <> travAF f <> travAF p <> travA a Unit e -> intHost $(hashQ "Unit") <> travE e - Generate e f -> intHost $(hashQ "Generate") <> arrayHash <> deep (travE e) <> travF f - Acond e a1 a2 -> intHost $(hashQ "Acond") <> deep (travE e) <> travA a1 <> travA a2 - Reshape sh a -> intHost $(hashQ "Reshape") <> arrayHash <> deep (travE sh) <> travA a - Backpermute sh f a -> intHost $(hashQ "Backpermute") <> arrayHash <> deep (travE sh) <> travF f <> travA a - Transform sh f1 f2 a -> intHost $(hashQ "Transform") <> arrayHash <> deep (travE sh) <> travF f1 <> travF f2 <> travA a - Replicate spec ix a -> intHost $(hashQ "Replicate") <> arrayHash <> deep (travE ix) <> travA a <> encodeSliceIndex spec - Slice spec a ix -> intHost $(hashQ "Slice") <> arrayHash <> deep (travE ix) <> travA a <> encodeSliceIndex spec - Map f a -> intHost $(hashQ "Map") <> arrayHash <> travF f <> travA a - ZipWith f a1 a2 -> intHost $(hashQ "ZipWith") <> arrayHash <> travF f <> travA a1 <> travA a2 + Generate e f -> intHost $(hashQ "Generate") <> deepE e <> travF f + -- We don't need to encode the type of 'e' when perfect is False, as 'e' is an expression of type Bool. + -- We thus use `deep (travE e)` instead of `deepE e`. + Acond e a1 a2 -> intHost $(hashQ "Acond") <> deep (travE e) <> travA a1 <> travA a2 + Reshape sh a -> intHost $(hashQ "Reshape") <> deepE sh <> travA a + Backpermute sh f a -> intHost $(hashQ "Backpermute") <> deepE sh <> travF f <> travA a + Transform sh f1 f2 a -> intHost $(hashQ "Transform") <> deepE sh <> travF f1 <> travF f2 <> travA a + Replicate spec ix a -> intHost $(hashQ "Replicate") <> deepE ix <> travA a <> encodeSliceIndex spec + Slice spec a ix -> intHost $(hashQ "Slice") <> deepE 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 From de2287cd868475eb28956f0c411804256a399588 Mon Sep 17 00:00:00 2001 From: David van Balen Date: Sat, 30 Nov 2019 14:55:03 +0100 Subject: [PATCH 109/316] new definitions for zipWithX --- src/Data/Array/Accelerate/Prelude.hs | 43 ++++++++-------------------- 1 file changed, 12 insertions(+), 31 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 762114f8b..1dcb727e9 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Prelude -- Copyright : [2009..2019] The Accelerate Team @@ -184,8 +185,7 @@ zipWith3 -> 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)) + = zipWith (\(unlift -> (a, b)) c -> f a b c) (zip as bs) cs -- | Zip four arrays with the given function, analogous to 'zipWith'. -- @@ -198,9 +198,7 @@ zipWith4 -> 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)) + = zipWith3 (\(unlift -> (a, b)) c d -> f a b c d) (zip as bs) cs ds -- | Zip five arrays with the given function, analogous to 'zipWith'. -- @@ -214,9 +212,7 @@ zipWith5 -> 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)) + = zipWith4 (\(unlift -> (a, b)) c d e -> f a b c d e) (zip as bs) cs ds es -- | Zip six arrays with the given function, analogous to 'zipWith'. -- @@ -230,11 +226,8 @@ zipWith6 -> 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)) +zipWith6 fn as bs cs ds es fs + = zipWith5 (\(unlift -> (a, b)) c d e f -> fn a b c d e f) (zip as bs) cs ds es fs -- | Zip seven arrays with the given function, analogous to 'zipWith'. -- @@ -249,11 +242,8 @@ zipWith7 -> 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)) +zipWith7 fn as bs cs ds es fs gs + = zipWith6 (\(unlift -> (a, b)) c d e f g -> fn a b c d e f g) (zip as bs) cs ds es fs gs -- | Zip eight arrays with the given function, analogous to 'zipWith'. -- @@ -269,12 +259,8 @@ zipWith8 -> 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)) +zipWith8 fn as bs cs ds es fs gs hs + = zipWith7 (\(unlift -> (a, b)) c d e f g h -> fn a b c d e f g h) (zip as bs) cs ds es fs gs hs -- | Zip nine arrays with the given function, analogous to 'zipWith'. -- @@ -291,13 +277,8 @@ zipWith9 -> 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)) - +zipWith9 fn as bs cs ds es fs gs hs is + = zipWith8 (\(unlift -> (a, b)) c d e f g h i -> fn a b c d e f g h i) (zip as bs) cs ds es fs gs hs is -- | Zip two arrays with a function that also takes the element index -- From 911e691cfaa998fcc226975c6de093c8f3510c3e Mon Sep 17 00:00:00 2001 From: David van Balen Date: Sat, 30 Nov 2019 17:01:57 +0100 Subject: [PATCH 110/316] fixed izipWith's --- src/Data/Array/Accelerate/Prelude.hs | 44 ++++++++-------------------- 1 file changed, 12 insertions(+), 32 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 1dcb727e9..542674e46 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -289,8 +289,7 @@ izipWith -> 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)) + = imap (\ix (unlift -> (a, b)) -> f ix a b) $ zip as bs -- | Zip three arrays with a function that also takes the element index, -- analogous to 'izipWith'. @@ -303,8 +302,7 @@ izipWith3 -> 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)) + = izipWith (\ix (unlift -> (a, b)) c -> f ix a b c) (zip as bs) cs -- | Zip four arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -318,9 +316,7 @@ izipWith4 -> 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)) + = izipWith (\ix (unlift -> (a, b)) c d -> f ix a b c d) (zip as bs) cs ds -- | Zip five arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -335,9 +331,7 @@ izipWith5 -> 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)) + = izipWith (\ix (unlift -> (a, b)) c d e -> f ix a b c d e) (zip as bs) cs ds es -- | Zip six arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -352,11 +346,8 @@ izipWith6 -> 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)) +izipWith6 fn as bs cs ds es fs + = izipWith (\ix (unlift -> (a, b)) c d e f -> fn ix a b c d e f) (zip as bs) cs ds es fs -- | Zip seven arrays with the given function that also takes the element -- index, analogous to 'zipWith'. @@ -372,11 +363,8 @@ izipWith7 -> 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)) +izipWith7 fn as bs cs ds es fs gs + = izipWith (\ix (unlift -> (a, b)) c d e f g -> fn ix a b c d e f g) (zip as bs) cs ds es fs gs -- | Zip eight arrays with the given function that also takes the element -- index, analogous to 'zipWith'. @@ -393,12 +381,8 @@ izipWith8 -> 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)) +izipWith8 fn as bs cs ds es fs gs hs + = izipWith (\ix (unlift -> (a, b)) c d e f g h -> fn ix a b c d e f g h) (zip as bs) cs ds es fs gs hs -- | Zip nine arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -416,12 +400,8 @@ izipWith9 -> 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)) +izipWith9 fn as bs cs ds es fs gs hs is + = izipWith (\ix (unlift -> (a, b)) c d e f g h i -> fn ix a b c d e f g h i) (zip as bs) cs ds es fs gs hs is -- | Combine the elements of two arrays pairwise. The shape of the result is the From f4292dfdba3439baa24edce113573a095ef0171a Mon Sep 17 00:00:00 2001 From: David van Balen Date: Sat, 30 Nov 2019 17:01:57 +0100 Subject: [PATCH 111/316] fixed izipWith's fixed small mistake --- src/Data/Array/Accelerate/Prelude.hs | 44 ++++++++-------------------- 1 file changed, 12 insertions(+), 32 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 1dcb727e9..6c47f3702 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -289,8 +289,7 @@ izipWith -> 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)) + = imap (\ix (unlift -> (a, b)) -> f ix a b) $ zip as bs -- | Zip three arrays with a function that also takes the element index, -- analogous to 'izipWith'. @@ -303,8 +302,7 @@ izipWith3 -> 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)) + = izipWith (\ix (unlift -> (a, b)) c -> f ix a b c) (zip as bs) cs -- | Zip four arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -318,9 +316,7 @@ izipWith4 -> 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)) + = izipWith3 (\ix (unlift -> (a, b)) c d -> f ix a b c d) (zip as bs) cs ds -- | Zip five arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -335,9 +331,7 @@ izipWith5 -> 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)) + = izipWith4 (\ix (unlift -> (a, b)) c d e -> f ix a b c d e) (zip as bs) cs ds es -- | Zip six arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -352,11 +346,8 @@ izipWith6 -> 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)) +izipWith6 fn as bs cs ds es fs + = izipWith5 (\ix (unlift -> (a, b)) c d e f -> fn ix a b c d e f) (zip as bs) cs ds es fs -- | Zip seven arrays with the given function that also takes the element -- index, analogous to 'zipWith'. @@ -372,11 +363,8 @@ izipWith7 -> 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)) +izipWith7 fn as bs cs ds es fs gs + = izipWith6 (\ix (unlift -> (a, b)) c d e f g -> fn ix a b c d e f g) (zip as bs) cs ds es fs gs -- | Zip eight arrays with the given function that also takes the element -- index, analogous to 'zipWith'. @@ -393,12 +381,8 @@ izipWith8 -> 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)) +izipWith8 fn as bs cs ds es fs gs hs + = izipWith7 (\ix (unlift -> (a, b)) c d e f g h -> fn ix a b c d e f g h) (zip as bs) cs ds es fs gs hs -- | Zip nine arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -416,12 +400,8 @@ izipWith9 -> 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)) +izipWith9 fn as bs cs ds es fs gs hs is + = izipWith8 (\ix (unlift -> (a, b)) c d e f g h i -> fn ix a b c d e f g h i) (zip as bs) cs ds es fs gs hs is -- | Combine the elements of two arrays pairwise. The shape of the result is the From 40ceeb5a7592f711142cf4757815aae4a4b0c9c5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 5 Dec 2019 18:09:19 +0100 Subject: [PATCH 112/316] prettier tuple printing --- src/Data/Array/Accelerate/Pretty.hs | 4 +- src/Data/Array/Accelerate/Pretty/Print.hs | 55 ++++++++++++++++------- 2 files changed, 42 insertions(+), 17 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index 5784828b5..fc549c4c0 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -144,8 +144,8 @@ terminalLayoutOptions where w = Term.width t f | w <= 80 = 1 - | w <= 100 = 0.8 - | otherwise = 0.6 + | w <= 100 = 0.9 + | otherwise = 0.8 prettyOpenAcc :: PrettyAcc OpenAcc prettyOpenAcc context aenv (OpenAcc pacc) = diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index f28b226fb..0aff9340d 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -110,11 +110,10 @@ prettyPreOpenAfun prettyPreOpenAfun prettyAcc aenv0 = next (pretty '\\') aenv0 where next :: Adoc -> Val aenv' -> PreOpenAfun acc aenv' f' -> Adoc - next vs aenv (Abody body) = hang shiftwidth (sep [vs <> "->", prettyAcc context0 aenv body]) + next vs aenv (Abody body) = hang shiftwidth (sep [vs <> "->", prettyAcc context0 aenv body]) next vs aenv (Alam lhs lam) = - let - (aenv', lhs') = prettyLHS aenv lhs - in next (vs <> lhs' <> space) aenv' lam + let (aenv', lhs') = prettyLHS aenv lhs + in next (vs <> lhs' <> space) aenv' lam prettyPreOpenAcc :: forall acc aenv arrs. @@ -128,7 +127,7 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = case pacc of Avar (ArrayVar idx) -> prj idx aenv Alet{} -> prettyAlet ctx prettyAcc extractAcc aenv pacc - Apair a1 a2 -> "(" <> prettyAcc context0 aenv a1 <> ", " <> prettyAcc context0 aenv a2 <> ")" + Apair{} -> prettyAtuple prettyAcc extractAcc aenv pacc Anil -> "()" Apply f a -> apply where @@ -229,7 +228,7 @@ prettyAlet ctx prettyAcc extractAcc aenv0 isAlet :: acc aenv' a -> Bool isAlet (extractAcc -> Alet{}) = True - isAlet _ = False + isAlet _ = False ppA :: Val aenv' -> acc aenv' a -> Adoc ppA = prettyAcc context0 @@ -244,19 +243,45 @@ prettyAlet ctx prettyAcc extractAcc aenv0 , body ] -prettyLHS :: Val aenv -> LeftHandSide arrs aenv aenv' -> (Val aenv', Adoc) -prettyLHS aenv (LeftHandSideWildcard ArraysRunit) = (aenv, "()") -prettyLHS aenv (LeftHandSideWildcard _) = (aenv, "_") -prettyLHS aenv LeftHandSideArray = (aenv `Push` v, v) +prettyAtuple + :: forall acc aenv arrs. + PrettyAcc acc + -> ExtractAcc acc + -> Val aenv + -> PreOpenAcc acc aenv arrs + -> Adoc +prettyAtuple prettyAcc extractAcc aenv0 + = align . wrap . collect aenv0 where - v = pretty 'a' <> pretty (sizeEnv aenv) -prettyLHS aenv (LeftHandSidePair a b) = (aenv2, "(" <> doc1 <> ", " <> doc2 <> ")") + wrap [x] = x + wrap xs = tupled xs + + collect :: Val aenv' -> PreOpenAcc acc aenv' a -> [Adoc] + collect aenv = + \case + Anil -> [] + Apair a1 a2 -> collect aenv (extractAcc a1) ++ [prettyAcc context0 aenv a2] + next -> [prettyPreOpenAcc context0 prettyAcc extractAcc aenv next] + +prettyLHS :: Val aenv -> LeftHandSide arrs aenv aenv' -> (Val aenv', Adoc) +prettyLHS aenv0 = fmap wrap . go aenv0 where - (aenv1, doc1) = prettyLHS aenv a - (aenv2, doc2) = prettyLHS aenv1 b + wrap [x] = x + wrap xs = tupled xs + + go :: Val aenv -> LeftHandSide arrs aenv aenv' -> (Val aenv', [Adoc]) + go aenv (LeftHandSideWildcard ArraysRunit) = (aenv, []) + go aenv (LeftHandSideWildcard _) = (aenv, ["_"]) + go aenv LeftHandSideArray = (aenv `Push` v, [v]) + where + v = pretty 'a' <> pretty (sizeEnv aenv) + go aenv (LeftHandSidePair a b) = (aenv2, doc1 ++ [doc2]) + where + (aenv1, doc1) = go aenv a + (aenv2, doc2) = prettyLHS aenv1 b prettyArray :: (Shape sh, Elt e) => Array sh e -> Adoc -prettyArray = viaShow +prettyArray = parens . viaShow -- Scalar expressions From 7fd40b6678d606d4f9decf0de54fd4ca3c450b2c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 6 Dec 2019 16:48:55 +0100 Subject: [PATCH 113/316] generate IsPattern Acc instances using TH --- src/Data/Array/Accelerate/AST.hs | 8 +- src/Data/Array/Accelerate/Lift.hs | 6 +- src/Data/Array/Accelerate/Pattern.hs | 105 +++++---------------- src/Data/Array/Accelerate/Trafo/Sharing.hs | 2 +- 4 files changed, 34 insertions(+), 87 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index a0c4004f3..67cff57df 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -273,8 +273,8 @@ lhsToArraysR (LeftHandSidePair as bs) = ArraysRpair (lhsToArraysR as) (lhsToArra type env :> env' = forall t'. Idx env t' -> Idx env' t' weakenWithLHS :: LeftHandSide arrs env env' -> env :> env' -weakenWithLHS (LeftHandSideWildcard _) = id -weakenWithLHS LeftHandSideArray = SuccIdx +weakenWithLHS (LeftHandSideWildcard _) = id +weakenWithLHS LeftHandSideArray = SuccIdx weakenWithLHS (LeftHandSidePair lhs1 lhs2) = weakenWithLHS lhs2 . weakenWithLHS lhs1 -- Often useful when working with LeftHandSide, when you need to @@ -852,7 +852,7 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr (Apair as bs) = ArraysRpair (arraysRepr as) (arraysRepr bs) arraysRepr Anil = ArraysRunit arraysRepr (Apply (Alam _ (Abody a)) _) = arraysRepr a - arraysRepr (Apply _ _) = error "Tomorrow will arive, on time" + arraysRepr (Apply _ _) = error "Tomorrow will arrive, on time" arraysRepr (Aforeign _ (Alam _ (Abody a)) _) = arraysRepr a arraysRepr (Aforeign _ (Abody _) _) = error "And what have you got, at the end of the day?" arraysRepr (Aforeign _ (Alam _ (Alam _ _)) _) = error "A bottle of whisky. And a new set of lies." @@ -884,7 +884,7 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr Stencil2{} = ArraysRarray instance HasArraysRepr OpenAcc where - arraysRepr (OpenAcc a) = arraysRepr a + arraysRepr (OpenAcc a) = arraysRepr a -- Embedded expressions -- -------------------- diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 3e271e46d..22cb2796a 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -473,9 +473,9 @@ instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, -- Instances for Arrays class ---instance Lift Acc () where --- type Plain () = () --- lift _ = Acc (Atuple NilAtup) +-- instance Lift Acc () where +-- type Plain () = () +-- lift _ = Acc (SmartAcc Anil) instance (Shape sh, Elt e) => Lift Acc (Array sh e) where type Plain (Array sh e) = Array sh e diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 1083ea990..4645ca36e 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -278,8 +278,8 @@ instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where -- $(runQ $ do let - mkIsPattern :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] - mkIsPattern con cst tup prj nil snoc n = + mkIsPattern' :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] + mkIsPattern' con cst tup prj nil snoc n = let xs = [ mkName ('x' : show i) | i <- [0 .. n-1]] b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs @@ -300,84 +300,31 @@ $(runQ $ do destruct _x = $(tupE (map (get [|_x|]) [(n-1), (n-2) .. 0])) |] - mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] - -- + mkIsPattern :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] + mkIsPattern _ _ _ _ _ _ 1 = return [] + mkIsPattern con cst smart prj nil pair n = do + let + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + a = foldl (\ts t -> appT ts (varT t)) (tupleT n) xs + b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs + context = foldl (\ts t -> appT ts (appT cst (varT t))) (tupleT n) xs + -- + get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] + get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) + -- + _x <- newName "_x" + [d| instance $context => IsPattern $(conT con) $a $b where + construct $(tupP (map (conP con . return . varP) xs)) = + $(conE con) $(foldl (\vs v -> appE smart (appE (appE pair vs) (varE v))) (appE smart nil) xs) + destruct $(conP con [varP _x]) = + $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0])) + |] + + mkExpPattern = mkIsPattern' (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] + mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] -- es <- mapM mkExpPattern [0..16] - return $ concat es + as <- mapM mkAccPattern [0..16] + return $ concat (es ++ as) ) --- IsPattern instances for Acc -instance (Arrays a, Arrays b) => IsPattern Acc (a, b) (Acc a, Acc b) where - construct = atup2 - destruct = unatup2 - -instance (Arrays a, Arrays b, Arrays c) - => IsPattern Acc (a, b, c) (Acc a, Acc b, Acc c) where - construct = atup3 - destruct = unatup3 - -instance (Arrays a, Arrays b, Arrays c, Arrays d) - => IsPattern Acc (a, b, c, d) (Acc a, Acc b, Acc c, Acc d) where - construct = atup4 - destruct = unatup4 - -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) - => IsPattern Acc (a, b, c, d, e) (Acc a, Acc b, Acc c, Acc d, Acc e) where - construct = atup5 - destruct = unatup5 - -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f) - => IsPattern Acc (a, b, c, d, e, f) (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) where - construct = atup6 - destruct = unatup6 - -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g) - => IsPattern Acc (a, b, c, d, e, f, g) (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) where - construct = atup7 - destruct = unatup7 - -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h) - => IsPattern 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) where - construct = atup8 - destruct = unatup8 - -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i) - => IsPattern 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) where - construct = atup9 - destruct = unatup9 - -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j) - => IsPattern 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) where - construct = atup10 - destruct = unatup10 - -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i, Arrays j, Arrays k) - => IsPattern 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) where - construct = atup11 - destruct = unatup11 - -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) - => IsPattern 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) where - construct = atup12 - destruct = unatup12 - -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) - => IsPattern 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) where - construct = atup13 - destruct = unatup13 - -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) - => IsPattern 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) where - construct = atup14 - destruct = unatup14 - -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) - => IsPattern 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) where - construct = atup15 - destruct = unatup15 - -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) - => IsPattern 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) where - construct = atup16 - destruct = unatup16 diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 7e4cdc048..da4371271 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -160,7 +160,7 @@ sizeArrayLayout (ArrayPushLayout lyt _ _) = 1 + sizeArrayLayout lyt incVarsWith :: env1 :> env2 -> ArrayVars env1 t -> ArrayVars env2 t incVarsWith _ ArrayVarsNil = ArrayVarsNil -incVarsWith k (ArrayVarsArray (ArrayVar idx)) = ArrayVarsArray $ ArrayVar $ k idx +incVarsWith k (ArrayVarsArray (ArrayVar idx)) = ArrayVarsArray $ ArrayVar $ k idx incVarsWith k (ArrayVarsPair v1 v2) = incVarsWith k v1 `ArrayVarsPair` incVarsWith k v2 -- Conversion from HOAS to de Bruijn computation AST From a2c64b8aaf693df9bd569fff996df6a84e8e921f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 6 Dec 2019 17:11:20 +0100 Subject: [PATCH 114/316] version bump 1.4.0.0 --- accelerate.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/accelerate.cabal b/accelerate.cabal index 8b3751055..aba3dd8ed 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -1,5 +1,5 @@ Name: accelerate -Version: 1.3.0.0 +Version: 1.4.0.0 Cabal-version: >= 1.18 Tested-with: GHC >= 7.10 Build-type: Custom @@ -583,7 +583,7 @@ source-repository head source-repository this Type: git - Tag: v1.3.0.0 + Tag: v1.4.0.0 Location: git://github.com/AccelerateHS/accelerate.git -- vim: nospell From ce08ef2dfec606b70650cc62b1d7e0ade0f8b7f8 Mon Sep 17 00:00:00 2001 From: David Date: Sat, 7 Dec 2019 17:00:22 +0100 Subject: [PATCH 115/316] possibly cleaner version still, should not change meaning or speed --- src/Data/Array/Accelerate/Prelude.hs | 65 +++++++++++++++------------- 1 file changed, 35 insertions(+), 30 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 6c47f3702..4c3d7e66e 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -174,6 +174,15 @@ imap :: (Shape sh, Elt a, Elt b) -> Acc (Array sh b) imap f xs = zipWith f (generate (shape xs) id) xs +-- | Used to define the zipWith functions on more than two arrays +zipWithInduction :: (Shape sh, Elt a, Elt b) + => ((Exp (a,b) -> rest) -> Acc (Array sh (a,b)) -> result) -- The zipWith function operating on one fewer array + -> (Exp a -> Exp b -> rest) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> result +zipWithInduction prev f as bs = prev (\(unlift -> (a,b)) -> f a b) (zip as bs) + -- | Zip three arrays with the given function, analogous to 'zipWith'. -- @@ -184,8 +193,7 @@ zipWith3 -> Acc (Array sh b) -> Acc (Array sh c) -> Acc (Array sh d) -zipWith3 f as bs cs - = zipWith (\(unlift -> (a, b)) c -> f a b c) (zip as bs) cs +zipWith3 = zipWithInduction zipWith -- | Zip four arrays with the given function, analogous to 'zipWith'. -- @@ -197,8 +205,7 @@ zipWith4 -> Acc (Array sh c) -> Acc (Array sh d) -> Acc (Array sh e) -zipWith4 f as bs cs ds - = zipWith3 (\(unlift -> (a, b)) c d -> f a b c d) (zip as bs) cs ds +zipWith4 = zipWithInduction zipWith3 -- | Zip five arrays with the given function, analogous to 'zipWith'. -- @@ -211,8 +218,7 @@ zipWith5 -> Acc (Array sh d) -> Acc (Array sh e) -> Acc (Array sh f) -zipWith5 f as bs cs ds es - = zipWith4 (\(unlift -> (a, b)) c d e -> f a b c d e) (zip as bs) cs ds es +zipWith5 = zipWithInduction zipWith4 -- | Zip six arrays with the given function, analogous to 'zipWith'. -- @@ -226,8 +232,7 @@ zipWith6 -> Acc (Array sh e) -> Acc (Array sh f) -> Acc (Array sh g) -zipWith6 fn as bs cs ds es fs - = zipWith5 (\(unlift -> (a, b)) c d e f -> fn a b c d e f) (zip as bs) cs ds es fs +zipWith6 = zipWithInduction zipWith5 -- | Zip seven arrays with the given function, analogous to 'zipWith'. -- @@ -242,8 +247,7 @@ zipWith7 -> Acc (Array sh f) -> Acc (Array sh g) -> Acc (Array sh h) -zipWith7 fn as bs cs ds es fs gs - = zipWith6 (\(unlift -> (a, b)) c d e f g -> fn a b c d e f g) (zip as bs) cs ds es fs gs +zipWith7 = zipWithInduction zipWith6 -- | Zip eight arrays with the given function, analogous to 'zipWith'. -- @@ -259,8 +263,7 @@ zipWith8 -> Acc (Array sh g) -> Acc (Array sh h) -> Acc (Array sh i) -zipWith8 fn as bs cs ds es fs gs hs - = zipWith7 (\(unlift -> (a, b)) c d e f g h -> fn a b c d e f g h) (zip as bs) cs ds es fs gs hs +zipWith8 = zipWithInduction zipWith7 -- | Zip nine arrays with the given function, analogous to 'zipWith'. -- @@ -277,8 +280,18 @@ zipWith9 -> Acc (Array sh h) -> Acc (Array sh i) -> Acc (Array sh j) -zipWith9 fn as bs cs ds es fs gs hs is - = zipWith8 (\(unlift -> (a, b)) c d e f g h i -> fn a b c d e f g h i) (zip as bs) cs ds es fs gs hs is +zipWith9 = zipWithInduction zipWith8 + + +-- | Used to define the izipWith functions on two or more arrays +izipWithInduction :: (Shape sh, Elt a, Elt b) + => ((Exp sh -> Exp (a,b) -> rest) -> Acc (Array sh (a,b)) -> result) -- The zipWith function operating on one fewer array + -> (Exp sh -> Exp a -> Exp b -> rest) + -> Acc (Array sh a) + -> Acc (Array sh b) + -> result +izipWithInduction prev f as bs = prev (\ix (unlift -> (a,b)) -> f ix a b) (zip as bs) + -- | Zip two arrays with a function that also takes the element index -- @@ -288,8 +301,7 @@ izipWith -> Acc (Array sh a) -> Acc (Array sh b) -> Acc (Array sh c) -izipWith f as bs - = imap (\ix (unlift -> (a, b)) -> f ix a b) $ zip as bs +izipWith = izipWithInduction imap -- | Zip three arrays with a function that also takes the element index, -- analogous to 'izipWith'. @@ -301,8 +313,7 @@ izipWith3 -> Acc (Array sh b) -> Acc (Array sh c) -> Acc (Array sh d) -izipWith3 f as bs cs - = izipWith (\ix (unlift -> (a, b)) c -> f ix a b c) (zip as bs) cs +izipWith3 = izipWithInduction izipWith -- | Zip four arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -315,8 +326,7 @@ izipWith4 -> Acc (Array sh c) -> Acc (Array sh d) -> Acc (Array sh e) -izipWith4 f as bs cs ds - = izipWith3 (\ix (unlift -> (a, b)) c d -> f ix a b c d) (zip as bs) cs ds +izipWith4 = izipWithInduction izipWith3 -- | Zip five arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -330,8 +340,7 @@ izipWith5 -> Acc (Array sh d) -> Acc (Array sh e) -> Acc (Array sh f) -izipWith5 f as bs cs ds es - = izipWith4 (\ix (unlift -> (a, b)) c d e -> f ix a b c d e) (zip as bs) cs ds es +izipWith5 = izipWithInduction izipWith4 -- | Zip six arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -346,8 +355,7 @@ izipWith6 -> Acc (Array sh e) -> Acc (Array sh f) -> Acc (Array sh g) -izipWith6 fn as bs cs ds es fs - = izipWith5 (\ix (unlift -> (a, b)) c d e f -> fn ix a b c d e f) (zip as bs) cs ds es fs +izipWith6 = izipWithInduction izipWith5 -- | Zip seven arrays with the given function that also takes the element -- index, analogous to 'zipWith'. @@ -363,8 +371,7 @@ izipWith7 -> Acc (Array sh f) -> Acc (Array sh g) -> Acc (Array sh h) -izipWith7 fn as bs cs ds es fs gs - = izipWith6 (\ix (unlift -> (a, b)) c d e f g -> fn ix a b c d e f g) (zip as bs) cs ds es fs gs +izipWith7 = izipWithInduction izipWith6 -- | Zip eight arrays with the given function that also takes the element -- index, analogous to 'zipWith'. @@ -381,8 +388,7 @@ izipWith8 -> Acc (Array sh g) -> Acc (Array sh h) -> Acc (Array sh i) -izipWith8 fn as bs cs ds es fs gs hs - = izipWith7 (\ix (unlift -> (a, b)) c d e f g h -> fn ix a b c d e f g h) (zip as bs) cs ds es fs gs hs +izipWith8 = izipWithInduction izipWith7 -- | Zip nine arrays with the given function that also takes the element index, -- analogous to 'zipWith'. @@ -400,8 +406,7 @@ izipWith9 -> Acc (Array sh h) -> Acc (Array sh i) -> Acc (Array sh j) -izipWith9 fn as bs cs ds es fs gs hs is - = izipWith8 (\ix (unlift -> (a, b)) c d e f g h i -> fn ix a b c d e f g h i) (zip as bs) cs ds es fs gs hs is +izipWith9 = izipWithInduction izipWith8 -- | Combine the elements of two arrays pairwise. The shape of the result is the From 1914d58b54343883cc465809faa3fbe38ce08afc Mon Sep 17 00:00:00 2001 From: David Date: Mon, 9 Dec 2019 13:34:42 +0100 Subject: [PATCH 116/316] used patterns --- src/Data/Array/Accelerate/Prelude.hs | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 4c3d7e66e..eee59023a 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -128,6 +128,7 @@ 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.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -164,7 +165,7 @@ import Data.Array.Accelerate.Data.Bits -- (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 +indexed = imap T2 -- | Apply a function to every element of an array and its index -- @@ -181,7 +182,7 @@ zipWithInduction :: (Shape sh, Elt a, Elt b) -> Acc (Array sh a) -> Acc (Array sh b) -> result -zipWithInduction prev f as bs = prev (\(unlift -> (a,b)) -> f a b) (zip as bs) +zipWithInduction prev f as bs = prev (\(T2 a b) -> f a b) (zip as bs) -- | Zip three arrays with the given function, analogous to 'zipWith'. @@ -290,7 +291,7 @@ izipWithInduction :: (Shape sh, Elt a, Elt b) -> Acc (Array sh a) -> Acc (Array sh b) -> result -izipWithInduction prev f as bs = prev (\ix (unlift -> (a,b)) -> f ix a b) (zip as bs) +izipWithInduction prev f as bs = prev (\ix (T2 a b) -> f ix a b) (zip as bs) -- | Zip two arrays with a function that also takes the element index @@ -426,7 +427,7 @@ zip :: (Shape sh, Elt a, Elt b) => Acc (Array sh a) -> Acc (Array sh b) -> Acc (Array sh (a, b)) -zip = zipWith (curry lift) +zip = zipWith T2 -- | Take three arrays and return an array of triples, analogous to zip. -- @@ -435,7 +436,7 @@ zip3 :: (Shape sh, Elt a, Elt b, Elt c) -> Acc (Array sh b) -> Acc (Array sh c) -> Acc (Array sh (a, b, c)) -zip3 = zipWith3 (\a b c -> lift (a,b,c)) +zip3 = zipWith3 T3 -- | Take four arrays and return an array of quadruples, analogous to zip. -- @@ -445,7 +446,7 @@ zip4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d) -> 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)) +zip4 = zipWith4 T4 -- | Take five arrays and return an array of five-tuples, analogous to zip. -- @@ -456,7 +457,7 @@ zip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e) -> 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)) +zip5 = zipWith5 T5 -- | Take six arrays and return an array of six-tuples, analogous to zip. -- @@ -468,7 +469,7 @@ zip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) -> 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)) +zip6 = zipWith6 T6 -- | Take seven arrays and return an array of seven-tuples, analogous to zip. -- @@ -481,7 +482,7 @@ zip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) -> 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)) +zip7 = zipWith7 T7 -- | Take seven arrays and return an array of seven-tuples, analogous to zip. -- @@ -495,7 +496,7 @@ zip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h) -> 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)) +zip8 = zipWith8 T8 -- | Take seven arrays and return an array of seven-tuples, analogous to zip. -- @@ -510,7 +511,7 @@ zip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i -> 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)) +zip9 = zipWith9 T9 -- | The converse of 'zip', but the shape of the two results is identical to the From 1b27df91a47185bf9c39201088aadf41061b2288 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 11 Dec 2019 10:48:29 +0100 Subject: [PATCH 117/316] unused extension --- src/Data/Array/Accelerate/Prelude.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index eee59023a..8861cda61 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -11,7 +11,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Prelude -- Copyright : [2009..2019] The Accelerate Team From 4f9ea57870171ad7b66ce86a232c50de21f03d99 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 11 Dec 2019 10:48:36 +0100 Subject: [PATCH 118/316] strip trailing whitespace --- src/Data/Array/Accelerate/Prelude.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 8861cda61..92ee22af2 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -175,9 +175,9 @@ imap :: (Shape sh, Elt a, Elt b) imap f xs = zipWith f (generate (shape xs) id) xs -- | Used to define the zipWith functions on more than two arrays -zipWithInduction :: (Shape sh, Elt a, Elt b) +zipWithInduction :: (Shape sh, Elt a, Elt b) => ((Exp (a,b) -> rest) -> Acc (Array sh (a,b)) -> result) -- The zipWith function operating on one fewer array - -> (Exp a -> Exp b -> rest) + -> (Exp a -> Exp b -> rest) -> Acc (Array sh a) -> Acc (Array sh b) -> result @@ -284,9 +284,9 @@ zipWith9 = zipWithInduction zipWith8 -- | Used to define the izipWith functions on two or more arrays -izipWithInduction :: (Shape sh, Elt a, Elt b) +izipWithInduction :: (Shape sh, Elt a, Elt b) => ((Exp sh -> Exp (a,b) -> rest) -> Acc (Array sh (a,b)) -> result) -- The zipWith function operating on one fewer array - -> (Exp sh -> Exp a -> Exp b -> rest) + -> (Exp sh -> Exp a -> Exp b -> rest) -> Acc (Array sh a) -> Acc (Array sh b) -> result From 9eaccc1a9953c442fcf2ffed0827634f37793a57 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 12 Dec 2019 14:46:27 +0100 Subject: [PATCH 119/316] update .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 5ab8a2309..6ddeedcf3 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ /.stack-work /stack.yaml /stack.yaml.lock +.DS_Store From 78683f70d914184daa7b9b40ec66df21f3bf5f40 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 12 Dec 2019 14:48:11 +0100 Subject: [PATCH 120/316] generate Acc Lift and Unlift instances with TH --- src/Data/Array/Accelerate/Lift.hs | 360 +++------------- src/Data/Array/Accelerate/Smart.hs | 635 ----------------------------- 2 files changed, 46 insertions(+), 949 deletions(-) diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 22cb2796a..8ea40c61b 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ <= 708 @@ -37,6 +39,8 @@ import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type +import Language.Haskell.TH hiding ( Exp ) + -- |Lift a unary function into 'Exp'. -- @@ -81,8 +85,8 @@ ilift3 :: (Exp Int -> Exp Int -> Exp Int -> Exp Int) -> 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@. @@ -92,6 +96,7 @@ class Lift c e where -- 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 @@ -471,322 +476,49 @@ instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, --- Instances for Arrays class - --- instance Lift Acc () where --- type Plain () = () --- lift _ = Acc (SmartAcc Anil) +instance Lift Acc () where + type Plain () = () + lift _ = Acc (SmartAcc Anil) instance (Shape sh, Elt e) => Lift Acc (Array sh e) where type Plain (Array sh e) = Array sh e lift = Acc . SmartAcc . 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 - -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, Lift Acc p, - 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), Arrays (Plain p)) - => Lift Acc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where - type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) - = (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, Plain p) - lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) - = atup16 (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, lift p) - -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) - => 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, Acc p) where - unlift = unatup16 - -{-- --- 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) - -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, Lift Seq p, - 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), Arrays (Plain p)) - => Lift Seq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where - type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) - = (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, Plain p) - lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) - = stup16 (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, lift p) ---} +-- Lift and Unlift instances for tuples +-- +$(runQ $ do + let + mkInstances :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] + mkInstances con cst smart prj nil pair n = do + let + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + res1 = foldl (\ts t -> appT ts (varT t)) (tupleT n) xs + res2 = foldl (\ts t -> [t| $ts ($(conT con) $(varT t)) |]) (tupleT n) xs + ctx1 = foldl (\ts t -> [t| $ts (Lift $(conT con) $(varT t)) |]) (tupleT n) xs + ctx2 = foldl (\ts t -> [t| $ts ($cst (Plain $(varT t))) |]) (tupleT n) xs + ctx3 = foldl (\ts t -> [t| $ts ($cst $(varT t)) |]) (tupleT n) xs + plain = foldl (\ts t -> [t| $ts (Plain $(varT t)) |]) (tupleT n) xs + -- + get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] + get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) + -- + _x <- newName "_x" + [d| instance ($ctx1, $ctx2) => Lift $(conT con) $res1 where + type Plain $res1 = $plain + lift $(tupP (map varP xs)) = + $(conE con) + $(foldl (\vs v -> do _v <- newName "_v" + [| let $(conP con [varP _v]) = lift $(varE v) + in $smart ($pair $vs $(varE _v)) |]) [| $smart $nil |] xs) + + instance $ctx3 => Unlift $(conT con) $res2 where + unlift $(conP con [varP _x]) = + $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0])) + |] + + mkAccInstances = mkInstances (mkName "Acc") [t| Arrays |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] + -- + as <- mapM mkAccInstances [2..16] + return $ concat as + ) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 942373136..733c17d62 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -40,9 +40,6 @@ module Data.Array.Accelerate.Smart ( 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, @@ -709,465 +706,6 @@ data PreExp acc exp t where -> PreExp acc exp b - --- Smart constructors and destructors for array tuples --- --------------------------------------------------- - -nilAtup :: SmartAcc () -nilAtup = SmartAcc Anil - -snocAtup :: (Typeable a, Arrays b) => SmartAcc a -> Acc b -> SmartAcc (a, ArrRepr b) -snocAtup a (Acc b) = SmartAcc $ Apair a b - -atup2 :: (Arrays a, Arrays b) - => (Acc a, Acc b) - -> Acc (a, b) -atup2 (a, b) - = Acc - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 (Acc e) = - ( aprj1 e - , aprj0 e ) - -unatup3 :: (Arrays a, Arrays b, Arrays c) - => Acc (a, b, c) - -> (Acc a, Acc b, Acc c) -unatup3 (Acc e) = - ( aprj2 e - , aprj1 e - , aprj0 e ) - -unatup4 - :: (Arrays a, Arrays b, Arrays c, Arrays d) - => Acc (a, b, c, d) - -> (Acc a, Acc b, Acc c, Acc d) -unatup4 (Acc e) = - ( aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj7 e - , aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj8 e - , aprj7 e - , aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj9 e - , aprj8 e - , aprj7 e - , aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj10 e - , aprj9 e - , aprj8 e - , aprj7 e - , aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj11 e - , aprj10 e - , aprj9 e - , aprj8 e - , aprj7 e - , aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj12 e - , aprj11 e - , aprj10 e - , aprj9 e - , aprj8 e - , aprj7 e - , aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj13 e - , aprj12 e - , aprj11 e - , aprj10 e - , aprj9 e - , aprj8 e - , aprj7 e - , aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj14 e - , aprj13 e - , aprj12 e - , aprj11 e - , aprj10 e - , aprj9 e - , aprj8 e - , aprj7 e - , aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 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 (Acc e) = - ( aprj15 e - , aprj14 e - , aprj13 e - , aprj12 e - , aprj11 e - , aprj10 e - , aprj9 e - , aprj8 e - , aprj7 e - , aprj6 e - , aprj5 e - , aprj4 e - , aprj3 e - , aprj2 e - , aprj1 e - , aprj0 e ) - - -- Smart constructors for stencils -- ------------------------------- @@ -1361,179 +899,6 @@ 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 -aprjTail :: (Typeable a, Typeable t) => SmartAcc (t, a) -> SmartAcc t -aprjTail = SmartAcc . Aprj PairIdxLeft - -aprj0 :: ( Arrays a, Typeable t) - => SmartAcc (t, ArrRepr a) -> Acc a -aprj0 = Acc . SmartAcc . Aprj PairIdxRight - -aprj1 :: ( Arrays a, Typeable t, Typeable s0) - => SmartAcc ((t, ArrRepr a), s0) -> Acc a -aprj1 = aprj0 . aprjTail - -aprj2 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1) - => SmartAcc (((t, ArrRepr a), s1), s0) -> Acc a -aprj2 = aprj1 . aprjTail - -aprj3 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2) - => SmartAcc ((((t, ArrRepr a), s2), s1), s0) -> Acc a -aprj3 = aprj2 . aprjTail - -aprj4 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3) - => SmartAcc (((((t, ArrRepr a), s3), s2), s1), s0) -> Acc a -aprj4 = aprj3 . aprjTail - -aprj5 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4) - => SmartAcc ((((((t, ArrRepr a), s4), s3), s2), s1), s0) -> Acc a -aprj5 = aprj4 . aprjTail - -aprj6 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5) - => SmartAcc (((((((t, ArrRepr a), s5), s4), s3), s2), s1), s0) -> Acc a -aprj6 = aprj5 . aprjTail - -aprj7 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6) - => SmartAcc ((((((((t, ArrRepr a), s6), s5), s4), s3), s2), s1), s0) -> Acc a -aprj7 = aprj6 . aprjTail - -aprj8 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7) - => SmartAcc (((((((((t, ArrRepr a), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a -aprj8 = aprj7 . aprjTail - -aprj9 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 - , Typeable s8) - => SmartAcc ((((((((((t, ArrRepr a), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a -aprj9 = aprj8 . aprjTail - -aprj10 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 - , Typeable s8, Typeable s9) - => SmartAcc (((((((((((t, ArrRepr a), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a -aprj10 = aprj9 . aprjTail - -aprj11 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 - , Typeable s8, Typeable s9, Typeable s10) - => SmartAcc ((((((((((((t, ArrRepr a), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a -aprj11 = aprj10 . aprjTail - -aprj12 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 - , Typeable s8, Typeable s9, Typeable s10, Typeable s11) - => SmartAcc (((((((((((((t, ArrRepr a), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a -aprj12 = aprj11 . aprjTail - -aprj13 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 - , Typeable s8, Typeable s9, Typeable s10, Typeable s11, Typeable s12) - => SmartAcc ((((((((((((((t, ArrRepr a), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a -aprj13 = aprj12 . aprjTail - -aprj14 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 - , Typeable s8, Typeable s9, Typeable s10, Typeable s11, Typeable s12, Typeable s13) - => SmartAcc (((((((((((((((t, ArrRepr a), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a -aprj14 = aprj13 . aprjTail - -aprj15 :: ( Arrays a, Typeable t, Typeable s0, Typeable s1, Typeable s2, Typeable s3, Typeable s4, Typeable s5, Typeable s6, Typeable s7 - , Typeable s8, Typeable s9, Typeable s10, Typeable s11, Typeable s12, Typeable s13, Typeable s14) - => SmartAcc ((((((((((((((((t, ArrRepr a), s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Acc a -aprj15 = aprj14 . aprjTail -{-- --- 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 -- From 1c97e4b3a803c03d5a526f19d1f710b029552413 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 12 Dec 2019 15:14:37 +0100 Subject: [PATCH 121/316] generate Elt and Arrays instances with TH --- src/Data/Array/Accelerate/Array/Sugar.hs | 68 ++++++------------------ 1 file changed, 15 insertions(+), 53 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 245009516..49a430d10 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -360,31 +360,6 @@ instance Shape sh => Elt (Any (sh:.Int)) where fromElt _ = (fromElt (Any @sh), ()) toElt _ = Any -instance (Elt a, Elt b) => Elt (a, b) -instance (Elt a, Elt b, Elt c) => Elt (a, b, c) -instance (Elt a, Elt b, Elt c, Elt d) => Elt (a, b, c, d) -instance (Elt a, Elt b, Elt c, Elt d, Elt e) => Elt (a, b, c, d, e) -instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) => Elt (a, b, c, d, e, f) -instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g) - => Elt (a, b, c, d, e, f, 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) -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) -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) -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) -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) -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) -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) -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) -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) -- Convenience functions -- @@ -570,34 +545,6 @@ instance (Shape sh, Elt e) => Arrays (Array sh e) where fromArr = id toArr = id -instance (Arrays a, Arrays b) => Arrays (a, b) -instance (Arrays a, Arrays b, Arrays c) => Arrays (a, b, c) -instance (Arrays a, Arrays b, Arrays c, Arrays d) => Arrays (a, b, c, d) -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e) => Arrays (a, b, c, d, e) -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f) - => Arrays (a, b, c, d, e, f) -instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g) - => Arrays (a, b, c, d, e, f, 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) -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) -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) -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) -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) -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) -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) -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) -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) - - -- Array type reification -- data ArraysR arrs where @@ -1261,3 +1208,18 @@ $( runQ $ do return (concat ss ++ concat vs ++ concat ns) ) +$(runQ $ do + let + mkInstance :: TypeQ -> Int -> Q [Dec] + mkInstance cst n = + let + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + res = foldl (\ts t -> [t| $ts $(varT t) |]) (tupleT n) xs + ctx = foldl (\ts t -> [t| $ts ($cst $(varT t)) |]) (tupleT n) xs + in + [d| instance $ctx => $cst $res |] + -- + es <- mapM (mkInstance [t| Elt |]) [2..16] + as <- mapM (mkInstance [t| Arrays |]) [2..16] + return $ concat (es ++ as) + ) From 30274553d051d022e287ff18a5c3ed07db68b674 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 12 Dec 2019 16:21:07 +0100 Subject: [PATCH 122/316] generate IsProduct instances with TH --- src/Data/Array/Accelerate/Product.hs | 149 +++++---------------------- 1 file changed, 25 insertions(+), 124 deletions(-) diff --git a/src/Data/Array/Accelerate/Product.hs b/src/Data/Array/Accelerate/Product.hs index 320bd29b9..b7e4f925e 100644 --- a/src/Data/Array/Accelerate/Product.hs +++ b/src/Data/Array/Accelerate/Product.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -35,6 +36,7 @@ module Data.Array.Accelerate.Product ( import GHC.Generics import Data.Primitive.Types +import Language.Haskell.TH import Data.Array.Accelerate.Type @@ -128,130 +130,6 @@ instance IsProduct cst () where 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 = ProdRsnoc (prod @cst @(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 = ProdRsnoc (prod @cst @(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 = ProdRsnoc (prod @cst @(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 = ProdRsnoc (prod @cst @(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 = ProdRsnoc (prod @cst @(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 = ProdRsnoc (prod @cst @(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 - = ProdRsnoc (prod @cst @(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 - = ProdRsnoc (prod @cst @(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 - = ProdRsnoc (prod @cst @(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 - = ProdRsnoc (prod @cst @(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 - = ProdRsnoc (prod @cst @(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 - = ProdRsnoc (prod @cst @(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 - = ProdRsnoc (prod @cst @(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 - = ProdRsnoc (prod @cst @(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) - instance (Prim a, cst a) => IsProduct cst (V2 a) where type ProdRepr (V2 a) = (((), a), a) fromProd (V2 a b) = (((), a), b) @@ -287,3 +165,26 @@ instance (Prim a, cst a) => IsProduct cst (V16 a) where prod = prod @cst @(a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a) +$(runQ $ do + let + mkIsProduct :: Int -> Q [Dec] + mkIsProduct n = do + cst <- newName "cst" + let + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + lhs = foldl (\ts t -> [t| $ts ($(varT cst) $(varT t)) |]) (tupleT n) xs + flat = foldl (\ts t -> [t| $ts $(varT t) |]) (tupleT n) xs + -- + prod' 0 = [| ProdRunit |] + prod' i = [| ProdRsnoc $(prod' (i-1)) |] + -- + [d| instance $lhs => IsProduct $(varT cst) $flat where + type ProdRepr $flat = $(foldl (\ts t -> [t| ($ts, $(varT t)) |]) [t| () |] xs) + fromProd $(tupP (map varP xs)) = $(foldl (\vs v -> [| ($vs, $(varE v)) |]) [|()|] xs) + toProd $(foldl (\ps p -> tupP [ps, varP p]) (tupP []) xs) = $(tupE (map varE xs)) + prod = $(prod' n) + |] + + concat <$> mapM mkIsProduct [2..16] + ) + From 49044a416f135f10c6223b25aafe89666945ec37 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 12 Dec 2019 18:47:00 +0100 Subject: [PATCH 123/316] generate Tx and Ix patterns with TH --- src/Data/Array/Accelerate/Pattern.hs | 248 +++++++-------------------- 1 file changed, 58 insertions(+), 190 deletions(-) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 4645ca36e..502c79483 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -72,196 +72,6 @@ pattern Ix :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) pattern a `Ix` b = a ::. b {-# COMPLETE Ix #-} -pattern I0 :: Exp DIM0 -pattern I0 = Z_ -{-# COMPLETE I0 #-} - -pattern I1 :: Elt a => Exp a -> Exp (Z :. a) -pattern I1 a = Z_ `Ix` a -{-# COMPLETE I1 #-} - -pattern I2 :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (Z :. a :. b) -pattern I2 a b = Z_ `Ix` a `Ix` b -{-# COMPLETE I2 #-} - -pattern I3 - :: (Elt a, Elt b, Elt c) - => Exp a -> Exp b -> Exp c - -> Exp (Z :. a :. b :. c) -pattern I3 a b c = Z_ `Ix` a `Ix` b `Ix` c -{-# COMPLETE I3 #-} - -pattern I4 - :: (Elt a, Elt b, Elt c, Elt d) - => Exp a -> Exp b -> Exp c -> Exp d - -> Exp (Z :. a :. b :. c :. d) -pattern I4 a b c d = Z_ `Ix` a `Ix` b `Ix` c `Ix` d -{-# COMPLETE I4 #-} - -pattern I5 - :: (Elt a, Elt b, Elt c, Elt d, Elt e) - => Exp a -> Exp b -> Exp c -> Exp d -> Exp e - -> Exp (Z :. a :. b :. c :. d :. e) -pattern I5 a b c d e = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e -{-# COMPLETE I5 #-} - -pattern I6 - :: (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 (Z :. a :. b :. c :. d :. e :. f) -pattern I6 a b c d e f = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e `Ix` f -{-# COMPLETE I6 #-} - -pattern I7 - :: (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 (Z :. a :. b :. c :. d :. e :. f :. g) -pattern I7 a b c d e f g = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e `Ix` f `Ix` g -{-# COMPLETE I7 #-} - -pattern I8 - :: (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 (Z :. a :. b :. c :. d :. e :. f :. g :. h) -pattern I8 a b c d e f g h = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e `Ix` f `Ix` g `Ix` h -{-# COMPLETE I8 #-} - -pattern I9 - :: (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 (Z :. a :. b :. c :. d :. e :. f :. g :. h :. i) -pattern I9 a b c d e f g h i = Z_ `Ix` a `Ix` b `Ix` c `Ix` d `Ix` e `Ix` f `Ix` g `Ix` h `Ix` i -{-# COMPLETE I9 #-} - - --- | Specialised pattern synonyms for tuples, which may be more convenient to --- use than 'Data.Array.Accelerate.Lift.lift' and --- 'Data.Array.Accelerate.Lift.unlift'. For example, to construct a pair: --- --- > let a = 4 :: Exp Int --- > let b = 2 :: Exp Float --- > let c = T2 a b -- :: Exp (Int, Float); equivalent to 'lift (a,b)' --- --- Similarly they can be used to destruct values: --- --- > let T2 x y = c -- x :: Exp Int, y :: Exp Float; equivalent to 'let (x,y) = unlift c' --- --- These pattern synonyms can be used for both 'Exp' and 'Acc' terms. --- -pattern T2 :: IsPattern con (a,b) (con a, con b) => con a -> con b -> con (a, b) -pattern T2 a b = Pattern (a, b) -{-# COMPLETE T2 :: Exp #-} -{-# COMPLETE T2 :: Acc #-} - -pattern T3 :: IsPattern con (a,b,c) (con a, con b, con c) => con a -> con b -> con c -> con (a, b, c) -pattern T3 a b c = Pattern (a, b, c) -{-# COMPLETE T3 :: Exp #-} -{-# COMPLETE T3 :: Acc #-} - -pattern T4 - :: IsPattern con (a,b,c,d) (con a, con b, con c, con d) - => con a -> con b -> con c -> con d - -> con (a, b, c, d) -pattern T4 a b c d = Pattern (a, b, c, d) -{-# COMPLETE T4 :: Exp #-} -{-# COMPLETE T4 :: Acc #-} - -pattern T5 - :: IsPattern con (a,b,c,d,e) (con a, con b, con c, con d, con e) - => con a -> con b -> con c -> con d -> con e - -> con (a, b, c, d, e) -pattern T5 a b c d e = Pattern (a, b, c, d, e) -{-# COMPLETE T5 :: Exp #-} -{-# COMPLETE T5 :: Acc #-} - -pattern T6 - :: IsPattern con (a,b,c,d,e,f) (con a, con b, con c, con d, con e, con f) - => con a -> con b -> con c -> con d -> con e -> con f - -> con (a, b, c, d, e, f) -pattern T6 a b c d e f = Pattern (a, b, c, d, e, f) -{-# COMPLETE T6 :: Exp #-} -{-# COMPLETE T6 :: Acc #-} - -pattern T7 - :: IsPattern con (a,b,c,d,e,f,g) (con a, con b, con c, con d, con e, con f, con g) - => con a -> con b -> con c -> con d -> con e -> con f -> con g - -> con (a, b, c, d, e, f, g) -pattern T7 a b c d e f g = Pattern (a, b, c, d, e, f, g) -{-# COMPLETE T7 :: Exp #-} -{-# COMPLETE T7 :: Acc #-} - -pattern T8 - :: IsPattern con (a,b,c,d,e,f,g,h) (con a, con b, con c, con d, con e, con f, con g, con h) - => con a -> con b -> con c -> con d -> con e -> con f -> con g -> con h - -> con (a, b, c, d, e, f, g, h) -pattern T8 a b c d e f g h = Pattern (a, b, c, d, e, f, g, h) -{-# COMPLETE T8 :: Exp #-} -{-# COMPLETE T8 :: Acc #-} - -pattern T9 - :: IsPattern con (a,b,c,d,e,f,g,h,i) (con a, con b, con c, con d, con e, con f, con g, con h, con i) - => con a -> con b -> con c -> con d -> con e -> con f -> con g -> con h -> con i - -> con (a, b, c, d, e, f, g, h, i) -pattern T9 a b c d e f g h i = Pattern (a, b, c, d, e, f, g, h, i) -{-# COMPLETE T9 :: Exp #-} -{-# COMPLETE T9 :: Acc #-} - -pattern T10 - :: IsPattern con (a,b,c,d,e,f,g,h,i,j) (con a, con b, con c, con d, con e, con f, con g, con h, con i, con j) - => con a -> con b -> con c -> con d -> con e -> con f -> con g -> con h -> con i -> con j - -> con (a, b, c, d, e, f, g, h, i, j) -pattern T10 a b c d e f g h i j = Pattern (a, b, c, d, e, f, g, h, i, j) -{-# COMPLETE T10 :: Exp #-} -{-# COMPLETE T10 :: Acc #-} - -pattern T11 - :: IsPattern con (a,b,c,d,e,f,g,h,i,j,k) (con a, con b, con c, con d, con e, con f, con g, con h, con i, con j, con k) - => con a -> con b -> con c -> con d -> con e -> con f -> con g -> con h -> con i -> con j -> con k - -> con (a, b, c, d, e, f, g, h, i, j, k) -pattern T11 a b c d e f g h i j k = Pattern (a, b, c, d, e, f, g, h, i, j, k) -{-# COMPLETE T11 :: Exp #-} -{-# COMPLETE T11 :: Acc #-} - -pattern T12 - :: IsPattern con (a,b,c,d,e,f,g,h,i,j,k,l) (con a, con b, con c, con d, con e, con f, con g, con h, con i, con j, con k, con l) - => con a -> con b -> con c -> con d -> con e -> con f -> con g -> con h -> con i -> con j -> con k -> con l - -> con (a, b, c, d, e, f, g, h, i, j, k, l) -pattern T12 a b c d e f g h i j k l = Pattern (a, b, c, d, e, f, g, h, i, j, k, l) -{-# COMPLETE T12 :: Exp #-} -{-# COMPLETE T12 :: Acc #-} - -pattern T13 - :: IsPattern con (a,b,c,d,e,f,g,h,i,j,k,l,m) (con a, con b, con c, con d, con e, con f, con g, con h, con i, con j, con k, con l, con m) - => con a -> con b -> con c -> con d -> con e -> con f -> con g -> con h -> con i -> con j -> con k -> con l -> con m - -> con (a, b, c, d, e, f, g, h, i, j, k, l, m) -pattern T13 a b c d e f g h i j k l m = Pattern (a, b, c, d, e, f, g, h, i, j, k, l, m) -{-# COMPLETE T13 :: Exp #-} -{-# COMPLETE T13 :: Acc #-} - -pattern T14 - :: IsPattern con (a,b,c,d,e,f,g,h,i,j,k,l,m,n) (con a, con b, con c, con d, con e, con f, con g, con h, con i, con j, con k, con l, con m, con n) - => con a -> con b -> con c -> con d -> con e -> con f -> con g -> con h -> con i -> con j -> con k -> con l -> con m -> con n - -> con (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -pattern T14 a b c d e f g h i j k l m n = Pattern (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -{-# COMPLETE T14 :: Exp #-} -{-# COMPLETE T14 :: Acc #-} - -pattern T15 - :: IsPattern con (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) (con a, con b, con c, con d, con e, con f, con g, con h, con i, con j, con k, con l, con m, con n, con o) - => con a -> con b -> con c -> con d -> con e -> con f -> con g -> con h -> con i -> con j -> con k -> con l -> con m -> con n -> con o - -> con (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -pattern T15 a b c d e f g h i j k l m n o = Pattern (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -{-# COMPLETE T15 :: Exp #-} -{-# COMPLETE T15 :: Acc #-} - -pattern T16 - :: IsPattern con (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) (con a, con b, con c, con d, con e, con f, con g, con h, con i, con j, con k, con l, con m, con n, con o, con p) - => con a -> con b -> con c -> con d -> con e -> con f -> con g -> con h -> con i -> con j -> con k -> con l -> con m -> con n -> con o -> con p - -> con (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -pattern T16 a b c d e f g h i j k l m n o p = Pattern (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -{-# COMPLETE T16 :: Exp #-} -{-# COMPLETE T16 :: Acc #-} - -- IsPattern instances for Shape nil and cons -- instance IsPattern Exp Z Z where @@ -328,3 +138,61 @@ $(runQ $ do return $ concat (es ++ as) ) +-- | Specialised pattern synonyms for tuples, which may be more convenient to +-- use than 'Data.Array.Accelerate.Lift.lift' and +-- 'Data.Array.Accelerate.Lift.unlift'. For example, to construct a pair: +-- +-- > let a = 4 :: Exp Int +-- > let b = 2 :: Exp Float +-- > let c = T2 a b -- :: Exp (Int, Float); equivalent to 'lift (a,b)' +-- +-- Similarly they can be used to destruct values: +-- +-- > let T2 x y = c -- x :: Exp Int, y :: Exp Float; equivalent to 'let (x,y) = unlift c' +-- +-- These pattern synonyms can be used for both 'Exp' and 'Acc' terms. +-- +-- Similarly, we have patterns for constructing and destructing indices of +-- a given dimensionality: +-- +-- > let ix = Ix 2 3 -- :: Exp DIM2 +-- > let I2 y x = ix -- y :: Exp Int, x :: Exp Int +-- +$(runQ $ do + let + mkT :: Int -> Q [Dec] + mkT n = + let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + name = mkName ('T':show n) + con = varT (mkName "con") + ty1 = foldl (\ts t -> [t| $ts $(varT t) |]) (tupleT n) xs + ty2 = foldl (\ts t -> [t| $ts ($con $(varT t)) |]) (tupleT n) xs + sig = foldr (\t ts -> [t| $con $(varT t) -> $ts |]) [t| $con $ty1 |] xs + in + sequence + [ patSynSigD name [t| IsPattern $con $ty1 $ty2 => $sig |] + , patSynD name (prefixPatSyn xs) implBidir [p| Pattern $(tupP (map varP xs)) |] + , pragCompleteD [name] (Just (mkName "Acc")) + , pragCompleteD [name] (Just (mkName "Exp")) + ] + + mkI :: Int -> Q [Dec] + mkI n = + let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + name = mkName ('I':show n) + ix = mkName "Ix" + cst = foldl (\ts t -> [t| $ts (Elt $(varT t)) |]) (tupleT n) xs + dim = foldl (\ts t -> [t| $ts :. $(varT t) |]) [t| Z |] xs + sig = foldr (\t ts -> [t| Exp $(varT t) -> $ts |]) [t| Exp $dim |] xs + in + sequence + [ patSynSigD name [t| $cst => $sig |] + , patSynD name (prefixPatSyn xs) implBidir (foldl (\ps p -> infixP ps ix (varP p)) [p| Z_ |] xs) + , pragCompleteD [name] Nothing + ] + -- + ts <- mapM mkT [2..16] + is <- mapM mkI [0..9] + return $ concat (ts ++ is) + ) + From 5f8dcbd1cabd8ea889f4983dbaa7f3b96bb33224 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 12 Dec 2019 21:00:10 +0100 Subject: [PATCH 124/316] wibble --- src/Data/Array/Accelerate/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 502c79483..4b3d76a7a 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -172,8 +172,8 @@ $(runQ $ do sequence [ patSynSigD name [t| IsPattern $con $ty1 $ty2 => $sig |] , patSynD name (prefixPatSyn xs) implBidir [p| Pattern $(tupP (map varP xs)) |] - , pragCompleteD [name] (Just (mkName "Acc")) - , pragCompleteD [name] (Just (mkName "Exp")) + , pragCompleteD [name] (Just ''Acc) + , pragCompleteD [name] (Just ''Exp) ] mkI :: Int -> Q [Dec] From fcaaaa54e2602d3faaeb9704dce62d8a1b161f74 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 12 Dec 2019 21:00:31 +0100 Subject: [PATCH 125/316] generate Eq instances with TH --- accelerate.cabal | 2 + src/Data/Array/Accelerate/Classes/Eq.hs | 322 +++++++----------------- src/Language/Haskell/TH/Extra.hs | 22 ++ 3 files changed, 112 insertions(+), 234 deletions(-) create mode 100644 src/Language/Haskell/TH/Extra.hs diff --git a/accelerate.cabal b/accelerate.cabal index aba3dd8ed..f28f417cd 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -394,6 +394,8 @@ Library Data.Array.Accelerate.Test.NoFib.Base Data.Array.Accelerate.Test.NoFib.Config + Language.Haskell.TH.Extra + if flag(nofib) build-depends: tasty-expected-failure >= 0.11 diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 276f77f28..2b336a5ff 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -23,11 +25,14 @@ module Data.Array.Accelerate.Classes.Eq ( ) where import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type import Text.Printf -import Prelude ( String, error) +import Prelude ( ($), String, Num(..), show, error, return, concat, map, zipWith, foldr1, mapM ) +import Language.Haskell.TH hiding ( Exp ) +import Language.Haskell.TH.Extra import qualified Prelude as P @@ -72,118 +77,6 @@ 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 - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CUInt where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CLong where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CULong where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CLLong where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CULLong where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CShort where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CUShort where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq Bool where - (==) = mkEq - (/=) = mkNEq - -instance Eq Char where - (==) = mkEq - (/=) = mkNEq - -instance Eq CChar where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CUChar where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CSChar where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq Half where - (==) = mkEq - (/=) = mkNEq - -instance Eq Float where - (==) = mkEq - (/=) = mkNEq - -instance Eq Double where - (==) = mkEq - (/=) = mkNEq - -instance Eq CFloat where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - -instance Eq CDouble where - (==) = lift2 mkEq - (/=) = lift2 mkNEq - instance Eq Z where (==) _ _ = constant True (/=) _ _ = constant False @@ -192,127 +85,6 @@ instance Eq sh => Eq (sh :. Int) where x == y = indexHead x == indexHead y && indexTail x == indexTail y x /= y = indexHead x /= indexHead y || indexTail x /= indexTail y -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. @@ -331,3 +103,85 @@ lift2 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) -> Exp Bool lift2 f x y = f (mkUnsafeCoerce x) (mkUnsafeCoerce y) +$(runQ $ do + let + integralTypes :: [Name] + integralTypes = + [ ''Int + , ''Int8 + , ''Int16 + , ''Int32 + , ''Int64 + , ''Word + , ''Word8 + , ''Word16 + , ''Word32 + , ''Word64 + ] + + floatingTypes :: [Name] + floatingTypes = + [ ''Half + , ''Float + , ''Double + ] + + nonNumTypes :: [Name] + nonNumTypes = + [ ''Bool + , ''Char + ] + + cTypes :: [Name] + cTypes = + [ ''CInt + , ''CUInt + , ''CLong + , ''CULong + , ''CLLong + , ''CULLong + , ''CShort + , ''CUShort + , ''CChar + , ''CUChar + , ''CSChar + , ''CFloat + , ''CDouble + ] + + mkPrim :: Name -> Q [Dec] + mkPrim t = + [d| instance Eq $(conT t) where + (==) = mkEq + (/=) = mkNEq + |] + + mkCPrim :: Name -> Q [Dec] + mkCPrim t = + [d| instance Eq $(conT t) where + (==) = lift2 mkEq + (/=) = lift2 mkNEq + |] + + mkTup :: Int -> Q [Dec] + mkTup n = + let + xs = [ mkName ('x':show i) | i <- [0 .. n-1] ] + ys = [ mkName ('y':show i) | i <- [0 .. n-1] ] + cst = tupT (map (\x -> [t| Eq $(varT x) |]) xs) + res = tupT (map varT xs) + pat vs = conP (mkName ('T':show n)) (map varP vs) + in + [d| instance ($cst) => Eq $res where + $(pat xs) == $(pat ys) = $(foldr1 (\vs v -> [| $vs && $v |]) (zipWith (\x y -> [| $x == $y |]) (map varE xs) (map varE ys))) + $(pat xs) /= $(pat ys) = $(foldr1 (\vs v -> [| $vs || $v |]) (zipWith (\x y -> [| $x /= $y |]) (map varE xs) (map varE ys))) + |] + + is <- mapM mkPrim integralTypes + fs <- mapM mkPrim floatingTypes + ns <- mapM mkPrim nonNumTypes + cs <- mapM mkCPrim cTypes + ts <- mapM mkTup [2..16] + return $ concat (concat [is,fs,ns,cs,ts]) + ) + diff --git a/src/Language/Haskell/TH/Extra.hs b/src/Language/Haskell/TH/Extra.hs new file mode 100644 index 000000000..3ccb0a4f7 --- /dev/null +++ b/src/Language/Haskell/TH/Extra.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Language.Haskell.TH.Extra +-- Copyright : [2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Language.Haskell.TH.Extra + where + +import Language.Haskell.TH + + +tupT :: [TypeQ] -> TypeQ +tupT ts = + let n = length ts + in foldl (\ts t -> [t| $ts $t |]) (tupleT n) ts + From 91ffc390e32dfa2036c4fe0ae783577a62868865 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 12 Dec 2019 22:46:10 +0100 Subject: [PATCH 126/316] build fix --- src/Data/Array/Accelerate/Array/Sugar.hs | 11 ++++++----- src/Data/Array/Accelerate/Type.hs | 2 +- src/Language/Haskell/TH/Extra.hs | 6 +++--- 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 49a430d10..e04c58fd2 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -1104,7 +1104,7 @@ enumSlices slix = map toElt . Repr.enumSlices slix . fromElt -- Instances -- --------- -$( runQ $ do +$(runQ $ do let -- XXX: we might want to do the digItOut trick used by FromIntegral? -- @@ -1210,16 +1210,17 @@ $( runQ $ do $(runQ $ do let - mkInstance :: TypeQ -> Int -> Q [Dec] + mkInstance :: TypeQ -> Int -> Q Dec mkInstance cst n = let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] res = foldl (\ts t -> [t| $ts $(varT t) |]) (tupleT n) xs - ctx = foldl (\ts t -> [t| $ts ($cst $(varT t)) |]) (tupleT n) xs + ctx = mapM (\x -> [t| $cst $(varT x) |]) xs in - [d| instance $ctx => $cst $res |] + instanceD ctx [t| $cst $res |] [] -- es <- mapM (mkInstance [t| Elt |]) [2..16] as <- mapM (mkInstance [t| Arrays |]) [2..16] - return $ concat (es ++ as) + return (es ++ as) ) + diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index f7d09c80d..869263a25 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -533,7 +533,7 @@ packV16 a b c d e f g h i j k l m n o p = runST $ do -- to split this into a separate module. -- -$( runQ $ do +$(runQ $ do let bits :: FiniteBits b => b -> Integer bits = toInteger . finiteBitSize diff --git a/src/Language/Haskell/TH/Extra.hs b/src/Language/Haskell/TH/Extra.hs index 3ccb0a4f7..b115540cc 100644 --- a/src/Language/Haskell/TH/Extra.hs +++ b/src/Language/Haskell/TH/Extra.hs @@ -16,7 +16,7 @@ import Language.Haskell.TH tupT :: [TypeQ] -> TypeQ -tupT ts = - let n = length ts - in foldl (\ts t -> [t| $ts $t |]) (tupleT n) ts +tupT tup = + let n = length tup + in foldl (\ts t -> [t| $ts $t |]) (tupleT n) tup From 2fe91219d6ecf7f4d9f9d0a6300822156ccf9c7e Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 13 Dec 2019 11:22:48 +0100 Subject: [PATCH 127/316] generate Ord instances with TH --- src/Data/Array/Accelerate/Classes/Ord.hs | 540 +++++------------------ 1 file changed, 118 insertions(+), 422 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 095615a8d..95c8e4ac1 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -25,13 +27,16 @@ module Data.Array.Accelerate.Classes.Ord ( import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Eq import Text.Printf -import Prelude ( ($), (.), Ordering(..), Maybe(..), String, error, unlines ) +import Prelude ( ($), (.), (>>=), Ordering(..), Num(..), Maybe(..), String, show, error, unlines, return, concat, map, mapM ) +import Language.Haskell.TH hiding ( Exp ) +import Language.Haskell.TH.Extra import qualified Prelude as P @@ -79,230 +84,6 @@ instance Ord () where 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 - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CUInt where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CLong where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CULong where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CLLong where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CULLong where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CShort where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CUShort where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 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 - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CUChar where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CSChar where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 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 - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - -instance Ord CDouble where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax - instance Ord Z where (<) _ _ = constant False (>) _ _ = constant False @@ -323,203 +104,6 @@ instance Ord sh => Ord (sh :. Int) where Just Refl -> constant True Nothing -> indexTail x > indexTail y -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') - - instance Elt Ordering where type EltRepr Ordering = Int8 eltType = TypeRscalar scalarType @@ -579,3 +163,115 @@ liftB :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) -> Exp Bool liftB f x y = f (mkUnsafeCoerce x) (mkUnsafeCoerce y) +$(runQ $ do + let + integralTypes :: [Name] + integralTypes = + [ ''Int + , ''Int8 + , ''Int16 + , ''Int32 + , ''Int64 + , ''Word + , ''Word8 + , ''Word16 + , ''Word32 + , ''Word64 + ] + + floatingTypes :: [Name] + floatingTypes = + [ ''Half + , ''Float + , ''Double + ] + + nonNumTypes :: [Name] + nonNumTypes = + [ ''Bool + , ''Char + ] + + cTypes :: [Name] + cTypes = + [ ''CInt + , ''CUInt + , ''CLong + , ''CULong + , ''CLLong + , ''CULLong + , ''CShort + , ''CUShort + , ''CChar + , ''CUChar + , ''CSChar + , ''CFloat + , ''CDouble + ] + + mkPrim :: Name -> Q [Dec] + mkPrim t = + [d| instance Ord $(conT t) where + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax + |] + + mkCPrim :: Name -> Q [Dec] + mkCPrim t = + [d| instance Ord $(conT t) where + (<) = liftB mkLt + (>) = liftB mkGt + (<=) = liftB mkLtEq + (>=) = liftB mkGtEq + min = lift2 mkMin + max = lift2 mkMax + |] + + mkLt' :: [ExpQ] -> [ExpQ] -> ExpQ + mkLt' [x] [y] = [| $x < $y |] + mkLt' (x:xs) (y:ys) = [| $x < $y || ( $x == $y && $(mkLt' xs ys) ) |] + mkLt' _ _ = error "mkLt'" + + mkGt' :: [ExpQ] -> [ExpQ] -> ExpQ + mkGt' [x] [y] = [| $x > $y |] + mkGt' (x:xs) (y:ys) = [| $x > $y || ( $x == $y && $(mkGt' xs ys) ) |] + mkGt' _ _ = error "mkGt'" + + mkLtEq' :: [ExpQ] -> [ExpQ] -> ExpQ + mkLtEq' [x] [y] = [| $x < $y |] + mkLtEq' (x:xs) (y:ys) = [| $x < $y || ( $x == $y && $(mkLtEq' xs ys) ) |] + mkLtEq' _ _ = error "mkLtEq'" + + mkGtEq' :: [ExpQ] -> [ExpQ] -> ExpQ + mkGtEq' [x] [y] = [| $x > $y |] + mkGtEq' (x:xs) (y:ys) = [| $x > $y || ( $x == $y && $(mkGtEq' xs ys) ) |] + mkGtEq' _ _ = error "mkGtEq'" + + mkTup :: Int -> Q [Dec] + mkTup n = + let + xs = [ mkName ('x':show i) | i <- [0 .. n-1] ] + ys = [ mkName ('y':show i) | i <- [0 .. n-1] ] + cst = tupT (map (\x -> [t| Ord $(varT x) |]) xs) + res = tupT (map varT xs) + pat vs = conP (mkName ('T':show n)) (map varP vs) + in + [d| instance $cst => Ord $res where + $(pat xs) < $(pat ys) = $( mkLt' (map varE xs) (map varE ys) ) + $(pat xs) > $(pat ys) = $( mkGt' (map varE xs) (map varE ys) ) + $(pat xs) >= $(pat ys) = $( mkGtEq' (map varE xs) (map varE ys) ) + $(pat xs) <= $(pat ys) = $( mkLtEq' (map varE xs) (map varE ys) ) + |] + + is <- mapM mkPrim integralTypes + fs <- mapM mkPrim floatingTypes + ns <- mapM mkPrim nonNumTypes + cs <- mapM mkCPrim cTypes + ts <- mapM mkTup [2..16] + return $ concat (concat [is,fs,ns,cs,ts]) + ) + From 9aa7b0ff618b31a5ba9bcfbce9fc67626c1e1561 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 13 Dec 2019 11:23:00 +0100 Subject: [PATCH 128/316] stack/8.8: update resolver --- stack-8.8.yaml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/stack-8.8.yaml b/stack-8.8.yaml index 7132fea0e..f39de92cd 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -1,14 +1,12 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: nightly-2019-09-26 +resolver: nightly-2019-12-13 packages: - . -extra-deps: -- prettyprinter-1.3.0 -- prettyprinter-ansi-terminal-1.1.1.2 +# extra-deps: [] # Override default flag values for local packages and extra-deps # flags: {} From 3d8fee277e0e211a0e1e5c1f38385478dab741e6 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 13 Dec 2019 11:26:11 +0100 Subject: [PATCH 129/316] drop ghc-8.0 --- .travis.yml | 3 --- accelerate.cabal | 10 +++++----- stack-8.0.yaml | 36 ------------------------------------ 3 files changed, 5 insertions(+), 44 deletions(-) delete mode 100644 stack-8.0.yaml diff --git a/.travis.yml b/.travis.yml index 3679c1697..07f1d0373 100644 --- a/.travis.yml +++ b/.travis.yml @@ -40,9 +40,6 @@ matrix: - env: GHC=8.2.2 compiler: "GHC 8.2" - - env: GHC=8.0.2 - compiler: "GHC 8.0" - allow_failures: - env: GHC=8.8.1 # not enough memory \: diff --git a/accelerate.cabal b/accelerate.cabal index f28f417cd..64aec140c 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -1,7 +1,7 @@ Name: accelerate Version: 1.4.0.0 Cabal-version: >= 1.18 -Tested-with: GHC >= 7.10 +Tested-with: GHC >= 8.2 Build-type: Custom Synopsis: An embedded language for accelerated array processing @@ -131,7 +131,7 @@ Extra-doc-files: custom-setup setup-depends: - base >= 4.7 + base >= 4.10 , Cabal , cabal-doctest >= 1.0 @@ -268,7 +268,7 @@ Flag nofib Library Build-depends: - base >= 4.9 && < 4.14 + base >= 4.10 && < 4.14 , ansi-terminal >= 0.6.2 , base-orphans >= 0.3 , bytestring >= 0.10.2 @@ -544,7 +544,7 @@ test-suite doctest main-is: Main.hs build-depends: - base >= 4.9 + base >= 4.10 , accelerate , doctest >= 0.11 @@ -568,7 +568,7 @@ test-suite nofib-interpreter buildable: False build-depends: - base >= 4.9 + base >= 4.10 , accelerate ghc-options: diff --git a/stack-8.0.yaml b/stack-8.0.yaml deleted file mode 100644 index 5aed69f5d..000000000 --- a/stack-8.0.yaml +++ /dev/null @@ -1,36 +0,0 @@ -# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md -# vim: nospell - -resolver: lts-9.21 - -packages: -- . - -extra-deps: -- half-0.3 -- hashtables-1.2.3.0 -- prettyprinter-1.2.1 -- primitive-0.6.4.0 -- tasty-hedgehog-0.2.0.0 - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true - -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: >= 0.1.4.0 - -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 - -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] - From d2f0131212d5e548e0870656b56d4e92cc1e7547 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 13 Dec 2019 11:26:19 +0100 Subject: [PATCH 130/316] =?UTF-8?q?travis:=20=E2=80=94fast?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 07f1d0373..274c6f71e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -57,7 +57,7 @@ before_install: - stack --version install: - - export FLAGS="--no-terminal --no-copy-bins --flag accelerate:nofib" + - export FLAGS="--fast --no-terminal --no-copy-bins --flag accelerate:nofib" - travis_retry stack build $FLAGS --only-dependencies --test script: From 7c300b0fc55bba16dcf48f1c0662603913f9a99f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 13 Dec 2019 11:38:39 +0100 Subject: [PATCH 131/316] appveyor: drop ghc-8.0 --- .appveyor.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.appveyor.yml b/.appveyor.yml index f5ffb28cc..147dccc08 100644 --- a/.appveyor.yml +++ b/.appveyor.yml @@ -12,7 +12,6 @@ environment: - GHC: "8.6" - GHC: "8.4" - GHC: "8.2" - - GHC: "8.0" before_build: # http://help.appveyor.com/discussions/problems/6312-curl-command-not-found From 155e17c5b26c3cbc0df8f8337727e26836ccd0fb Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 13 Dec 2019 11:48:49 +0100 Subject: [PATCH 132/316] align --- src/Data/Array/Accelerate/Smart.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 733c17d62..0eddf517f 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -347,11 +347,11 @@ data PreSmartAcc acc exp as where Replicate :: (Slice slix, Elt e) => exp slix - -> acc (Array (SliceShape slix) e) + -> acc (Array (SliceShape slix) e) -> PreSmartAcc acc exp (Array (FullShape slix) e) Slice :: (Slice slix, Elt e) - => acc (Array (FullShape slix) e) + => acc (Array (FullShape slix) e) -> exp slix -> PreSmartAcc acc exp (Array (SliceShape slix) e) From 2814670f44bf947d0b0d6b9d40ae9b6240c95b3d Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 13 Dec 2019 11:50:56 +0100 Subject: [PATCH 133/316] ci: require ghc-8.8 --- .appveyor.yml | 1 + .travis.yml | 3 --- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/.appveyor.yml b/.appveyor.yml index 147dccc08..15de0579f 100644 --- a/.appveyor.yml +++ b/.appveyor.yml @@ -9,6 +9,7 @@ environment: global: STACK_ROOT: "c:\\sr" matrix: + - GHC: "8.8" - GHC: "8.6" - GHC: "8.4" - GHC: "8.2" diff --git a/.travis.yml b/.travis.yml index 274c6f71e..cb85fc081 100644 --- a/.travis.yml +++ b/.travis.yml @@ -40,9 +40,6 @@ matrix: - env: GHC=8.2.2 compiler: "GHC 8.2" - allow_failures: - - env: GHC=8.8.1 # not enough memory \: - before_install: - export PATH=/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:${PATH} - source .travis/install-stack.sh From 90ff6ab85df71f0a02c7a8d30a4013a5bb2d41fd Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 13 Dec 2019 13:57:29 +0100 Subject: [PATCH 134/316] warning police --- src/Data/Array/Accelerate/Trafo/Substitution.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 336859925..6e6991127 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -467,8 +467,8 @@ instance SyntacticAcc PreOpenAcc where accOut = id weakenAcc k = runIdentity . rebuildPreOpenAcc k (Identity . weakenAcc k . IA) -type RebuildAvar f (fa :: (* -> * -> *) -> * -> * -> *) acc aenv aenv' = - forall sh e. ArrayVar aenv (Array sh e) -> f (fa acc aenv' (Array sh e)) +type RebuildAvar f (fa :: (Type -> Type -> Type) -> Type -> Type -> Type) acc aenv aenv' + = forall sh e. ArrayVar aenv (Array sh e) -> f (fa acc aenv' (Array sh e)) {-# INLINEABLE shiftA #-} shiftA From 04099138e20d40cc2b44a84071108322fbb1bfec Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 15 Dec 2019 15:15:20 +0100 Subject: [PATCH 135/316] generate Bounded instances with TH --- src/Data/Array/Accelerate/Classes/Bounded.hs | 96 +++++--------------- 1 file changed, 22 insertions(+), 74 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/Bounded.hs b/src/Data/Array/Accelerate/Classes/Bounded.hs index efc511872..187cf0150 100644 --- a/src/Data/Array/Accelerate/Classes/Bounded.hs +++ b/src/Data/Array/Accelerate/Classes/Bounded.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | @@ -22,9 +23,13 @@ module Data.Array.Accelerate.Classes.Bounded ( import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type +import Prelude ( ($), (<$>), Num(..), show, concat, map, mapM ) +import Language.Haskell.TH hiding ( Exp ) +import Language.Haskell.TH.Extra import qualified Prelude as P @@ -130,78 +135,21 @@ instance P.Bounded (Exp CUChar) where minBound = mkBitcast (mkMinBound @Word8) maxBound = mkBitcast (mkMaxBound @Word8) -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) +$(runQ $ do + let + mkInstance :: Int -> Q [Dec] + mkInstance n = + let + xs = [ mkName ('x':show i) | i <- [0 .. n-1] ] + cst = tupT (map (\x -> [t| Bounded $(varT x) |]) xs) + res = tupT (map varT xs) + app x = appsE (conE (mkName ('T':show n)) : P.replicate n x) + in + [d| instance $cst => P.Bounded (Exp $res) where + minBound = $(app [| P.minBound |]) + maxBound = $(app [| P.maxBound |]) + |] + -- + concat <$> mapM mkInstance [2..16] + ) From 6aab6e99cdf994e2475d2322215dcab30b6caf83 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 15 Dec 2019 15:27:30 +0100 Subject: [PATCH 136/316] replace uses of [un]tupN with pattern synonyms --- src/Data/Array/Accelerate/Classes/RealFrac.hs | 10 ++++--- src/Data/Array/Accelerate/Language.hs | 26 +++++++++---------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs b/src/Data/Array/Accelerate/Classes/RealFrac.hs index 8bc4e0dbd..8c0bc1d31 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs @@ -24,6 +24,8 @@ module Data.Array.Accelerate.Classes.RealFrac ( import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Language ( (^), cond, even ) +import Data.Array.Accelerate.Lift +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -149,7 +151,7 @@ instance RealFrac CDouble where -- => Exp a -- -> (Exp b, Exp a) -- defaultProperFraction x = --- untup2 $ Exp +-- unlift $ Exp -- $ Cond (x == 0) (tup2 (0, 0)) -- (tup2 (n, f)) -- where @@ -161,10 +163,10 @@ defaultProperFraction => Exp a -> (Exp b, Exp a) defaultProperFraction x - = untup2 + = unlift $ cond (n >= 0) - (tup2 (fromIntegral m * (2 ^ n), 0.0)) - (tup2 (fromIntegral q, encodeFloat r n)) + (T2 (fromIntegral m * (2 ^ n)) 0.0) + (T2 (fromIntegral q) (encodeFloat r n)) where (m, n) = decodeFloat x (q, r) = quotRem m (2 ^ (negate n)) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 14ece2974..b4e3d6c95 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -109,6 +109,7 @@ module Data.Array.Accelerate.Language ( -- friends import Data.Array.Accelerate.Array.Sugar hiding ( (!), (!!), ignore, shape, reshape, size, toIndex, fromIndex, intersect, union ) +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Array.Sugar as Sugar @@ -1389,10 +1390,9 @@ 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)) + let T2 r _ = while (\(T2 _ b) -> b /= 0) + (\(T2 a b) -> T2 b (a `rem` b)) + (T2 u v) in r @@ -1412,21 +1412,19 @@ 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)) + let T2 x' y' = while (\(T2 _ v) -> even v) + (\(T2 u v) -> T2 (u * u) (v `quot` 2)) + (T2 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)) + let T3 x' _ z' = while (\(T3 _ v _) -> v /= 1) + (\(T3 u v w) -> + cond (even v) (T3 (u*u) (v `quot` 2) w) + (T3 (u*u) ((v-1) `quot` 2) (w*u))) + (T3 x y z) in x' * z' From ab51e5b6d73bcd669582a07a12fb40d57b7af7bc Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 15 Dec 2019 15:50:22 +0100 Subject: [PATCH 137/316] smol cleanup --- src/Data/Array/Accelerate/Array/Sugar.hs | 8 ++++--- src/Data/Array/Accelerate/Lift.hs | 14 +++++++----- src/Data/Array/Accelerate/Pattern.hs | 28 ++++++++++++++---------- src/Data/Array/Accelerate/Product.hs | 10 +++++---- 4 files changed, 35 insertions(+), 25 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index e04c58fd2..431b0ecc1 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -66,6 +66,7 @@ import Data.Kind import Data.Typeable import System.IO.Unsafe ( unsafePerformIO ) import Language.Haskell.TH hiding ( Foreign, Type ) +import Language.Haskell.TH.Extra import Prelude hiding ( (!!) ) import qualified Data.Vector.Unboxed as U @@ -1214,10 +1215,11 @@ $(runQ $ do mkInstance cst n = let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - res = foldl (\ts t -> [t| $ts $(varT t) |]) (tupleT n) xs - ctx = mapM (\x -> [t| $cst $(varT x) |]) xs + ts = map varT xs + res = tupT ts + ctx = mapM (appT cst) ts in - instanceD ctx [t| $cst $res |] [] + instanceD ctx (appT cst res) [] -- es <- mapM (mkInstance [t| Elt |]) [2..16] as <- mapM (mkInstance [t| Arrays |]) [2..16] diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 8ea40c61b..de456237f 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -40,6 +40,7 @@ import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type import Language.Haskell.TH hiding ( Exp ) +import Language.Haskell.TH.Extra -- |Lift a unary function into 'Exp'. @@ -492,12 +493,13 @@ $(runQ $ do mkInstances con cst smart prj nil pair n = do let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - res1 = foldl (\ts t -> appT ts (varT t)) (tupleT n) xs - res2 = foldl (\ts t -> [t| $ts ($(conT con) $(varT t)) |]) (tupleT n) xs - ctx1 = foldl (\ts t -> [t| $ts (Lift $(conT con) $(varT t)) |]) (tupleT n) xs - ctx2 = foldl (\ts t -> [t| $ts ($cst (Plain $(varT t))) |]) (tupleT n) xs - ctx3 = foldl (\ts t -> [t| $ts ($cst $(varT t)) |]) (tupleT n) xs - plain = foldl (\ts t -> [t| $ts (Plain $(varT t)) |]) (tupleT n) xs + ts = map varT xs + res1 = tupT ts + res2 = tupT (map (conT con `appT`) ts) + plain = tupT (map (\t -> [t| Plain $t |]) ts) + ctx1 = tupT (map (\t -> [t| Lift $(conT con) $t |]) ts) + ctx2 = tupT (map (\t -> [t| $cst (Plain $t) |]) ts) + ctx3 = tupT (map (appT cst) ts) -- get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 4b3d76a7a..88c9c0cba 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -41,6 +41,7 @@ import Data.Array.Accelerate.Product import Data.Array.Accelerate.Smart import Language.Haskell.TH hiding ( Exp ) +import Language.Haskell.TH.Extra -- | A pattern synonym for working with (product) data types. You can declare @@ -115,9 +116,10 @@ $(runQ $ do mkIsPattern con cst smart prj nil pair n = do let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - a = foldl (\ts t -> appT ts (varT t)) (tupleT n) xs - b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs - context = foldl (\ts t -> appT ts (appT cst (varT t))) (tupleT n) xs + ts = map varT xs + a = tupT ts + b = tupT (map (conT con `appT`) ts) + context = tupT (map (cst `appT`) ts) -- get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) @@ -162,12 +164,13 @@ $(runQ $ do let mkT :: Int -> Q [Dec] mkT n = - let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - name = mkName ('T':show n) - con = varT (mkName "con") - ty1 = foldl (\ts t -> [t| $ts $(varT t) |]) (tupleT n) xs - ty2 = foldl (\ts t -> [t| $ts ($con $(varT t)) |]) (tupleT n) xs - sig = foldr (\t ts -> [t| $con $(varT t) -> $ts |]) [t| $con $ty1 |] xs + let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + name = mkName ('T':show n) + con = varT (mkName "con") + ty1 = tupT ts + ty2 = tupT (map (con `appT`) ts) + sig = foldr (\t r -> [t| $con $t -> $r |]) (appT con ty1) ts in sequence [ patSynSigD name [t| IsPattern $con $ty1 $ty2 => $sig |] @@ -179,11 +182,12 @@ $(runQ $ do mkI :: Int -> Q [Dec] mkI n = let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs name = mkName ('I':show n) ix = mkName "Ix" - cst = foldl (\ts t -> [t| $ts (Elt $(varT t)) |]) (tupleT n) xs - dim = foldl (\ts t -> [t| $ts :. $(varT t) |]) [t| Z |] xs - sig = foldr (\t ts -> [t| Exp $(varT t) -> $ts |]) [t| Exp $dim |] xs + cst = tupT (map (\t -> [t| Elt $t |]) ts) + dim = foldl (\h t -> [t| $h :. $t |]) [t| Z |] ts + sig = foldr (\t r -> [t| Exp $t -> $r |]) [t| Exp $dim |] ts in sequence [ patSynSigD name [t| $cst => $sig |] diff --git a/src/Data/Array/Accelerate/Product.hs b/src/Data/Array/Accelerate/Product.hs index b7e4f925e..f075b23ab 100644 --- a/src/Data/Array/Accelerate/Product.hs +++ b/src/Data/Array/Accelerate/Product.hs @@ -37,6 +37,7 @@ module Data.Array.Accelerate.Product ( import GHC.Generics import Data.Primitive.Types import Language.Haskell.TH +import Language.Haskell.TH.Extra import Data.Array.Accelerate.Type @@ -171,15 +172,16 @@ $(runQ $ do mkIsProduct n = do cst <- newName "cst" let - xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - lhs = foldl (\ts t -> [t| $ts ($(varT cst) $(varT t)) |]) (tupleT n) xs - flat = foldl (\ts t -> [t| $ts $(varT t) |]) (tupleT n) xs + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + lhs = tupT (map (varT cst `appT`) ts) + flat = tupT ts -- prod' 0 = [| ProdRunit |] prod' i = [| ProdRsnoc $(prod' (i-1)) |] -- [d| instance $lhs => IsProduct $(varT cst) $flat where - type ProdRepr $flat = $(foldl (\ts t -> [t| ($ts, $(varT t)) |]) [t| () |] xs) + type ProdRepr $flat = $(foldl (\s t -> [t| ($s, $t) |]) [t| () |] ts) fromProd $(tupP (map varP xs)) = $(foldl (\vs v -> [| ($vs, $(varE v)) |]) [|()|] xs) toProd $(foldl (\ps p -> tupP [ps, varP p]) (tupP []) xs) = $(tupE (map varE xs)) prod = $(prod' n) From 1280915c2942ee19ef3c46b4261447633d2f00af Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 15 Dec 2019 16:15:24 +0100 Subject: [PATCH 138/316] wibble --- src/Data/Array/Accelerate/Lift.hs | 1 - src/Data/Array/Accelerate/Smart.hs | 14 ++++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index de456237f..d2371150e 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -476,7 +476,6 @@ instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, unlift = untup16 - instance Lift Acc () where type Plain () = () lift _ = Acc (SmartAcc Anil) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 0eddf517f..16e99fa26 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -728,16 +728,18 @@ data PreBoundary acc exp t where -- 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). +-- 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 :: Type - stencilPrj :: Exp (StencilRepr sh stencil) - -> stencil + stencilPrj :: Exp (StencilRepr sh stencil) -> stencil -- DIM1 instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e) where From 15d07062fbb26de740a180547d178eb09fc90a3d Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 15 Dec 2019 17:32:38 +0100 Subject: [PATCH 139/316] build fix --- src/Data/Array/Accelerate/Classes/RealFrac.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs b/src/Data/Array/Accelerate/Classes/RealFrac.hs index 8c0bc1d31..200bcf7b5 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs @@ -24,7 +24,7 @@ module Data.Array.Accelerate.Classes.RealFrac ( import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Language ( (^), cond, even ) -import Data.Array.Accelerate.Lift +import Data.Array.Accelerate.Lift ( unlift ) import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type From 8e5a592cab2738dc4e6c7e4a44bb24bd9bccf1e6 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 20 Dec 2019 16:27:38 +0100 Subject: [PATCH 140/316] Refactor AST for representation types, split tuple --- src/Data/Array/Accelerate/AST.hs | 798 +++++++++--------- src/Data/Array/Accelerate/Array/Data.hs | 407 +++------ .../Array/Accelerate/Array/Representation.hs | 313 ++++--- src/Data/Array/Accelerate/Array/Sugar.hs | 287 ++++--- src/Data/Array/Accelerate/Type.hs | 140 +-- 5 files changed, 979 insertions(+), 966 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 67cff57df..151070dc0 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -83,15 +83,15 @@ module Data.Array.Accelerate.AST ( -- * Typed de Bruijn indices - Idx(..), idxToInt, tupleIdxToInt, ArrayVar(..), ArrayVars(..), + Idx(..), idxToInt, tupleIdxToInt, Vars(..), ArrayVar(..), ScalarVars(..), ArrayVars, ScalarVars, -- * Valuation environment - Val(..), ValElt(..), push, prj, prjElt, + Val(..), push, prj, -- * Accelerated array expressions PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc, PreBoundary(..), Boundary, Stencil(..), StencilR(..), - LeftHandSide(..), HasArraysRepr(..), lhsToArraysR, + LeftHandSide(..), HasArraysRepr(..), lhsToTupR, -- * Accelerated sequences -- PreOpenSeq(..), Seq, @@ -111,7 +111,7 @@ module Data.Array.Accelerate.AST ( liftIdx, liftTupleIdx, liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp, - liftLHS, liftArray, + liftALhs, liftELhs, liftArray, -- Utilities Exists(..), weakenWithLHS, (:>), @@ -145,8 +145,8 @@ import GHC.Word ( Word8(..) -- 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.Representation +import qualified Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.Array.Unique import Data.Array.Accelerate.Product import Data.Array.Accelerate.Type @@ -186,18 +186,11 @@ data Val env where Push :: Val env -> t -> Val (env, t) deriving instance Typeable Val -push :: Val env -> (LeftHandSide arrs env env', arrs) -> Val env' +push :: Val env -> (LeftHandSide s arrs env env', arrs) -> Val env' push env (LeftHandSideWildcard _, _ ) = env -push env (LeftHandSideArray , a ) = env `Push` a +push env (LeftHandSideSingle _ , a ) = env `Push` a push env (LeftHandSidePair l1 l2, (a, b)) = push env (l1, a) `push` (l2, b) --- 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 @@ -207,23 +200,14 @@ prj (SuccIdx idx) (Push val _) = prj idx val 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 :: acc aenv t -> PreOpenAfun acc aenv t - Alam :: LeftHandSide a aenv aenv' -> PreOpenAfun acc aenv' t -> PreOpenAfun acc aenv (a -> t) + Abody :: acc aenv t -> PreOpenAfun acc aenv t + Alam :: ALeftHandSide a aenv aenv' -> PreOpenAfun acc aenv' t -> PreOpenAfun acc aenv (a -> t) -- Function abstraction over vanilla open array computations -- @@ -248,33 +232,37 @@ type Acc = OpenAcc () deriving instance Typeable PreOpenAcc deriving instance Typeable OpenAcc -data LeftHandSide arrs env env' where - LeftHandSideArray - :: (Shape sh, Elt e) - => LeftHandSide (Array sh e) env (env, Array sh e) +type ALeftHandSide = LeftHandSide ArrayR + +type ELeftHandSide = LeftHandSide ScalarType - -- Note: a unit is represented as LeftHandSide ArraysRunit +data LeftHandSide (s :: * -> *) arrs env env' where + LeftHandSideSingle + :: s arrs + -> LeftHandSide s arrs env (env, arrs) + + -- Note: a unit is represented as LeftHandSideWildcard TupRunit LeftHandSideWildcard - :: ArraysR arrs - -> LeftHandSide arrs env env + :: TupR s arrs + -> LeftHandSide s arrs env env LeftHandSidePair - :: LeftHandSide arrs1 env env' - -> LeftHandSide arrs2 env' env'' - -> LeftHandSide (arrs1, arrs2) env env'' + :: LeftHandSide s arrs1 env env' + -> LeftHandSide s arrs2 env' env'' + -> LeftHandSide s (arrs1, arrs2) env env'' -lhsToArraysR :: LeftHandSide arrs aenv aenv' -> ArraysR arrs -lhsToArraysR LeftHandSideArray = ArraysRarray -lhsToArraysR (LeftHandSideWildcard r) = r -lhsToArraysR (LeftHandSidePair as bs) = ArraysRpair (lhsToArraysR as) (lhsToArraysR bs) +lhsToTupR :: LeftHandSide s arrs aenv aenv' -> TupR s arrs +lhsToTupR (LeftHandSideSingle s) = TupRsingle s +lhsToTupR (LeftHandSideWildcard r) = r +lhsToTupR (LeftHandSidePair as bs) = TupRpair (lhsToTupR as) (lhsToTupR bs) -- The type of shifting terms from one context into another -- type env :> env' = forall t'. Idx env t' -> Idx env' t' -weakenWithLHS :: LeftHandSide arrs env env' -> env :> env' +weakenWithLHS :: LeftHandSide s arrs env env' -> env :> env' weakenWithLHS (LeftHandSideWildcard _) = id -weakenWithLHS LeftHandSideArray = SuccIdx +weakenWithLHS (LeftHandSideSingle _) = SuccIdx weakenWithLHS (LeftHandSidePair lhs1 lhs2) = weakenWithLHS lhs2 . weakenWithLHS lhs1 -- Often useful when working with LeftHandSide, when you need to @@ -282,13 +270,17 @@ weakenWithLHS (LeftHandSidePair lhs1 lhs2) = weakenWithLHS lhs2 . weakenWithLHS data Exists f where Exists :: f a -> Exists f -data ArrayVar aenv arr where - ArrayVar :: (Shape sh, Elt e) => Idx aenv (Array sh e) -> ArrayVar aenv (Array sh e) +type ArrayVar = Var ArrayR +type ArrayVars = Vars ArrayR + +type ScalarVar = Var ScalarType +type ScalarVars = Vars ScalarType -data ArrayVars aenv arrs where - ArrayVarsArray :: ArrayVar aenv a -> ArrayVars aenv a - ArrayVarsNil :: ArrayVars aenv () - ArrayVarsPair :: ArrayVars aenv a -> ArrayVars aenv b -> ArrayVars aenv (a, b) +data Var s env t = Var (s t) (Idx env t) +data Vars s env t where + VarsSingle :: Var s env a -> Vars s env a + VarsNil :: Vars s aenv () + VarsPair :: Vars s aenv a -> Vars s aenv b -> Vars s aenv (a, b) -- | Collective array computations parametrised over array variables -- represented with de Bruijn indices. @@ -314,7 +306,7 @@ data PreOpenAcc acc aenv a where -- Local non-recursive binding to represent sharing and demand -- explicitly. Note this is an eager binding! -- - Alet :: LeftHandSide bndArrs aenv aenv' + Alet :: ALeftHandSide bndArrs aenv aenv' -> acc aenv bndArrs -- bound expression -> acc aenv' bodyArrs -- the bound expression scope -> PreOpenAcc acc aenv bodyArrs @@ -345,11 +337,11 @@ data PreOpenAcc acc aenv a where -- Accelerate version for use with other backends. The functions must be -- closed. -- - Aforeign :: (Arrays as, Arrays bs, Foreign asm) + Aforeign :: (Sugar.Arrays as, Sugar.Arrays bs, Sugar.Foreign asm) => asm (as -> bs) -- The foreign function for a given backend - -> PreAfun acc (ArrRepr as -> ArrRepr bs) -- Fallback implementation(s) - -> acc aenv (ArrRepr as) -- Arguments to the function - -> PreOpenAcc acc aenv (ArrRepr bs) + -> PreAfun acc (Sugar.ArrRepr as -> Sugar.ArrRepr bs) -- Fallback implementation(s) + -> acc aenv (Sugar.ArrRepr as) -- Arguments to the function + -> PreOpenAcc acc aenv (Sugar.ArrRepr bs) -- If-then-else for array-level computations -- @@ -369,13 +361,13 @@ data PreOpenAcc acc aenv a where -- Array inlet. Triggers (possibly) asynchronous host->device transfer if -- necessary. -- - Use :: (Shape sh, Elt e) - => Array sh e + Use :: ArrayR (Array sh e) + -> Array sh e -> PreOpenAcc acc aenv (Array sh e) -- Capture a scalar (or a tuple of scalars) in a singleton array -- - Unit :: Elt e + Unit :: TupleType e => PreExp acc aenv e -> PreOpenAcc acc aenv (Scalar e) @@ -384,14 +376,14 @@ data PreOpenAcc acc aenv a where -- -- > dim == size dim' -- - Reshape :: (Shape sh, Shape sh', Elt e) - => PreExp acc aenv sh -- new shape + Reshape :: ShapeR sh + -> 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) + Generate :: ArrayR (Array sh e) => PreExp acc aenv sh -- output shape -> PreFun acc aenv (sh -> e) -- representation function -> PreOpenAcc acc aenv (Array sh e) @@ -399,7 +391,7 @@ data PreOpenAcc acc aenv a where -- Hybrid map/backpermute, where we separate the index and value -- transformations. -- - Transform :: (Elt a, Elt b, Shape sh, Shape sh') + Transform :: ArrayR (Array sh' b) => 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 @@ -409,8 +401,7 @@ data PreOpenAcc acc aenv a where -- 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 + Replicate :: SliceIndex (EltRepr slix) -- slice type specification (EltRepr sl) co (EltRepr sh) @@ -421,8 +412,7 @@ data PreOpenAcc acc aenv a where -- 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 + Slice :: SliceIndex (EltRepr slix) -- slice type specification (EltRepr sl) co (EltRepr sh) @@ -432,8 +422,8 @@ data PreOpenAcc acc aenv a where -- Apply the given unary function to all elements of the given array -- - Map :: (Shape sh, Elt e, Elt e') - => PreFun acc aenv (e -> e') + Map :: TupleType e' + -> PreFun acc aenv (e -> e') -> acc aenv (Array sh e) -> PreOpenAcc acc aenv (Array sh e') @@ -441,8 +431,8 @@ data PreOpenAcc acc aenv a where -- 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) + ZipWith :: TupleType e3 + -> PreFun acc aenv (e1 -> e2 -> e3) -> acc aenv (Array sh e1) -> acc aenv (Array sh e2) -> PreOpenAcc acc aenv (Array sh e3) @@ -450,24 +440,22 @@ data PreOpenAcc acc aenv a where -- 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 + Fold :: 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) -- As 'Fold' without a default value -- - Fold1 :: (Shape sh, Elt e) - => PreFun acc aenv (e -> e -> e) -- combination function + Fold1 :: 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 + FoldSeg :: IntegralType 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 @@ -475,8 +463,8 @@ data PreOpenAcc acc aenv a where -- As 'FoldSeg' without a default value -- - Fold1Seg :: (Shape sh, Elt e, Elt i, IsIntegral i) - => PreFun acc aenv (e -> e -> e) -- combination function + Fold1Seg :: IntegralType 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) @@ -485,8 +473,7 @@ data PreOpenAcc acc aenv a where -- /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 + Scanl :: 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) @@ -495,39 +482,34 @@ data PreOpenAcc acc aenv a where -- 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 + Scanl' :: PreFun acc aenv (e -> e -> e) -- combination function -> PreExp acc aenv e -- initial value -> acc aenv (Array (sh:.Int) e) - -> PreOpenAcc acc aenv (ArrRepr (Array (sh:.Int) e, Array sh 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 + Scanl1 :: 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 + Scanr :: 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 + Scanr' :: PreFun acc aenv (e -> e -> e) -- combination function -> PreExp acc aenv e -- initial value -> acc aenv (Array (sh:.Int) e) - -> PreOpenAcc acc aenv (ArrRepr (Array (sh:.Int) e, Array sh 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 + Scanr1 :: PreFun acc aenv (e -> e -> e) -- combination function -> acc aenv (Array (sh:.Int) e) -> PreOpenAcc acc aenv (Array (sh:.Int) e) @@ -551,7 +533,7 @@ data PreOpenAcc acc aenv a where -- function is used to combine elements, which needs to be /associative/ -- and /commutative/. -- - Permute :: (Shape sh, Shape sh', Elt e) + Permute :: ShapeR sh' => PreFun acc aenv (e -> e -> e) -- combination function -> acc aenv (Array sh' e) -- default values -> PreFun acc aenv (sh -> sh') -- permutation function @@ -561,7 +543,7 @@ data PreOpenAcc acc aenv a where -- 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) + Backpermute :: ShapeR sh' => PreExp acc aenv sh' -- dimensions of the result -> PreFun acc aenv (sh' -> sh) -- permutation function -> acc aenv (Array sh e) -- source array @@ -570,15 +552,18 @@ data PreOpenAcc acc aenv a where -- 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 + Stencil :: StencilR sh e stencil + -> TupleType e' + -> 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) + Stencil2 :: StencilR sh a stencil1 + -> StencilR sh b stencil2 + -> TupleType c => 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 @@ -736,152 +721,45 @@ data PreBoundary acc aenv t where -> 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 - class HasArraysRepr f where arraysRepr :: f aenv a -> ArraysR a instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr (Alet _ _ body) = arraysRepr body - arraysRepr (Avar ArrayVar{}) = ArraysRarray - arraysRepr (Apair as bs) = ArraysRpair (arraysRepr as) (arraysRepr bs) - arraysRepr Anil = ArraysRunit + arraysRepr (Avar ArrayVar{}) = arraysRarray + arraysRepr (Apair as bs) = TupRpair (arraysRepr as) (arraysRepr bs) + arraysRepr Anil = TupRunit arraysRepr (Apply (Alam _ (Abody a)) _) = arraysRepr a arraysRepr (Apply _ _) = error "Tomorrow will arrive, on time" arraysRepr (Aforeign _ (Alam _ (Abody a)) _) = arraysRepr a arraysRepr (Aforeign _ (Abody _) _) = error "And what have you got, at the end of the day?" arraysRepr (Aforeign _ (Alam _ (Alam _ _)) _) = error "A bottle of whisky. And a new set of lies." arraysRepr (Acond _ whenTrue _) = arraysRepr whenTrue - arraysRepr (Awhile _ (Alam lhs _) _) = lhsToArraysR lhs + arraysRepr (Awhile _ (Alam lhs _) _) = lhsToTupR lhs arraysRepr (Awhile _ _ _) = error "I want my, I want my MTV!" - arraysRepr Use{} = ArraysRarray - arraysRepr Unit{} = ArraysRarray - arraysRepr Reshape{} = ArraysRarray - arraysRepr Generate{} = ArraysRarray - arraysRepr Transform{} = ArraysRarray - arraysRepr Replicate{} = ArraysRarray - arraysRepr Slice{} = ArraysRarray - arraysRepr Map{} = ArraysRarray - arraysRepr ZipWith{} = ArraysRarray - arraysRepr Fold{} = ArraysRarray - arraysRepr Fold1{} = ArraysRarray - arraysRepr FoldSeg{} = ArraysRarray - arraysRepr Fold1Seg{} = ArraysRarray - arraysRepr Scanl{} = ArraysRarray + arraysRepr Use{} = arraysRarray + arraysRepr Unit{} = arraysRarray + arraysRepr Reshape{} = arraysRarray + arraysRepr Generate{} = arraysRarray + arraysRepr Transform{} = arraysRarray + arraysRepr Replicate{} = arraysRarray + arraysRepr Slice{} = arraysRarray + arraysRepr Map{} = arraysRarray + arraysRepr ZipWith{} = arraysRarray + arraysRepr Fold{} = arraysRarray + arraysRepr Fold1{} = arraysRarray + arraysRepr FoldSeg{} = arraysRarray + arraysRepr Fold1Seg{} = arraysRarray + arraysRepr Scanl{} = arraysRarray arraysRepr Scanl'{} = arraysRtuple2 - arraysRepr Scanl1{} = ArraysRarray - arraysRepr Scanr{} = ArraysRarray + arraysRepr Scanl1{} = arraysRarray + arraysRepr Scanr{} = arraysRarray arraysRepr Scanr'{} = arraysRtuple2 - arraysRepr Scanr1{} = ArraysRarray - arraysRepr Permute{} = ArraysRarray - arraysRepr Backpermute{} = ArraysRarray - arraysRepr Stencil{} = ArraysRarray - arraysRepr Stencil2{} = ArraysRarray + arraysRepr Scanr1{} = arraysRarray + arraysRepr Permute{} = arraysRarray + arraysRepr Backpermute{} = arraysRarray + arraysRepr Stencil{} = arraysRarray + arraysRepr Stencil2{} = arraysRarray instance HasArraysRepr OpenAcc where arraysRepr (OpenAcc a) = arraysRepr a @@ -891,8 +769,8 @@ instance HasArraysRepr OpenAcc where -- |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) + Body :: PreOpenExp acc env aenv t -> PreOpenFun acc env aenv t + Lam :: ELeftHandSide a env env' -> PreOpenFun acc env' aenv t -> PreOpenFun acc env aenv (a -> t) -- |Vanilla open function abstraction -- @@ -922,65 +800,47 @@ type Exp = OpenExp () -- 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). +-- The data type is parametrised over the representation type (not the surface types). -- 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 + Let :: ELeftHandSide bnd_t env env' + -> PreOpenExp acc env aenv bnd_t + -> PreOpenExp acc env' aenv body_t + -> PreOpenExp acc env aenv body_t -- Variable index, ranging only over tuples or scalars - Var :: Elt t - => Idx env t + EVar :: ScalarVar 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 + Foreign :: (Sugar.Foreign asm, Sugar.Elt x, Sugar.Elt y) + => asm (x -> y) -- foreign function + -> PreFun acc () (Sugar.EltRepr x -> Sugar.EltRepr y) -- alternate implementation (for other backends) + -> PreOpenExp acc env aenv (Sugar.EltRepr x) + -> PreOpenExp acc env aenv (Sugar.EltRepr y) -- Tuples - Tuple :: (Elt t, IsTuple t) - => Tuple (PreOpenExp acc env aenv) (TupleRepr t) - -> PreOpenExp acc env aenv t + Pair :: PreOpenExp acc env aenv t1 + -> PreOpenExp acc env aenv t2 + -> PreOpenExp acc env aenv (t1, t2) - Prj :: (Elt t, IsTuple t, Elt e) - => TupleIdx (TupleRepr t) e - -> PreOpenExp acc env aenv t - -> PreOpenExp acc env aenv e + Nil :: PreOpenExp acc env aenv () -- Array indices & shapes - IndexNil :: PreOpenExp acc env aenv Z - - IndexCons :: (Elt sl, Elt a) - => PreOpenExp acc env aenv sl - -> PreOpenExp acc env aenv a - -> PreOpenExp acc env aenv (sl:.a) - - IndexHead :: (Elt sl, Elt a) - => PreOpenExp acc env aenv (sl:.a) - -> PreOpenExp acc env aenv a - - IndexTail :: (Elt sl, Elt a) - => PreOpenExp acc env aenv (sl:.a) - -> PreOpenExp acc env aenv sl - + -- TODO: IndexIgnore? IndexAny :: Shape sh => PreOpenExp acc env aenv (Any sh) - IndexSlice :: (Shape sh, Shape sl, Elt slix) - => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) + IndexSlice :: (Shape sh, Shape sl) + => SliceIndex slix sl co 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) + IndexFull :: (Shape sh, Shape sl) + => SliceIndex slix sl co sh -> PreOpenExp acc env aenv slix -> PreOpenExp acc env aenv sl -> PreOpenExp acc env aenv sh @@ -997,57 +857,50 @@ data PreOpenExp acc env aenv t where -> PreOpenExp acc env aenv sh -- Conditional expression (non-strict in 2nd and 3rd argument) - Cond :: Elt t - => PreOpenExp acc env aenv Bool + Cond :: 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 + While :: 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 + Const :: ScalarType t + -> t -> PreOpenExp acc env aenv t - PrimConst :: Elt t - => PrimConst t + PrimConst :: PrimConst t -> PreOpenExp acc env aenv t -- Primitive scalar operations - PrimApp :: (Elt a, Elt r) - => PrimFun (a -> r) + PrimApp :: 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) + Index :: 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) + LinearIndex :: 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) + Shape :: 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 + ShapeSize :: PreOpenExp acc env aenv dim -> PreOpenExp acc env aenv Int + {- -- Intersection of two shapes Intersect :: Shape dim => PreOpenExp acc env aenv dim @@ -1059,15 +912,17 @@ data PreOpenExp acc env aenv t where => 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 + Undef :: ScalarType 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 + Coerce :: BitSizeEq a b + => ScalarType a + -> ScalarType b + -> PreOpenExp acc env aenv a -> PreOpenExp acc env aenv b @@ -1176,6 +1031,146 @@ data PrimFun sig where PrimFromIntegral :: IntegralType a -> NumType b -> PrimFun (a -> b) PrimToFloating :: NumType a -> FloatingType b -> PrimFun (a -> b) +primConstType :: PrimConst a -> TupleType a +primConstType prim = case prim of + PrimMinBound t -> boundedType t + PrimMaxBound t -> boundedType t + PrimPi t -> floatingType t + where + boundedType :: BoundedType a -> TupleType a + boundedType (IntegralBoundedType t) = SingleType $ NumSingleType $ IntegralNumType t + boundedType (NonNumBoundedType t) = SingleType $ NonNumSingleType t + + floatingType :: FloatingType t -> TupleType t + floatingType = numType . FloatingNumType + +primFunType :: PrimFun (a -> b) -> (TupleType a, TupleType b) +primFunType prim = case prim of + -- Num + PrimAdd t -> binary' $ numType t + PrimSub t -> binary' $ numType t + PrimMul t -> binary' $ numType t + PrimNeg t -> unary' $ numType t + PrimAbs t -> unary' $ numType t + PrimSig t -> unary' $ numType t + + -- Integral + PrimQuot t -> binary' $ integralType t + PrimRem t -> binary' $ integralType t + PrimQuotRem t -> divMod t + PrimIDiv t -> binary' $ integralType t + PrimMod t -> binary' $ integralType t + PrimDivMod t -> divMod t + + -- Bits & FiniteBits + PrimBAnd t -> binary' $ integralType t + PrimBOr t -> binary' $ integralType t + PrimBXor t -> binary' $ integralType t + PrimBNot t -> unary' $ integralType t + PrimBShiftL t -> (integralType t `TupRpair` typeInt, integralType t) + PrimBShiftR t -> (integralType t `TupRpair` typeInt, integralType t) + PrimBRotateL t -> (integralType t `TupRpair` typeInt, integralType t) + PrimBRotateR t -> (integralType t `TupRpair` typeInt, integralType t) + PrimPopCount t -> unary (integralType t) typeInt + PrimCountLeadingZeros t -> unary (integralType t) typeInt + PrimCountTrailingZeros t -> unary (integralType t) typeInt + + -- Fractional, Floating + PrimFDiv t -> binary' $ floatingType t + PrimRecip t -> unary' $ floatingType t + PrimSin t -> unary' $ floatingType t + PrimCos t -> unary' $ floatingType t + PrimTan t -> unary' $ floatingType t + PrimAsin t -> unary' $ floatingType t + PrimAcos t -> unary' $ floatingType t + PrimAtan t -> unary' $ floatingType t + PrimSinh t -> unary' $ floatingType t + PrimCosh t -> unary' $ floatingType t + PrimTanh t -> unary' $ floatingType t + PrimAsinh t -> unary' $ floatingType t + PrimAcosh t -> unary' $ floatingType t + PrimAtanh t -> unary' $ floatingType t + PrimExpFloating t -> unary' $ floatingType t + PrimSqrt t -> unary' $ floatingType t + PrimLog t -> unary' $ floatingType t + PrimFPow t -> binary' $ floatingType t + PrimLogBase t -> binary' $ floatingType t + + -- RealFrac + PrimTruncate a b -> unary (floatingType a) (integralType b) + PrimRound a b -> unary (floatingType a) (integralType b) + PrimFloor a b -> unary (floatingType a) (integralType b) + PrimCeiling a b -> unary (floatingType a) (integralType b) + + -- RealFloat + PrimAtan2 t -> binary' $ floatingType t + PrimIsNaN t -> unary (floatingType t) typeBool + PrimIsInfinite t -> unary (floatingType t) typeBool + + -- Relational and equality + PrimLt t -> compare t + PrimGt t -> compare t + PrimLtEq t -> compare t + PrimGtEq t -> compare t + PrimEq t -> compare t + PrimMax t -> binary $ singleType t + PrimMin t -> binary $ singleType t + + -- Logical + PrimLAnd -> binary' typeBool + PrimLOr -> binary' typeBool + PrimLNot -> unary' typeBool + + -- character conversions + PrimOrd -> unary typeChar typeInt + PrimChr -> unary typeInt typeChar + + -- boolean conversion + PrimBoolToInt -> unary typeBool typeInt + + -- general conversion between types + PrimFromIntegral a b -> unary (integralType a) (numType b) + PrimToFloating a b -> unary (numType a) (floatingType b) + + where + unary :: TupleType a -> TupleType b -> (TupleType a, TupleType b) + unary a b = (a, b) + + unary' :: TupleType a -> (TupleType a, TupleType a) + unary' a = unary a a + + binary :: TupleType a -> TupleType b -> (TupleType (a, a), TupleType b) + binary a b = (a `TupRpair` a, b) + + binary' :: TupleType a -> (TupleType (a, a), TupleType a) + binary' a = binary a a + + compare :: SingleType a -> (TupleType (a, a), TupleType Bool) + compare a = binary (singleType a) typeBool + + singleType :: SingleType t -> TupleType t + singleType = SingleScalarType + + numType :: NumType t -> TupleType t + numType = SingleScalarType . NumSingleType + + integralType :: IntegralType t -> TupleType t + integralType = numType . IntegralNumType + + floatingType :: FloatingType t -> TupleType t + floatingType = numType . FloatingNumType + + divMod :: IntegralType t -> (TupleType (t, t), TupleType (t, t)) + divMod t = unary' $ integralType t `TupRpair` integralType t + + typeBool :: TupleType Bool + typeBool = SingleScalarType $ NonNumSingleType $ TypeBool + + typeChar :: TupleType Char + typeChar = SingleScalarType $ NonNumSingleType $ TypeChar + + typeInt :: TupleType Int + typeInt = SingleScalarType $ NumSingleType $ IntegralNumType TypeInt -- NFData instances -- ================ @@ -1217,7 +1212,7 @@ rnfOpenAcc (OpenAcc pacc) = rnfPreOpenAcc rnfOpenAcc pacc rnfPreOpenAfun :: NFDataAcc acc -> PreOpenAfun acc aenv t -> () rnfPreOpenAfun rnfA (Abody b) = rnfA b -rnfPreOpenAfun rnfA (Alam lhs f) = rnfLHS lhs `seq` rnfPreOpenAfun rnfA f +rnfPreOpenAfun rnfA (Alam lhs f) = rnfALhs lhs `seq` rnfPreOpenAfun rnfA f rnfPreOpenAcc :: forall acc aenv t. NFDataAcc acc -> PreOpenAcc acc aenv t -> () rnfPreOpenAcc rnfA pacc = @@ -1238,7 +1233,7 @@ rnfPreOpenAcc rnfA pacc = rnfB = rnfBoundary rnfA in case pacc of - Alet lhs bnd body -> rnfLHS lhs `seq` rnfA bnd `seq` rnfA body + Alet lhs bnd body -> rnfALhs lhs `seq` rnfA bnd `seq` rnfA body Avar (ArrayVar ix) -> rnfIdx ix Apair as bs -> rnfA as `seq` rnfA bs Anil -> () @@ -1271,20 +1266,29 @@ rnfPreOpenAcc rnfA pacc = Stencil2 f b1 a1 b2 a2 -> rnfF f `seq` rnfB b1 `seq` rnfB b2 `seq` rnfA a1 `seq` rnfA a2 -- Collect s -> rnfS s -rnfLHS :: LeftHandSide arrs aenv aenv' -> () -rnfLHS (LeftHandSideWildcard r) = rnfArraysR r -rnfLHS LeftHandSideArray = () -rnfLHS (LeftHandSidePair ar1 ar2) = rnfLHS ar1 `seq` rnfLHS ar2 +rnfLhs :: (forall b. s b -> ()) -> LeftHandSide s arrs env env' -> () +rnfLhs rnfS (LeftHandSideWildcard r) = rnfTupR rnfS r +rnfLhs rnfS (LeftHandSideSingle s) = rnfS s +rnfLhs rnfS (LeftHandSidePair ar1 ar2) = rnfLhs rnfS ar1 `seq` rnfLhs rnfS ar2 -rnfArraysR :: ArraysR arrs -> () -rnfArraysR ArraysRunit = () -rnfArraysR ArraysRarray = () -rnfArraysR (ArraysRpair ar1 ar2) = rnfArraysR ar1 `seq` rnfArraysR ar2 +rnfALhs :: ALeftHandSide arrs aenv aenv' -> () +rnfALhs = rnfLhs rnfArrayR + +rnfELhs :: ELeftHandSide t env env' -> () +rnfELhs = rnfLhs rnfScalarType + +rnfTupR :: (forall b. s b -> ()) -> TupR s a -> () +rnfTupR _ TupRunit = () +rnfTupR rnfS (TupRsingle s) = rnfS s +rnfTupR rnfS (TupRpair t1 t2) = rnfTupR rnfS t1 `seq` rnfTupR rnfS t2 + +rnfArrayR :: ArrayR arr -> () +rnfArrayR ArrayR = () rnfArrays :: ArraysR arrs -> arrs -> () -rnfArrays ArraysRunit () = () -rnfArrays ArraysRarray arr = rnf arr -rnfArrays (ArraysRpair ar1 ar2) (a1,a2) = rnfArrays ar1 a1 `seq` rnfArrays ar2 a2 +rnfArrays TupRunit () = () +rnfArrays (TupRsingle ArrayR) arr = rnf arr +rnfArrays (TupRpair 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 = () @@ -1383,12 +1387,8 @@ rnfPreOpenExp rnfA topExp = Foreign asm f x -> rnf (strForeign asm) `seq` rnfF f `seq` rnfE x Const t -> rnfConst (eltType @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 + Pair a b -> rnfE a `seq` rnfE b + Nil -> () 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 @@ -1402,18 +1402,12 @@ rnfPreOpenExp rnfA topExp = 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 +rnfConst TupRunit () = () +rnfConst (TupRsingle t) !_ = rnfScalarType t -- scalars should have (nf == whnf) +rnfConst (TupRpair ta tb) (a,b) = rnfConst ta a `seq` rnfConst tb b rnfPrimConst :: PrimConst c -> () rnfPrimConst (PrimMinBound t) = rnfBoundedType t @@ -1548,7 +1542,7 @@ liftTupleIdx (SuccTupIdx tix) = [|| SuccTupIdx $$(liftTupleIdx tix) ||] liftPreOpenAfun :: LiftAcc acc -> PreOpenAfun acc aenv t -> Q (TExp (PreOpenAfun acc aenv t)) -liftPreOpenAfun liftA (Alam lhs f) = [|| Alam $$(liftLHS lhs) $$(liftPreOpenAfun liftA f) ||] +liftPreOpenAfun liftA (Alam lhs f) = [|| Alam $$(liftALhs lhs) $$(liftPreOpenAfun liftA f) ||] liftPreOpenAfun liftA (Abody b) = [|| Abody $$(liftA b) ||] liftPreOpenAcc @@ -1572,7 +1566,7 @@ liftPreOpenAcc liftA pacc = in case pacc of - Alet lhs bnd body -> [|| Alet $$(liftLHS lhs) $$(liftA bnd) $$(liftA body) ||] + Alet lhs bnd body -> [|| Alet $$(liftALhs lhs) $$(liftA bnd) $$(liftA body) ||] Avar (ArrayVar ix) -> [|| Avar (ArrayVar $$(liftIdx ix)) ||] Apair as bs -> [|| Apair $$(liftA as) $$(liftA bs) ||] Anil -> [|| Anil ||] @@ -1604,15 +1598,20 @@ liftPreOpenAcc liftA pacc = 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) ||] -liftLHS :: LeftHandSide arrs aenv aenv' -> Q (TExp (LeftHandSide arrs aenv aenv')) -liftLHS (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftArraysR r) ||] -liftLHS LeftHandSideArray = [|| LeftHandSideArray ||] -liftLHS (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftLHS a) $$(liftLHS b) ||] +liftALhs :: ALeftHandSide arrs aenv aenv' -> Q (TExp (ALeftHandSide arrs aenv aenv')) +liftALhs (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftArraysR r) ||] +liftALhs (LeftHandSideSingle ArrayR) = [|| LeftHandSideSingle ArrayR ||] +liftALhs (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftALhs a) $$(liftALhs b) ||] + +liftELhs :: ELeftHandSide t aenv aenv' -> Q (TExp (ELeftHandSide t aenv aenv')) +liftELhs (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftTupleType r) ||] +liftELhs (LeftHandSideSingle t) = [|| LeftHandSideSingle $$(liftScalarType t) ||] +liftELhs (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftELhs a) $$(liftELhs b) ||] liftArraysR :: ArraysR arrs -> Q (TExp (ArraysR arrs)) -liftArraysR ArraysRunit = [|| ArraysRunit ||] -liftArraysR ArraysRarray = [|| ArraysRarray ||] -liftArraysR (ArraysRpair a b) = [|| ArraysRpair $$(liftArraysR a) $$(liftArraysR b) ||] +liftArraysR TupRunit = [|| TupRunit ||] +liftArraysR (TupRsingle ArrayR) = [|| TupRsingle ArrayR ||] +liftArraysR (TupRpair a b) = [|| TupRpair $$(liftArraysR a) $$(liftArraysR b) ||] liftPreOpenFun :: LiftAcc acc @@ -1633,23 +1632,15 @@ liftPreOpenExp liftA pexp = 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) ||] + Let lhs bnd body -> [|| Let $$(liftElhs lhs) $$(liftPreOpenExp liftA bnd) $$(liftPreOpenExp liftA body) ||] + Var var -> [|| Var $$(liftScalarVar var) ||] Foreign asm f x -> [|| Foreign $$(liftForeign asm) $$(liftPreOpenFun liftA f) $$(liftE x) ||] Const c -> [|| Const $$(liftConst (eltType @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) ||] + Pair a b -> [|| Pair $$(liftE a) $$(liftE b) ||] + Nil -> [|| Nil ||] IndexAny -> [|| IndexAny ||] IndexSlice slice slix sh -> [|| IndexSlice $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sh) ||] IndexFull slice slix sl -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||] @@ -1663,13 +1654,13 @@ liftPreOpenExp liftA pexp = 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) ||] +liftScalarVar :: ScalarVar env t -> Q (TExp (ScalarVar env t)) +liftScalarVar (ScalarVar tp ix) = [|| ScalarVar $$(liftScalarType tp) $$(liftIdx ix) ||] -liftArray :: forall sh e. (Shape sh, Elt e) => Array sh e -> Q (TExp (Array sh e)) -liftArray (Array sh adata) = +liftArray :: forall sh e. Shape sh => TupleType -> Array sh e -> Q (TExp (Array sh e)) +liftArray tp (Array sh adata) = [|| Array $$(liftConst (eltType @sh) sh) $$(go arrayElt adata) ||] `sigE` typeRepToType (typeOf (undefined::Array sh e)) where sz :: Int @@ -1808,11 +1799,15 @@ liftPrimFun PrimBoolToInt = [|| PrimBoolToInt ||] liftPrimFun (PrimFromIntegral ta tb) = [|| PrimFromIntegral $$(liftIntegralType ta) $$(liftNumType tb) ||] liftPrimFun (PrimToFloating ta tb) = [|| PrimToFloating $$(liftNumType ta) $$(liftFloatingType tb) ||] +liftTupleType :: TupleType t -> Q (TExp (TupleType t)) +liftTupleType TupRunit = [|| TupRunit ||] +liftTupleType (TupRsingle t) = [|| TupRsingle $$(liftScalarType t) ||] +liftTupleType (TupRpair ta tb) = [|| TupRpair $$(liftTupleType ta) $$(liftTupleType 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)) ||] +liftConst TupRunit () = [|| () ||] +liftConst (TupRsingle t) x = [|| $$(liftScalar t x) ||] +liftConst (TupRpair ta tb) (a,b) = [|| ($$(liftConst ta a), $$(liftConst tb b)) ||] liftScalar :: ScalarType t -> t -> Q (TExp t) liftScalar (SingleScalarType t) x = liftSingle t x @@ -1912,16 +1907,16 @@ 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) ||] +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 (VectorType n t) = [|| VectorType n $$(liftSingleType t) ||] +liftVectorType :: VectorType t -> Q (TExp (VectorType t)) +liftVectorType (VectorType n t) = [|| VectorType n $$(liftSingleType t) ||] -- Debugging @@ -1962,40 +1957,81 @@ showPreAccOp Stencil2{} = "Stencil2" -- showPreAccOp Collect{} = "Collect" -showShortendArr :: (Shape sh, Elt e) => Array sh e -> String -showShortendArr arr - = show (take cutoff l) ++ if length l > cutoff then ".." else "" +showShortendArr :: TupleType -> Array sh e -> String +showShortendArr tp arr + | length l > cutoff = "[" ++ elements ++ ", ..]" + | otherwise = "[" ++ elements ++ "]" where l = toList arr cutoff = 5 + elements = intercalate ", " $ map (showElement tp) $ take cutoff l 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" +showPreExpOp Let{} = "Let" +showPreExpOp (EVar (Var _ ix)) = "Var x" ++ show (idxToInt ix) +showPreExpOp (Const tp c) = "Const " ++ showElement tp c +showPreExpOp Undef = "Undef" +showPreExpOp Foreign{} = "Foreign" +showPreExpOp Pair{} = "Pair" +showPreExpOp Nil{} = "Nil" +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 Coerce{} = "Coerce" + +showElement :: TupleType e -> e -> String +showElement tuple value = showElement' tuple value "" + where + showElement' :: TupleType e -> e -> ShowS + showElement' TupRunit () = showString "()" + showElement' (TupRpair t1 t2) (e1, e2) = showString "(" . showElement' t1 e1 . showString ", " . showElement' t2 e2 . showString ")" + showElement' (TupRsingle tp) val = showScalar tp val + + showScalar :: ScalarType e -> e -> ShowS + showScalar (SingleScalarType t) e = showString $ showSingle t e + showScalar (VectorScalarType t) e = showString $ showVector t e + + showSingle :: SingleType e -> e -> String + showSingle (NumSingleType t) e = showNum t e + showSingle (NonNumSingleType t) e = showNonNum t e + + showNum :: NumType e -> e -> String + showNum (IntegralNumType t) e = showIntegral t e + showNum (FloatingNumType t) e = showFloating t e + + showIntegral :: IntegralType e -> e -> String + showIntegral TypeInt{} e = show e + showIntegral TypeInt8{} e = show e + showIntegral TypeInt16{} e = show e + showIntegral TypeInt32{} e = show e + showIntegral TypeInt64{} e = show e + showIntegral TypeWord{} e = show e + showIntegral TypeWord8{} e = show e + showIntegral TypeWord16{} e = show e + showIntegral TypeWord32{} e = show e + showIntegral TypeWord64{} e = show e + + showFloating :: FloatingType e -> e -> String + showFloating TypeHalf{} e = show e + showFloating TypeFloat{} e = show e + showFloating TypeDouble{} e = show e + + showNonNum :: NonNumType e -> e -> String + showNonNum TypeChar e = show e + showNonNum TypeBool e = show e + + showVector :: VectorType (Vec n a) e -> String + showVector (VectorType _ scalar) vec = "<" ++ (intercalate ", " $ showScalar scalar $ vecToArray vec) ++ ">" + diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index f1ede7162..a7936c225 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -1,15 +1,18 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Data @@ -29,11 +32,8 @@ module Data.Array.Accelerate.Array.Data ( -- * Array operations and representations - ArrayElt(..), ArrayData, MutableArrayData, runArrayData, - ArrayEltR(..), GArrayData(..), - - -- * Array tuple operations - fstArrayData, sndArrayData, pairArrayData, + ArrayData, MutableArrayData, runArrayData, GArrayData, rnfArrayData, ScalarData, + unsafeIndexArrayData, ptrOfArrayData, touchArrayData, newArrayData, unsafeReadArrayData, unsafeWriteArrayData, -- * Type macros HTYPE_INT, HTYPE_WORD, HTYPE_CLONG, HTYPE_CULONG, HTYPE_CCHAR, @@ -56,12 +56,10 @@ import Data.Array.Accelerate.Debug.Trace -- standard libraries import Control.Applicative import Control.Monad ( (<=<) ) +import Control.DeepSeq import Data.Bits -import Data.Char import Data.IORef -import Data.Kind import Data.Primitive ( sizeOf# ) -import Data.Typeable ( Typeable ) import Foreign.ForeignPtr import Foreign.Storable import Language.Haskell.TH hiding ( Type ) @@ -72,7 +70,7 @@ import Prelude hiding ( map import GHC.Base import GHC.ForeignPtr import GHC.Ptr -import GHC.TypeLits +import Data.Primitive.Types ( Prim ) -- Determine the underlying type of a Haskell CLong or CULong. @@ -123,152 +121,130 @@ type MutableArrayData e = GArrayData e -- In previous versions this was abstracted over by the mutable/immutable array -- representation, but this is now fixed to our UniqueArray type. -- -data family GArrayData a :: Type -data instance GArrayData () = AD_Unit -data instance GArrayData Int = AD_Int {-# UNPACK #-} !(UniqueArray Int) -data instance GArrayData Int8 = AD_Int8 {-# UNPACK #-} !(UniqueArray Int8) -data instance GArrayData Int16 = AD_Int16 {-# UNPACK #-} !(UniqueArray Int16) -data instance GArrayData Int32 = AD_Int32 {-# UNPACK #-} !(UniqueArray Int32) -data instance GArrayData Int64 = AD_Int64 {-# UNPACK #-} !(UniqueArray Int64) -data instance GArrayData Word = AD_Word {-# UNPACK #-} !(UniqueArray Word) -data instance GArrayData Word8 = AD_Word8 {-# UNPACK #-} !(UniqueArray Word8) -data instance GArrayData Word16 = AD_Word16 {-# UNPACK #-} !(UniqueArray Word16) -data instance GArrayData Word32 = AD_Word32 {-# UNPACK #-} !(UniqueArray Word32) -data instance GArrayData Word64 = AD_Word64 {-# UNPACK #-} !(UniqueArray Word64) -data instance GArrayData Half = AD_Half {-# UNPACK #-} !(UniqueArray Half) -data instance GArrayData Float = AD_Float {-# UNPACK #-} !(UniqueArray Float) -data instance GArrayData Double = AD_Double {-# UNPACK #-} !(UniqueArray Double) -data instance GArrayData Bool = AD_Bool {-# UNPACK #-} !(UniqueArray Word8) -data instance GArrayData Char = AD_Char {-# UNPACK #-} !(UniqueArray Char) -data instance GArrayData (Vec n a) = AD_Vec !Int# !(GArrayData a) -- sad this does not get unpacked ): -data instance GArrayData (a, b) = AD_Pair (GArrayData a) (GArrayData b) -- XXX: non-strict to support lazy device-host copying - -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 - ArrayEltRhalf :: ArrayEltR Half - ArrayEltRfloat :: ArrayEltR Float - ArrayEltRdouble :: ArrayEltR Double - ArrayEltRbool :: ArrayEltR Bool - ArrayEltRchar :: ArrayEltR Char - ArrayEltRpair :: ArrayEltR a -> ArrayEltR b -> ArrayEltR (a,b) - ArrayEltRvec :: (KnownNat n, ArrayPtrs (Vec n a) ~ ArrayPtrs a, ArrayPtrs a ~ Ptr a) => ArrayEltR a -> ArrayEltR (Vec n a) - -- XXX: Do we really require these embedded class constraints? +type family GArrayData a = r | r -> a where + GArrayData () = () + GArrayData (a, b) = (GArrayData a, GArrayData b) -- XXX: fields of tuple are non-strict, which enables lazy device-host copying + GArrayData a = ScalarData a + +type ScalarData a = UniqueArray (ScalarDataRepr a) + +-- Mapping from scalar type to the type as represented in memory in an array. +-- Booleans are stored as Word8, other types are represented as itself. +type family ScalarDataRepr tp where + ScalarDataRepr Int = Int + ScalarDataRepr Int8 = Int8 + ScalarDataRepr Int16 = Int16 + ScalarDataRepr Int32 = Int32 + ScalarDataRepr Int64 = Int64 + ScalarDataRepr Word = Word + ScalarDataRepr Word8 = Word8 + ScalarDataRepr Word16 = Word16 + ScalarDataRepr Word32 = Word32 + ScalarDataRepr Word64 = Word64 + ScalarDataRepr Half = Half + ScalarDataRepr Float = Float + ScalarDataRepr Double = Double + ScalarDataRepr Bool = Word8 + ScalarDataRepr Char = Char + ScalarDataRepr (Vec n tp) = ScalarDataRepr tp + +-- Utilities for working with the type families & type class instances +data ScalarDict e where + ScalarDict :: (Storable (ScalarDataRepr e), Prim (ScalarDataRepr e), ArrayData e ~ ScalarData e) => ScalarDict e + +{-# INLINE scalarDict #-} +scalarDict :: ScalarType e -> (Int, ScalarDict e) +scalarDict (SingleScalarType tp) + | (dict, _, _) <- singleDict tp = (1, dict) +scalarDict (VectorScalarType (VectorType n tp)) + | (ScalarDict, _, _) <- singleDict tp = (n, ScalarDict) + +{-# INLINE singleDict #-} +singleDict :: SingleType e -> (ScalarDict e, e -> ScalarDataRepr e, ScalarDataRepr e -> e) +singleDict (NonNumSingleType TypeBool) = (ScalarDict, fromBool, toBool) +singleDict (NonNumSingleType TypeChar) = (ScalarDict, id, id) +singleDict (NumSingleType (IntegralNumType tp)) = case tp of + TypeInt -> (ScalarDict, id, id) + TypeInt8 -> (ScalarDict, id, id) + TypeInt16 -> (ScalarDict, id, id) + TypeInt32 -> (ScalarDict, id, id) + TypeInt64 -> (ScalarDict, id, id) + TypeWord -> (ScalarDict, id, id) + TypeWord8 -> (ScalarDict, id, id) + TypeWord16 -> (ScalarDict, id, id) + TypeWord32 -> (ScalarDict, id, id) + TypeWord64 -> (ScalarDict, id, id) +singleDict (NumSingleType (FloatingNumType tp)) = case tp of + TypeHalf -> (ScalarDict, id, id) + TypeFloat -> (ScalarDict, id, id) + TypeDouble -> (ScalarDict, id, id) -- Array operations -- ---------------- -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 arrayElt #-} - {-# 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 () - --- 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. --- --- XXX: Currently there are _no_ (Vec n Bool) instances. We could use efficient --- bit-packed representations for these cases... --- -instance ArrayElt Bool where - type ArrayPtrs Bool = Ptr Word8 - arrayElt = ArrayEltRbool - {-# INLINE arrayElt #-} - {-# 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) - -instance (ArrayElt a, ArrayElt b) => ArrayElt (a, b) where - type ArrayPtrs (a, b) = (ArrayPtrs a, ArrayPtrs b) - arrayElt = ArrayEltRpair arrayElt arrayElt - {-# INLINEABLE arrayElt #-} - {-# INLINEABLE newArrayData #-} - {-# INLINEABLE ptrsOfArrayData #-} - {-# INLINEABLE ptrsOfMutableArrayData #-} - {-# INLINEABLE touchArrayData #-} - {-# INLINEABLE unsafeFreezeArrayData #-} - {-# INLINEABLE unsafeIndexArrayData #-} - {-# INLINEABLE unsafeReadArrayData #-} - {-# INLINEABLE 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 +-- Reads an element from an array +unsafeIndexArrayData :: TupleType e -> ArrayData e -> Int -> e +unsafeIndexArrayData TupRunit () !_ = () +unsafeIndexArrayData (TupRpair t1 t2) (a1, a2) !ix = (unsafeIndexArrayData t1 a1 ix, unsafeIndexArrayData t2 a2 ix) +unsafeIndexArrayData (TupRsingle (SingleScalarType tp)) arr ix + | (ScalarDict, _, to) <- singleDict tp = to $! unsafeIndexArray arr ix +-- VectorScalarType is handled in unsafeReadArrayData +unsafeIndexArrayData !tp !arr !ix = unsafePerformIO $! unsafeReadArrayData tp arr ix + +ptrOfArrayData :: ScalarType e -> ArrayData e -> Ptr (ScalarDataRepr e) +ptrOfArrayData tp arr + | (_, ScalarDict) <- scalarDict tp = unsafeUniqueArrayPtr arr + +touchArrayData :: TupleType e -> ArrayData e -> IO () +touchArrayData TupRunit () = return () +touchArrayData (TupRpair t1 t2) (a1, a2) = touchArrayData t1 a1 >> touchArrayData t2 a2 +touchArrayData (TupRsingle tp) arr + | (_, ScalarDict) <- scalarDict tp = touchUniqueArray arr + +newArrayData :: TupleType e -> Int -> IO (MutableArrayData e) +newArrayData TupRunit !_ = return () +newArrayData (TupRpair t1 t2) !size = (,) <$> newArrayData t1 size <*> newArrayData t2 size +newArrayData (TupRsingle tp) !size + | (n, ScalarDict) <- scalarDict tp = newArrayData' (n * size) + +unsafeReadArrayData :: forall e. TupleType e -> MutableArrayData e -> Int -> IO e +unsafeReadArrayData TupRunit () !_ = return () +unsafeReadArrayData (TupRpair t1 t2) (a1, a2) !ix = (,) <$> unsafeReadArrayData t1 a1 ix <*> unsafeReadArrayData t2 a2 ix +unsafeReadArrayData (TupRsingle (SingleScalarType tp)) arr !ix + | (ScalarDict, _, to) <- singleDict tp = to <$> unsafeReadArray arr ix +unsafeReadArrayData (TupRsingle (VectorScalarType (VectorType (I# w#) tp))) arr (I# ix#) + | (ScalarDict, _, _) <- singleDict tp = + let + !bytes# = w# *# sizeOf# (undefined :: ScalarDataRepr e) + !addr# = unPtr# (unsafeUniqueArrayPtr arr) `plusAddr#` (ix# *# bytes#) + in + IO $ \s -> + case newByteArray# bytes# s of { (# s1, mba# #) -> + case copyAddrToByteArray# addr# mba# 0# bytes# s1 of { s2 -> + case unsafeFreezeByteArray# mba# s2 of { (# s3, ba# #) -> + (# s3, Vec ba# #) + }}} + +unsafeWriteArrayData :: forall e. TupleType e -> MutableArrayData e -> Int -> e -> IO () +unsafeWriteArrayData TupRunit () !_ () = return () +unsafeWriteArrayData (TupRpair t1 t2) (a1, a2) !ix (v1, v2) + = unsafeWriteArrayData t1 a1 ix v1 + >> unsafeWriteArrayData t2 a2 ix v2 +unsafeWriteArrayData (TupRsingle (SingleScalarType tp)) arr !ix !val + | (ScalarDict, from, _) <- singleDict tp = unsafeWriteArray arr ix (from val) +unsafeWriteArrayData (TupRsingle (VectorScalarType (VectorType (I# w#) tp))) arr !(I# ix#) (Vec ba# :: Vec n t) + | (ScalarDict, _, _) <- singleDict tp = + let + !bytes# = w# *# sizeOf# (undefined :: ScalarDataRepr e) + !addr# = unPtr# (unsafeUniqueArrayPtr arr) `plusAddr#` (ix# *# bytes#) + in + IO $ \s -> case copyByteArrayToAddr# ba# 0# addr# bytes# s of + s1 -> (# s1, () #) +rnfArrayData :: TupleType e -> ArrayData e -> () +rnfArrayData TupRunit () = () +rnfArrayData (TupRpair t1 t2) (a1, a2) = rnfArrayData t1 a1 `seq` rnfArrayData t2 a2 +rnfArrayData (TupRsingle tp) arr = rnf $ ptrOfArrayData tp arr -- Auxiliary functions -- ------------------- @@ -371,110 +347,3 @@ mallocPlainForeignPtrBytesAligned (I# size) = IO $ \s -> case newAlignedPinnedByteArray# size 64# s of (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (PlainPtr mbarr#) #) - --- Instances --- --------- --- -$(runQ $ do - let - integralTypes :: [Name] - integralTypes = - [ ''Int - , ''Int8 - , ''Int16 - , ''Int32 - , ''Int64 - , ''Word - , ''Word8 - , ''Word16 - , ''Word32 - , ''Word64 - ] - - floatingTypes :: [Name] - floatingTypes = - [ ''Half - , ''Float - , ''Double - ] - - nonNumTypes :: [Name] - nonNumTypes = - [ ''Char -- wide characters are 4-bytes - --''Bool -- handled explicitly; stored as Word8 - ] - - allTypes :: [Name] - allTypes = integralTypes ++ floatingTypes ++ nonNumTypes - - mkSingleElt :: Name -> Q [Dec] - mkSingleElt name = - let - n = nameBase name - t = conT name - con = conE (mkName ("AD_" ++ n)) - pat = conP (mkName ("AD_" ++ n)) [varP (mkName "ba")] - in - [d| instance ArrayElt $t where - type ArrayPtrs $t = Ptr $t - arrayElt = $(conE (mkName ("ArrayEltR" ++ map toLower n))) - {-# INLINE arrayElt #-} - {-# INLINE newArrayData #-} - {-# INLINE ptrsOfArrayData #-} - {-# INLINE touchArrayData #-} - {-# INLINE unsafeIndexArrayData #-} - {-# INLINE unsafeReadArrayData #-} - {-# INLINE unsafeWriteArrayData #-} - newArrayData size = $con <$> newArrayData' size - ptrsOfArrayData $pat = unsafeUniqueArrayPtr ba - touchArrayData $pat = touchUniqueArray ba - unsafeIndexArrayData $pat i = unsafeIndexArray ba i - unsafeReadArrayData $pat i = unsafeReadArray ba i - unsafeWriteArrayData $pat i e = unsafeWriteArray ba i e - |] - - mkVectorElt :: Name -> Q [Dec] - mkVectorElt name = - let t = conT name - in - [d| instance KnownNat n => ArrayElt (Vec n $t) where - type ArrayPtrs (Vec n $t) = ArrayPtrs $t - arrayElt = ArrayEltRvec arrayElt - {-# INLINE arrayElt #-} - {-# INLINE newArrayData #-} - {-# INLINE ptrsOfArrayData #-} - {-# INLINE touchArrayData #-} - {-# INLINE unsafeIndexArrayData #-} - {-# INLINE unsafeReadArrayData #-} - {-# INLINE unsafeWriteArrayData #-} - newArrayData size = - let !w@(I# w#) = fromIntegral (natVal' (proxy# :: Proxy# n)) - in AD_Vec w# <$> newArrayData (w * size) - - ptrsOfArrayData (AD_Vec _ ba) = ptrsOfArrayData ba - touchArrayData (AD_Vec _ ba) = touchArrayData ba - unsafeIndexArrayData vec ix = unsafePerformIO $! unsafeReadArrayData vec ix - unsafeReadArrayData (AD_Vec w# ad) (I# ix#) = - let !bytes# = w# *# sizeOf# (undefined :: $t) - !addr# = unPtr# (ptrsOfArrayData ad) `plusAddr#` (ix# *# bytes#) - in - IO $ \s -> - case newByteArray# bytes# s of { (# s1, mba# #) -> - case copyAddrToByteArray# addr# mba# 0# bytes# s1 of { s2 -> - case unsafeFreezeByteArray# mba# s2 of { (# s3, ba# #) -> - (# s3, Vec ba# #) - }}} - unsafeWriteArrayData (AD_Vec w# ad) (I# ix#) (Vec ba#) = - let !bytes# = w# *# sizeOf# (undefined :: $t) - !addr# = unPtr# (ptrsOfArrayData ad) `plusAddr#` (ix# *# bytes#) - in - IO $ \s -> - case copyByteArrayToAddr# ba# 0# addr# bytes# s of - s1 -> (# s1, () #) - |] - -- - ss <- mapM mkSingleElt allTypes - vv <- mapM mkVectorElt allTypes - return (concat ss ++ concat vv) - ) - diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index 4a0d62b31..ac5386432 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -21,163 +22,193 @@ -- module Data.Array.Accelerate.Array.Representation ( + -- * Array data type in terms of representation types + Array(..), ArrayR(..), arraysRarray, arraysRtuple2, + ArraysR, TupleType, Scalar, Vector, Matrix, fromList, toList, -- * Array shapes, indices, and slices - Shape(..), Slice(..), SliceIndex(..), + ShapeR(..), Slice(..), SliceIndex(..), + DIM0, DIM1, DIM2, + + -- * Shape functions + rank, size, empty, ignore, intersect, union, toIndex, fromIndex, iter, iter1, + rangeToShape, shapeToRange, shapeToList, listToShape, listToShape', shapeType, -- * Slice shape functions - sliceShape, enumSlices, + sliceShape, sliceShapeR, enumSlices, ) where -- friends import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Array.Data -- standard library import GHC.Base ( quotInt, remInt ) +-- |Array data type, where the type arguments regard the representation types of the shape and elements. +data Array sh e where + Array :: sh -- extent of dimensions = shape + -> ArrayData e -- array payload + -> Array sh e + +{-# INLINEABLE fromList #-} +fromList :: ArrayR (Array sh e) -> sh -> [e] -> Array sh e +fromList (ArrayR shr tp) sh xs = adata `seq` Array 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 shr sh + (adata, _) = runArrayData $ do + arr <- newArrayData tp n + let go !i _ | i >= n = return () + go !i (v:vs) = unsafeWriteArrayData tp arr i 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 :: ArrayR (Array sh e) -> Array sh e -> [e] +toList (ArrayR shr tp) (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 = size shr sh + go !i | i >= n = [] + | otherwise = (unsafeIndexArrayData tp adata i) : go (i+1) + +type ArraysR = TupR ArrayR +data ArrayR a where + ArrayR :: ShapeR sh -> TupleType e -> ArrayR (Array sh e) + +arraysRarray :: ShapeR sh -> TupleType e -> ArraysR (Array sh e) +arraysRarray shr tp = TupRsingle $ ArrayR shr tp + +arraysRtuple2 :: ArrayR a -> ArrayR b -> ArraysR (((), a), b) +arraysRtuple2 a b = TupRpair TupRunit (TupRsingle a) `TupRpair` TupRsingle b + +type Scalar = Array DIM0 +type Vector = Array DIM1 +type Matrix = Array DIM2 -- |Index representation -- +type DIM0 = () +type DIM1 = ((), Int) +type DIM2 = (((), Int), Int) --- |Class of index representations (which are nested pairs) +-- |Index representations (which are nested pairs) -- -class (Eq sh, Slice sh) => Shape sh where - -- user-facing methods - rank :: 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 - listToShape' :: [Int] -> Maybe sh -- attempt to convert a list of dimensions into a shape - - listToShape ds = - case listToShape' ds of - Just sh -> sh - Nothing -> $internalError "listToShape" "unable to convert list to a shape at the specified type" - -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" - - listToShape' [] = Just () - listToShape' _ = Nothing - -instance Shape sh => Shape (sh, Int) where - rank = rank @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) | sz <= 0 = 0 - | otherwise = 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 cons" - listToShape (x:xs) = (listToShape xs,x) - - listToShape' [] = Nothing - listToShape' (x:xs) = do - xs' <- listToShape' xs - return (xs', x) + +data ShapeR sh where + ShapeRz :: ShapeR () + ShapeRcons :: ShapeR sh -> ShapeR (sh, Int) + +rank :: ShapeR sh -> Int +rank ShapeRz = 0 +rank (ShapeRcons shr) = rank shr + 1 + +size :: ShapeR sh -> sh -> Int +size ShapeRz () = 1 +size (ShapeRcons shr) (sh, sz) + | sz <= 0 = 0 + | otherwise = size shr sh * sz + +empty :: ShapeR sh -> sh +empty ShapeRz = () +empty (ShapeRcons shr) = (empty shr, 0) + +ignore :: ShapeR sh -> sh +ignore ShapeRz = () +ignore (ShapeRcons shr) = (ignore shr, -1) + +shapeZip :: (Int -> Int -> Int) -> ShapeR sh -> sh -> sh -> sh +shapeZip _ ShapeRz () () = () +shapeZip f (ShapeRcons shr) (as, a) (bs, b) = (shapeZip f shr as bs, f a b) + +intersect, union :: ShapeR sh -> sh -> sh -> sh +intersect = shapeZip min +union = shapeZip max + +toIndex :: ShapeR sh -> sh -> sh -> Int +toIndex ShapeRz () () = 0 +toIndex (ShapeRcons shr) (sh, sz) (ix, i) + = $indexCheck "toIndex" i sz + $ toIndex shr sh ix * sz + i + +fromIndex :: ShapeR sh -> sh -> Int -> sh +fromIndex ShapeRz () _ = () +fromIndex (ShapeRcons shr) (sh, sz) i + = (fromIndex shr 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 = case shr of -- Check if rank of shr is 0 + ShapeRz -> $indexCheck "fromIndex" i sz i + _ -> i `remInt` sz + +-- 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 +iter :: ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a -> a +iter ShapeRz () f _ _ = f () +iter (ShapeRcons shr) (sh, sz) f c r = iter shr sh (\ix -> iter' (ix,0)) c r + where + iter' (ix,i) | i >= sz = r + | otherwise = f (ix,i) `c` iter' (ix,i+1) + +-- variant of 'iter' without an initial value +iter1 :: ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a +iter1 ShapeRz () f _ = f () +iter1 (ShapeRcons _ ) (_, 0) _ _ = $boundsError "iter1" "empty iteration space" +iter1 (ShapeRcons shr) (sh, sz) f c = iter1 shr 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) + +-- Operations to facilitate conversion with IArray + +-- convert a minpoint-maxpoint index into a shape +rangeToShape :: ShapeR sh -> (sh, sh) -> sh +rangeToShape ShapeRz ((), ()) = () +rangeToShape (ShapeRcons shr) ((sh1, sz1), (sh2, sz2)) = (rangeToShape shr (sh1, sh2), sz2 - sz1 + 1) + +-- the converse +shapeToRange :: ShapeR sh -> sh -> (sh, sh) +shapeToRange ShapeRz () = ((), ()) +shapeToRange (ShapeRcons shr) (sh, sz) = let (low, high) = shapeToRange shr sh in ((low, 0), (high, sz - 1)) + +-- Other conversions + +-- Convert a shape into its list of dimensions +shapeToList :: ShapeR sh -> sh -> [Int] +shapeToList ShapeRz () = [] +shapeToList (ShapeRcons shr) (sh,sz) = sz : shapeToList shr sh + +-- Convert a list of dimensions into a shape +listToShape :: ShapeR sh -> [Int] -> sh +listToShape shr ds = case listToShape' shr ds of + Just sh -> sh + Nothing -> $internalError "listToShape" "unable to convert list to a shape at the specified type" + +-- Attempt to convert a list of dimensions into a shape +listToShape' :: ShapeR sh -> [Int] -> Maybe sh +listToShape' ShapeRz [] = Just () +listToShape' (ShapeRcons shr) (x:xs) = (, x) <$> listToShape' shr xs +listToShape' _ _ = Nothing + +shapeType :: ShapeR sh -> TupleType sh +shapeType ShapeRz = TupRunit +shapeType (ShapeRcons shr) = shapeType shr `TupRpair` (TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType TypeInt) -- |Slice representation -- @@ -234,6 +265,10 @@ sliceShape SliceNil () = () sliceShape (SliceAll sl) (sh, n) = (sliceShape sl sh, n) sliceShape (SliceFixed sl) (sh, _) = sliceShape sl sh +sliceShapeR :: SliceIndex slix sl co dim -> ShapeR sl +sliceShapeR SliceNil = ShapeRz +sliceShapeR (SliceAll sl) = ShapeRcons $ sliceShapeR sl +sliceShapeR (SliceFixed sl) = sliceShapeR sl -- | Enumerate all slices within a given bound. The innermost dimension changes -- most rapidly. diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 245009516..9443bc84d 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -31,13 +32,18 @@ -- module Data.Array.Accelerate.Array.Sugar ( + -- * Tuple representation + TupR(..), -- * Array representation Array(..), Scalar, Vector, Matrix, Segments, - Arrays(..), ArraysR(..), arraysRtuple2, + Arrays(..), Repr.ArraysR, Repr.ArrayR(..), Repr.arraysRarray, Repr.arraysRtuple2, -- * Class of supported surface element types and their mapping to representation types - Elt(..), + Elt(..), TupleType, + + -- * Stencils + Stencil(..), StencilR(..), -- * Derived functions liftToElt, liftToElt2, sinkFromElt, sinkFromElt2, @@ -173,7 +179,6 @@ data Split = Split data Divide sh = Divide deriving (Typeable, Show, Eq) - -- Scalar elements -- --------------- @@ -208,7 +213,7 @@ data Divide sh = Divide -- > data Point = Point Int Float -- > deriving (Show, Generic, Elt) -- -class (Show a, Typeable a, Typeable (EltRepr a), ArrayElt (EltRepr a)) => Elt a where +class (Show a, Typeable a, Typeable (EltRepr a)) => Elt a where -- | Type representation mapping, which explains how to convert a type from -- the surface type into the internal representation type consisting only of -- simple primitive types, unit '()', and pair '(,)'. @@ -224,7 +229,7 @@ class (Show a, Typeable a, Typeable (EltRepr a), ArrayElt (EltRepr a)) => Elt a default eltType :: (GElt (Rep a), EltRepr a ~ GEltRepr () (Rep a)) => TupleType (EltRepr a) - eltType = geltType @(Rep a) TypeRunit + eltType = geltType @(Rep a) TupRunit {-# INLINE [1] fromElt #-} default fromElt @@ -261,7 +266,7 @@ instance GElt a => GElt (M1 i c a) where instance Elt a => GElt (K1 i a) where type GEltRepr t (K1 i a) = (t, EltRepr a) - geltType t = TypeRpair t (eltType @a) + geltType t = TupRpair t (eltType @a) gfromElt t (K1 x) = (t, fromElt x) gtoElt (t, x) = (t, K1 (toElt x)) @@ -288,7 +293,7 @@ instance (GElt a, GElt b) => GElt (a :*: b) where -- > @(TupleType (EltRepr CShort)) -- > (eltType :: TupleType (EltRepr CShort)) -- --- Which yields the error "couldn't match type type 'EltRepr a0' with 'Int16'". +-- Which yields the error "couldn't match type 'EltRepr a0' with 'Int16'". -- Since this function returns a type family type, the type signature on the -- result is not enough to fix the type 'a'. Instead, we require the use of -- (visible) type applications: @@ -311,7 +316,7 @@ instance Elt () where {-# INLINE eltType #-} {-# INLINE toElt #-} {-# INLINE fromElt #-} - eltType = TypeRunit + eltType = TupRunit fromElt = id toElt = id @@ -320,7 +325,7 @@ instance Elt Z where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRunit + eltType = TupRunit fromElt Z = () toElt () = Z @@ -329,7 +334,7 @@ instance (Elt t, Elt h) => Elt (t:.h) where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRpair (eltType @t) (eltType @h) + eltType = TupRpair (eltType @t) (eltType @h) fromElt (t:.h) = (fromElt t, fromElt h) toElt (t, h) = toElt t :. toElt h @@ -338,7 +343,7 @@ instance Elt All where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRunit + eltType = TupRunit fromElt All = () toElt () = All @@ -347,7 +352,7 @@ instance Elt (Any Z) where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRunit + eltType = TupRunit fromElt _ = () toElt _ = Any @@ -356,7 +361,7 @@ instance Shape sh => Elt (Any (sh:.Int)) where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRpair (eltType @(Any sh)) TypeRunit + eltType = TupRpair (eltType @(Any sh)) TupRunit fromElt _ = (fromElt (Any @sh), ()) toElt _ = Any @@ -389,7 +394,7 @@ instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, -- Convenience functions -- singletonScalarType :: IsScalar a => TupleType a -singletonScalarType = TypeRscalar scalarType +singletonScalarType = TupRsingle scalarType {-# INLINE liftToElt #-} liftToElt :: (Elt a, Elt b) @@ -421,6 +426,114 @@ sinkFromElt2 f x y = fromElt $ f (toElt x) (toElt y) #-} +-- | 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 + + -- Foreign functions -- ----------------- @@ -488,15 +601,15 @@ class (Typeable a, Typeable (ArrRepr a)) => Arrays a where type ArrRepr a :: Type type ArrRepr a = GArrRepr () (Rep a) - arrays :: ArraysR (ArrRepr a) + arrays :: Repr.ArraysR (ArrRepr a) toArr :: ArrRepr a -> a fromArr :: a -> ArrRepr a {-# INLINE arrays #-} default arrays :: (GArrays (Rep a), ArrRepr a ~ GArrRepr () (Rep a)) - => ArraysR (ArrRepr a) - arrays = garrays @(Rep a) ArraysRunit + => Repr.ArraysR (ArrRepr a) + arrays = garrays @(Rep a) TupRunit {-# INLINE [1] toArr #-} default toArr @@ -516,10 +629,12 @@ class (Typeable a, Typeable (ArrRepr a)) => Arrays a where -- => a -> ArraysFlavour a -- flavour _ = gflavour @(Rep a) +arrayR :: forall sh e. (Shape sh, Elt e) => Repr.ArrayR (Repr.Array (EltRepr sh) (EltRepr e)) +arrayR = Repr.ArrayR (shapeR @sh) (eltType @e) class GArrays f where type GArrRepr t f - garrays :: ArraysR t -> ArraysR (GArrRepr t f) + garrays :: Repr.ArraysR t -> Repr.ArraysR (GArrRepr t f) gfromArr :: f a -> t -> GArrRepr t f gtoArr :: GArrRepr t f -> (t, f a) @@ -537,7 +652,7 @@ instance GArrays a => GArrays (M1 i c a) where instance Arrays a => GArrays (K1 i a) where type GArrRepr t (K1 i a) = (t, ArrRepr a) - garrays t = ArraysRpair t (arrays @a) + garrays t = TupRpair t (arrays @a) gfromArr (K1 x) t = (t, fromArr x) gtoArr (t, x) = (t, K1 (toArr x)) @@ -557,18 +672,18 @@ instance Arrays () where {-# INLINE arrays #-} {-# INLINE [1] fromArr #-} {-# INLINE [1] toArr #-} - arrays = ArraysRunit + arrays = TupRunit fromArr = id toArr = id instance (Shape sh, Elt e) => Arrays (Array sh e) where - type ArrRepr (Array sh e) = Array sh e + type ArrRepr (Array sh e) = Repr.Array (EltRepr sh) (EltRepr e) {-# INLINE arrays #-} {-# INLINE [1] fromArr #-} {-# INLINE [1] toArr #-} - arrays = ArraysRarray - fromArr = id - toArr = id + arrays = Repr.arraysRarray (shapeR @sh) (eltType @e) + fromArr (Array sh arrayData) = Repr.Array sh arrayData + toArr (Repr.Array sh arrayData) = Array sh arrayData instance (Arrays a, Arrays b) => Arrays (a, b) instance (Arrays a, Arrays b, Arrays c) => Arrays (a, b, c) @@ -597,17 +712,6 @@ instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, 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) - --- 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) - -arraysRtuple2 :: (Shape sh1, Elt e1, Shape sh2, Elt e2) => ArraysR (((), Array sh2 e2), Array sh1 e1) -arraysRtuple2 = ArraysRpair ArraysRunit ArraysRarray `ArraysRpair` ArraysRarray - {-# RULES "fromArr/toArr" forall a. fromArr (toArr a) = a "toArr/fromArr" forall a. toArr (fromArr a) = a @@ -739,28 +843,7 @@ instance Elt e => IsList (Vector e) where fromList xs = GHC.fromListN (length xs) xs instance (Shape sh, Elt e) => 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 ArrayEltRhalf (AD_Half ua) = rnf ua - go ArrayEltRfloat (AD_Float ua) = rnf ua - go ArrayEltRdouble (AD_Double ua) = rnf ua - go ArrayEltRbool (AD_Bool ua) = rnf ua - go ArrayEltRchar (AD_Char ua) = rnf ua - go (ArrayEltRvec r) (AD_Vec !_ a) = go r a `seq` () - go (ArrayEltRpair r1 r2) (AD_Pair a1 a2) = go r1 a1 `seq` go r2 a2 `seq` () - + rnf (Array sh ad) = Repr.size (shapeR @sh) sh `seq` rnfArrayData (eltType @e) ad -- | Scalar arrays hold a single element -- @@ -801,9 +884,11 @@ type DIM9 = DIM8:.Int -- |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) +class (Elt sh, Elt (Any sh), FullShape sh ~ sh, CoSliceShape sh ~ sh, SliceShape sh ~ Z) => Shape sh where + shapeR :: Repr.ShapeR (EltRepr sh) + -- |Number of dimensions of a /shape/ or /index/ (>= 0). rank :: Int @@ -874,37 +959,39 @@ class (Elt sh, Elt (Any sh), Repr.Shape (EltRepr sh), FullShape sh ~ sh, CoSlice {-# INLINE shapeToList #-} {-# INLINE listToShape #-} {-# INLINE listToShape' #-} - rank = Repr.rank @(EltRepr sh) - size = Repr.size . fromElt - empty = toElt Repr.empty + rank = Repr.rank (shapeR @sh) + size = Repr.size (shapeR @sh) . fromElt + empty = toElt $ Repr.empty $ shapeR @sh -- (#) 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) + ignore = toElt $ Repr.ignore $ shapeR @sh + intersect sh1 sh2 = toElt (Repr.intersect (shapeR @sh) (fromElt sh1) (fromElt sh2)) + union sh1 sh2 = toElt (Repr.union (shapeR @sh) (fromElt sh1) (fromElt sh2)) + fromIndex sh ix = toElt (Repr.fromIndex (shapeR @sh) (fromElt sh) ix) + toIndex sh ix = Repr.toIndex (shapeR @sh) (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 + iter sh f c r = Repr.iter (shapeR @sh) (fromElt sh) (f . toElt) c r + iter1 sh f r = Repr.iter1 (shapeR @sh) (fromElt sh) (f . toElt) r rangeToShape (low, high) - = toElt (Repr.rangeToShape (fromElt low, fromElt high)) + = toElt (Repr.rangeToShape (shapeR @sh) (fromElt low, fromElt high)) shapeToRange ix - = let (low, high) = Repr.shapeToRange (fromElt ix) + = let (low, high) = Repr.shapeToRange (shapeR @sh) (fromElt ix) in (toElt low, toElt high) - shapeToList = Repr.shapeToList . fromElt - listToShape = toElt . Repr.listToShape - listToShape' = fmap toElt . Repr.listToShape' + shapeToList = Repr.shapeToList (shapeR @sh) . fromElt + listToShape = toElt . Repr.listToShape (shapeR @sh) + listToShape' = fmap toElt . Repr.listToShape' (shapeR @sh) instance Shape Z where + shapeR = Repr.ShapeRz sliceAnyIndex = Repr.SliceNil sliceNoneIndex = Repr.SliceNil instance Shape sh => Shape (sh:.Int) where + shapeR = Repr.ShapeRcons (shapeR @sh) sliceAnyIndex = Repr.SliceAll (sliceAnyIndex @sh) sliceNoneIndex = Repr.SliceFixed (sliceNoneIndex @sh) @@ -990,22 +1077,22 @@ shape (Array sh _) = toElt sh -- the source and result arrays must be identical. -- {-# INLINE reshape #-} -reshape :: (Shape sh, Shape sh') => sh -> Array sh' e -> Array sh e +reshape :: forall sh sh' e. (Shape sh, Shape sh') => sh -> Array sh' e -> Array sh e reshape sh (Array sh' adata) - = $boundsCheck "reshape" "shape mismatch" (size sh == Repr.size sh') + = $boundsCheck "reshape" "shape mismatch" (size sh == Repr.size (shapeR @sh') sh') $ Array (fromElt sh) adata -- | Array indexing -- infixl 9 ! {-# INLINE [1] (!) #-} -(!) :: (Shape sh, Elt e) => Array sh e -> sh -> e -(!) (Array sh adata) ix = toElt (adata `unsafeIndexArrayData` toIndex (toElt sh) ix) +(!) :: forall sh e. (Shape sh, Elt e) => Array sh e -> sh -> e +(!) (Array sh adata) ix = toElt (unsafeIndexArrayData (eltType @e) adata $ toIndex (toElt sh) ix) infixl 9 !! {-# INLINE [1] (!!) #-} -(!!) :: Elt e => Array sh e -> Int -> e -(!!) (Array _ adata) i = toElt (adata `unsafeIndexArrayData` i) +(!!) :: forall sh e. Elt e => Array sh e -> Int -> e +(!!) (Array _ adata) i = toElt (unsafeIndexArrayData (eltType @e) adata i) {-# RULES "indexArray/DIM0" forall arr. arr ! Z = arr !! 0 @@ -1024,16 +1111,16 @@ fromFunction sh f = unsafePerformIO $! fromFunctionM sh (return . f) -- @since 1.2.0.0 -- {-# INLINEABLE fromFunctionM #-} -fromFunctionM :: (Shape sh, Elt e) => sh -> (sh -> IO e) -> IO (Array sh e) +fromFunctionM :: forall sh e. (Shape sh, Elt e) => sh -> (sh -> IO e) -> IO (Array sh e) fromFunctionM sh f = do let !n = size sh - arr <- newArrayData n + arr <- newArrayData (eltType @e) n -- let write !i | i >= n = return () | otherwise = do v <- f (fromIndex sh i) - unsafeWriteArrayData arr i (fromElt v) + unsafeWriteArrayData (eltType @e) arr i (fromElt v) write (i+1) -- write 0 @@ -1043,14 +1130,14 @@ fromFunctionM sh f = do -- | Create a vector from the concatenation of the given list of vectors. -- {-# INLINEABLE concatVectors #-} -concatVectors :: Elt e => [Vector e] -> Vector e +concatVectors :: forall e. 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) + arr <- newArrayData (eltType @e) len + sequence_ [ unsafeWriteArrayData (eltType @e) arr (i + k) (unsafeIndexArrayData (eltType @e) ad i) | (Array ((), n) ad, k) <- vs `zip` offsets , i <- [0 .. n - 1] ] return (arr, undefined) @@ -1058,9 +1145,9 @@ concatVectors vs = adata `seq` Array ((), len) adata -- | Creates a new, uninitialized Accelerate array. -- {-# INLINEABLE allocateArray #-} -allocateArray :: (Shape sh, Elt e) => sh -> IO (Array sh e) +allocateArray :: forall sh e. (Shape sh, Elt e) => sh -> IO (Array sh e) allocateArray sh = do - adata <- newArrayData (size sh) + adata <- newArrayData (eltType @e) (size sh) return $! Array (fromElt sh) adata @@ -1095,34 +1182,14 @@ allocateArray sh = do -- 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) +fromList :: forall sh e. (Shape sh, Elt e) => sh -> [e] -> Array sh e +fromList sh xs = toArr $ Repr.fromList (arrayR @sh @e) (fromElt sh) $ map fromElt xs -- | Convert an accelerated 'Array' to a list in row-major order. -- {-# INLINEABLE toList #-} toList :: forall sh e. (Shape sh, Elt 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) +toList = map toElt . Repr.toList (arrayR @sh @e) . fromArr -- | Nicely format a shape as a string -- diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index f7d09c80d..b098ae112 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -124,29 +124,29 @@ data NonNumDict a where -- | 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 + TypeInt :: IntegralType Int + TypeInt8 :: IntegralType Int8 + TypeInt16 :: IntegralType Int16 + TypeInt32 :: IntegralType Int32 + TypeInt64 :: IntegralType Int64 + TypeWord :: IntegralType Word + TypeWord8 :: IntegralType Word8 + TypeWord16 :: IntegralType Word16 + TypeWord32 :: IntegralType Word32 + TypeWord64 :: IntegralType Word64 -- | 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 + TypeHalf :: FloatingType Half + TypeFloat :: FloatingType Float + TypeDouble :: FloatingType Double -- | Non-numeric types supported in array computations. -- data NonNumType a where - TypeBool :: NonNumDict Bool -> NonNumType Bool -- marshalled to Word8 - TypeChar :: NonNumDict Char -> NonNumType Char + TypeBool :: NonNumType Bool -- marshalled to Word8 + TypeChar :: NonNumType Char -- | Numeric element types implement Num & Real -- @@ -177,25 +177,25 @@ data VectorType a where -- 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 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" instance Show (FloatingType a) where - show TypeHalf{} = "Half" - show TypeFloat{} = "Float" - show TypeDouble{} = "Double" + show TypeHalf = "Half" + show TypeFloat = "Float" + show TypeDouble = "Double" instance Show (NonNumType a) where - show TypeBool{} = "Bool" - show TypeChar{} = "Char" + show TypeBool = "Bool" + show TypeChar = "Char" instance Show (NumType a) where show (IntegralNumType ty) = show ty @@ -216,7 +216,6 @@ instance Show (ScalarType a) where show (SingleScalarType ty) = show ty show (VectorScalarType ty) = show ty - -- Querying scalar type representations -- @@ -260,51 +259,55 @@ class Typeable a => IsScalar a where -- 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 TypeInt = IntegralDict +integralDict TypeInt8 = IntegralDict +integralDict TypeInt16 = IntegralDict +integralDict TypeInt32 = IntegralDict +integralDict TypeInt64 = IntegralDict +integralDict TypeWord = IntegralDict +integralDict TypeWord8 = IntegralDict +integralDict TypeWord16 = IntegralDict +integralDict TypeWord32 = IntegralDict +integralDict TypeWord64 = IntegralDict floatingDict :: FloatingType a -> FloatingDict a -floatingDict (TypeHalf dict) = dict -floatingDict (TypeFloat dict) = dict -floatingDict (TypeDouble dict) = dict +floatingDict TypeHalf = FloatingDict +floatingDict TypeFloat = FloatingDict +floatingDict TypeDouble = FloatingDict nonNumDict :: NonNumType a -> NonNumDict a -nonNumDict (TypeBool dict) = dict -nonNumDict (TypeChar dict) = dict +nonNumDict TypeBool = NonNumDict +nonNumDict TypeChar = NonNumDict + --- Type representation +-- Tuple representation -- ------------------- -- --- Representation of product types, consisting of: +-- Both arrays (Acc) and expressions (Exp) may form tuples. These are represented +-- using as product types, consisting of: -- -- * unit (void) -- --- * scalar types: values which go in registers. These may be single value +-- * single array / scalar types +-- in case of expressions: 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) +data TupR s a where + TupRunit :: TupR s () + TupRsingle :: s a -> TupR s a + TupRpair :: TupR s a -> TupR s b -> TupR s (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 TupleType = TupR ScalarType -- Rename to EltR? +instance Show (TupR ScalarType a) where + show TupRunit = "()" + show (TupRsingle t) = show t + show (TupRpair a b) = "(" ++ show a ++ "," ++ show b ++")" -- Type-level bit sizes -- -------------------- @@ -357,18 +360,21 @@ data Vec (n::Nat) a = Vec ByteArray# type role Vec nominal representational instance (Show a, Prim a, KnownNat n) => Show (Vec n a) where - show (Vec ba#) = vec (go 0#) + show = vec . vecToArray where vec :: [a] -> String vec = show . group . encloseSep (flatAlt "< " "<") (flatAlt " >" ">") ", " . map viaShow - -- - go :: Int# -> [a] - go i# | isTrue# (i# <# n#) = indexByteArray# ba# i# : go (i# +# 1#) - | otherwise = [] - -- - !(I# n#) = fromIntegral (natVal' (proxy# :: Proxy# n)) + +vecToArray :: forall a n. (Prim a, KnownNat n) => Vec n a -> [a] +vecToArray (Vec ba#) = go 0# + where + go :: Int# -> [a] + go i# | isTrue# (i# <# n#) = indexByteArray# ba# i# : go (i# +# 1#) + | otherwise = [] + + !(I# n#) = fromIntegral (natVal' (proxy# :: Proxy# n)) instance Eq (Vec n a) where Vec ba1# == Vec ba2# = ByteArray ba1# == ByteArray ba2# @@ -571,7 +577,7 @@ $( runQ $ do mkIntegral :: Name -> Integer -> Q [Dec] mkIntegral t n = [d| instance IsIntegral $(conT t) where - integralType = $(conE (mkName ("Type" ++ nameBase t))) IntegralDict + integralType = $(conE (mkName ("Type" ++ nameBase t))) instance IsNum $(conT t) where numType = IntegralNumType integralType @@ -591,7 +597,7 @@ $( runQ $ do mkFloating :: Name -> Integer -> Q [Dec] mkFloating t n = [d| instance IsFloating $(conT t) where - floatingType = $(conE (mkName ("Type" ++ nameBase t))) FloatingDict + floatingType = $(conE (mkName ("Type" ++ nameBase t))) instance IsNum $(conT t) where numType = FloatingNumType floatingType @@ -608,7 +614,7 @@ $( runQ $ do mkNonNum :: Name -> Integer -> Q [Dec] mkNonNum t n = [d| instance IsNonNum $(conT t) where - nonNumType = $(conE (mkName ("Type" ++ nameBase t))) NonNumDict + nonNumType = $(conE (mkName ("Type" ++ nameBase t))) instance IsBounded $(conT t) where boundedType = NonNumBoundedType nonNumType From 584ecd16699d32b673f15d9f7760acee45d607c7 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 8 Jan 2020 17:04:35 +0100 Subject: [PATCH 141/316] fix collision in expression hashing --- src/Data/Array/Accelerate/Analysis/Hash.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 9da93010a..9f994325e 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -317,8 +317,16 @@ encodePreOpenExp -> Builder encodePreOpenExp options encodeAcc exp = let + -- XXX: Temporary fix for hashing expressions which only depend on + -- free array variables. For the code generating backends it will + -- never pick up expressions which differ only at free array + -- variables. We know that this will always be an Avar (we depend on + -- array expressions being floated out already) so we should change + -- this in the AST. This problem occurred in the Quickhull program. + -- -- TLM 2020-01-08 + -- travA :: forall aenv' a. Arrays a => acc aenv' a -> Builder - travA a = encodeArraysType (arrays @a) <> encodeAcc options a + travA a = encodeArraysType (arrays @a) <> encodeAcc (options {perfect=True}) a travE :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder travE e = encodeTupleType (eltType @e) <> encodePreOpenExp options encodeAcc e From 66aca3418ad583e5e85824bbcc1de39a78157034 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 12:10:49 +0100 Subject: [PATCH 142/316] fix segmented operator lifting for right-to-left scans --- src/Data/Array/Accelerate/Prelude.hs | 38 +++++++++++++++------------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 92ee22af2..c54f9a0e3 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -982,9 +982,9 @@ scanlSeg f z arr seg = -- 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. + -- This is done by 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 @@ -1135,7 +1135,7 @@ scanl1Seg -> Acc (Array (sh:.Int) e) scanl1Seg f arr seg = map snd - . scanl1 (segmented f) + . scanl1 (segmentedL f) $ zip (replicate (lift (indexTail (shape arr) :. All)) (mkHeadFlags seg)) arr -- |Segmented version of 'prescanl'. @@ -1315,7 +1315,7 @@ scanr1Seg -> Acc (Array (sh:.Int) e) scanr1Seg f arr seg = map snd - . scanr1 (flip (segmented f)) + . scanr1 (segmentedR f) $ zip (replicate (lift (indexTail (shape arr) :. All)) (mkTailFlags seg)) arr @@ -1383,23 +1383,25 @@ mkTailFlags 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. +-- | 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 +segmentedL :: (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)) + -> (Exp (i, e) -> Exp (i, e) -> Exp (i, e)) +segmentedL f (T2 aF aV) (T2 bF bV) = + T2 (aF .|. bF) + (bF /= 0 ? (bV, f aV bV)) + +segmentedR + :: (Elt e, Num i, Bits i) + => (Exp e -> Exp e -> Exp e) + -> (Exp (i, e) -> Exp (i, e) -> Exp (i, e)) +segmentedR f y x = segmentedL (flip f) x y --- |Index construction and destruction generalised to integral types. +-- | 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, From 13b10d6565ac67a9a966ffc957773a7a329fa55e Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 13:40:59 +0100 Subject: [PATCH 143/316] add pattern synonyms for True, False --- src/Data/Array/Accelerate.hs | 2 ++ src/Data/Array/Accelerate/Classes/Eq.hs | 17 +++++++++++++---- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index b290adae2..a57eaff05 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -339,6 +339,8 @@ module Data.Array.Accelerate ( pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, + pattern True_, pattern False_, + -- ** Scalar operations -- *** Introduction constant, diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 2b336a5ff..c99983182 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -17,6 +18,7 @@ module Data.Array.Accelerate.Classes.Eq ( + Bool(..), pattern True_, pattern False_, Eq(..), (&&), (||), @@ -36,6 +38,13 @@ import Language.Haskell.TH.Extra import qualified Prelude as P +pattern True_ :: Exp Bool +pattern True_ = Exp (Const True) + +pattern False_ :: Exp Bool +pattern False_ = Exp (Const False) + + infix 4 == infix 4 /= @@ -74,12 +83,12 @@ class Elt a => Eq a where instance Eq () where - _ == _ = constant True -- force arguments? - _ /= _ = constant False -- force arguments? + _ == _ = True_ + _ /= _ = False_ instance Eq Z where - (==) _ _ = constant True - (/=) _ _ = constant False + _ == _ = True_ + _ /= _ = False_ instance Eq sh => Eq (sh :. Int) where x == y = indexHead x == indexHead y && indexTail x == indexTail y From 85c9a5b406fd415364d35ef2730da9d4664d2319 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 13:41:17 +0100 Subject: [PATCH 144/316] add pattern synonyms for Nothing, Just These can only be used on the RHS of expressions --- src/Data/Array/Accelerate/Data/Maybe.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index f3e3901e0..8e5918edf 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -22,7 +23,7 @@ module Data.Array.Accelerate.Data.Maybe ( - Maybe(..), + Maybe(..), pattern Nothing_, pattern Just_, just, nothing, maybe, isJust, isNothing, fromMaybe, fromJust, justs, @@ -51,6 +52,14 @@ import Data.Maybe ( Maybe(..) import Prelude ( (.), ($), const, otherwise ) +pattern Nothing_ :: Elt a => Exp (Maybe a) +pattern Nothing_ <- _ + where Nothing_ = nothing + +pattern Just_ :: Elt a => Exp a -> Exp (Maybe a) +pattern Just_ <- _ + where Just_ = just + -- | Lift a value into a 'Just' constructor -- just :: Elt a => Exp a -> Exp (Maybe a) @@ -113,12 +122,12 @@ 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)))) + fmap f x = cond (isNothing x) Nothing_ (Just_ (f (fromJust x))) instance Eq a => Eq (Maybe a) where - ma == mb = cond (isNothing ma && isNothing mb) (constant True) + ma == mb = cond (isNothing ma && isNothing mb) True_ $ cond (isJust ma && isJust mb) (fromJust ma == fromJust mb) - $ constant False + $ False_ instance Ord a => Ord (Maybe a) where compare ma mb = cond (isJust ma && isJust mb) @@ -126,7 +135,7 @@ instance Ord a => Ord (Maybe a) where (compare (tag ma) (tag mb)) instance (Monoid (Exp a), Elt a) => Monoid (Exp (Maybe a)) where - mempty = constant Nothing + mempty = Nothing_ #if __GLASGOW_HASKELL__ < 804 mappend ma mb = cond (isNothing ma) mb $ cond (isNothing mb) ma From ea4d29b4565d4f2a0a9d95f796bb4b5ae16c9f09 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 13:41:36 +0100 Subject: [PATCH 145/316] add pattern synonyms for Left, Right These can only be used on the RHS of expressions --- src/Data/Array/Accelerate/Data/Either.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index 5881001fa..b0ebcd389 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -22,7 +23,7 @@ module Data.Array.Accelerate.Data.Either ( - Either(..), + Either(..), pattern Left_, pattern Right_, left, right, either, isLeft, isRight, fromLeft, fromRight, lefts, rights, @@ -52,6 +53,14 @@ import Data.Maybe import Prelude ( (.), ($), const, otherwise ) +pattern Left_ :: (Elt a, Elt b) => Exp a -> Exp (Either a b) +pattern Left_ <- _ + where Left_ = left + +pattern Right_ :: (Elt a, Elt b) => Exp b -> Exp (Either a b) +pattern Right_ <- _ + where Right_ = right + -- | Lift a value into the 'Left' constructor -- left :: forall a b. (Elt a, Elt b) => Exp a -> Exp (Either a b) @@ -123,7 +132,7 @@ instance Elt a => Functor (Either a) where 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 )) + , {- else -} False_ )) instance (Ord a, Ord b) => Ord (Either a b) where compare ex ey = isLeft ex && isLeft ey ? ( compare (fromLeft ex) (fromLeft ey) From 4cd524ac01b1f2fa5c78972d0a038074ea152158 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 13:42:17 +0100 Subject: [PATCH 146/316] convert uses of [un]lift to pattern synonyms --- src/Data/Array/Accelerate/Prelude.hs | 104 +++++++++++++-------------- 1 file changed, 50 insertions(+), 54 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index c54f9a0e3..fd1a12802 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -795,14 +795,14 @@ any f = or . map f and :: Shape sh => Acc (Array (sh:.Int) Bool) -> Acc (Array sh Bool) -and = fold (&&) (constant True) +and = fold (&&) 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) +or = fold (||) False_ -- | Compute the sum of elements along the innermost dimension of the array. To -- find the sum of the entire array, 'flatten' it first. @@ -973,10 +973,10 @@ scanlSeg -> Acc (Array (sh:.Int) e) scanlSeg f z arr seg = if null arr || null flags - then fill (lift (sh:.sz + length seg)) z + then fill (sh ::. sz + length seg) z else scanl1Seg f arr' seg' where - sh :. sz = unlift (shape arr) :: Exp sh :. Exp Int + sh ::. sz = shape arr -- Segmented exclusive scan is implemented by first injecting the seed -- element at the head of each segment, and then performing a segmented @@ -988,9 +988,9 @@ scanlSeg f z arr seg = -- 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))) + (fill (sh ::. sz + length seg) z) + (\ix -> let sx ::. i = ix + in sx ::. i + fromIntegral (inc ! I1 i)) (take (length flags) arr) -- Each element in the segments must be shifted to the right one additional @@ -1048,8 +1048,8 @@ scanl'Seg -> 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) + then T2 arr (fill (indexTail (shape arr) ::. length seg) z) + else T2 body sums where -- Segmented scan' is implemented by deconstructing a segmented exclusive -- scan, to separate the final value and scan body. @@ -1068,9 +1068,9 @@ scanl'Seg f z arr seg = 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))) + (indexTail (shape arr') ::. length seg) + (\ix -> let sz ::. i = ix + in sz ::. fromIntegral (tails ! I1 i)) arr' -- Slice out the body of each segment. @@ -1089,9 +1089,9 @@ scanl'Seg f z arr seg = 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))) + (indexTail (shape arr) ::. fromIntegral len) + (\ix -> let sz ::. i = ix + in sz ::. i + fromIntegral (inc ! I1 i)) arr' @@ -1198,10 +1198,10 @@ scanrSeg -> Acc (Array (sh:.Int) e) scanrSeg f z arr seg = if null arr || null flags - then fill (lift (sh :. sz + length seg)) z + then fill (sh ::. sz + length seg) z else scanr1Seg f arr' seg' where - sh :. sz = unlift (shape arr) :: Exp sh :. Exp Int + sh ::. sz = shape arr -- Using technique described for 'scanlSeg', where we intersperse the array -- with the seed element at the start of each segment, and then perform an @@ -1212,9 +1212,9 @@ scanrSeg f z arr seg = 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)) + (fill (sh ::. sz + length seg) z) + (\ix -> let sx ::. i = ix + in sx ::. i + fromIntegral (inc ! index1 i) - 1) (drop (sz - length flags) arr) @@ -1258,8 +1258,8 @@ scanr'Seg -> 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) + then T2 arr (fill (indexTail (shape arr) ::. length seg) z) + else T2 body sums where -- Using technique described for scanl'Seg -- @@ -1269,18 +1269,18 @@ scanr'Seg f z arr seg = 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))) + (indexTail (shape arr') ::. length seg) + (\ix -> let sz ::.i = ix + in sz ::. fromIntegral (heads ! I1 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))) + (indexTail (shape arr) ::. indexHead (shape flags)) + (\ix -> let sz ::. i = ix + in sz ::. i + fromIntegral (inc ! I1 i)) arr' @@ -1364,9 +1364,9 @@ 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 + T2 offset len = 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. @@ -1379,9 +1379,9 @@ 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 + T2 offset len = 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 @@ -1639,21 +1639,21 @@ filter p arr | Just Refl <- matchShapeType @sh @Z = let keep = map p arr - (target, len) = unlift $ scanl' (+) 0 (map boolToInt keep) + T2 target len = 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) + then T2 emptyArray (fill Z_ 0) + else T2 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) + T2 target len = scanl' (+) 0 (map boolToInt keep) + T2 offset valid = scanl' (+) 0 (flatten len) prj ix = if keep!ix then index1 $ offset!index1 (toIndex sz (indexTail ix)) + target!ix else ignore @@ -1661,8 +1661,8 @@ filter p arr result = permute const dummy prj arr in if null arr - then lift (emptyArray, fill sz 0) - else lift (result, len) + then T2 emptyArray (fill sz 0) + else T2 result len {-# NOINLINE filter #-} {-# RULES @@ -2220,10 +2220,8 @@ iterate -> 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)) + = let step (T2 i acc) = T2 (i+1) (f acc) + in snd $ while (\v -> fst v < n) step (T2 0 z) -- Scalar bulk operations @@ -2239,11 +2237,9 @@ sfoldl :: forall sh a b. (Shape sh, Elt a, Elt b) -> 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)) + = let n = indexHead (shape xs) + step (T2 i acc) = T2 (i+1) (acc `f` (xs ! (ix ::. i))) + in snd $ while (\v -> fst v < n) step (T2 0 z) -- Tuples @@ -2252,21 +2248,21 @@ sfoldl f z ix xs -- |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 +fst (T2 a _) = a -- |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 +afst (T2 a _) = a -- |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 +snd (T2 _ b) = b -- | 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 +asnd (T2 _ b) = b -- |Converts an uncurried function to a curried function. -- From c0d89b754ad1f5d8337030d542fddbd0826bb1ff Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 15:47:51 +0100 Subject: [PATCH 147/316] :set fileformat=unix --- src/Data/Array/Accelerate/Pattern.hs | 404 +++++++++++++-------------- 1 file changed, 202 insertions(+), 202 deletions(-) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 88c9c0cba..382999ae1 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -1,202 +1,202 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ <= 800 -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif --- | --- Module : Data.Array.Accelerate.Pattern --- Copyright : [2018..2019] The Accelerate Team --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.Pattern ( - - pattern Pattern, - pattern T2, pattern T3, pattern T4, pattern T5, pattern T6, - pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, - pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, - - pattern Z_, pattern Ix, pattern (::.), - pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, - pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, - -) where - -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Product -import Data.Array.Accelerate.Smart - -import Language.Haskell.TH hiding ( Exp ) -import Language.Haskell.TH.Extra - - --- | A pattern synonym for working with (product) data types. You can declare --- your own pattern synonyms based off of this. --- -pattern Pattern :: forall b a context. IsPattern context a b => b -> context a -pattern Pattern vars <- (destruct @context -> vars) - where Pattern = construct @context - -class IsPattern con a t where - construct :: t -> con a - destruct :: con a -> t - - --- | Pattern synonyms for indices, which may be more convenient to use than --- 'Data.Array.Accelerate.Lift.lift' and --- 'Data.Array.Accelerate.Lift.unlift'. --- -pattern Z_ :: Exp DIM0 -pattern Z_ = Pattern Z -{-# COMPLETE Z_ #-} - -infixl 3 ::. -pattern (::.) :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) -pattern a ::. b = Pattern (a :. b) -{-# COMPLETE (::.) #-} - -pattern Ix :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) -pattern a `Ix` b = a ::. b -{-# COMPLETE Ix #-} - --- IsPattern instances for Shape nil and cons --- -instance IsPattern Exp Z Z where - construct _ = Exp IndexNil - destruct _ = Z - -instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where - construct (a :. b) = Exp (a `IndexCons` b) - destruct t = Exp (IndexTail t) :. Exp (IndexHead t) - --- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of the --- (unremarkable) boilerplate for us, but since the implementation is a little --- tricky it is debatable whether or not this is a good idea... --- -$(runQ $ do - let - mkIsPattern' :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] - mkIsPattern' con cst tup prj nil snoc n = - let - xs = [ mkName ('x' : show i) | i <- [0 .. n-1]] - b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs - repr = foldl (\ts t -> [t| ($ts, $(varT t)) |]) [t| () |] xs - context = foldl (\ts t -> appT ts (appT cst (varT t))) (tupleT n) xs - -- - tix 0 = [| ZeroTupIdx |] - tix i = [| SuccTupIdx $(tix (i-1)) |] - get x i = [| $(conE con) ($prj $(tix i) $x) |] - in - [d| instance - ( IsProduct $cst a - , ProdRepr a ~ $repr - , $cst a - , $context - ) => IsPattern $(conT con) a $b where - construct $(tupP (map varP xs)) = $(conE con) ($tup $(foldl (\vs v -> appE (appE snoc vs) (varE v)) nil xs)) - destruct _x = $(tupE (map (get [|_x|]) [(n-1), (n-2) .. 0])) - |] - - mkIsPattern :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] - mkIsPattern _ _ _ _ _ _ 1 = return [] - mkIsPattern con cst smart prj nil pair n = do - let - xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - ts = map varT xs - a = tupT ts - b = tupT (map (conT con `appT`) ts) - context = tupT (map (cst `appT`) ts) - -- - get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] - get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) - -- - _x <- newName "_x" - [d| instance $context => IsPattern $(conT con) $a $b where - construct $(tupP (map (conP con . return . varP) xs)) = - $(conE con) $(foldl (\vs v -> appE smart (appE (appE pair vs) (varE v))) (appE smart nil) xs) - destruct $(conP con [varP _x]) = - $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0])) - |] - - mkExpPattern = mkIsPattern' (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] - mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] - -- - es <- mapM mkExpPattern [0..16] - as <- mapM mkAccPattern [0..16] - return $ concat (es ++ as) - ) - --- | Specialised pattern synonyms for tuples, which may be more convenient to --- use than 'Data.Array.Accelerate.Lift.lift' and --- 'Data.Array.Accelerate.Lift.unlift'. For example, to construct a pair: --- --- > let a = 4 :: Exp Int --- > let b = 2 :: Exp Float --- > let c = T2 a b -- :: Exp (Int, Float); equivalent to 'lift (a,b)' --- --- Similarly they can be used to destruct values: --- --- > let T2 x y = c -- x :: Exp Int, y :: Exp Float; equivalent to 'let (x,y) = unlift c' --- --- These pattern synonyms can be used for both 'Exp' and 'Acc' terms. --- --- Similarly, we have patterns for constructing and destructing indices of --- a given dimensionality: --- --- > let ix = Ix 2 3 -- :: Exp DIM2 --- > let I2 y x = ix -- y :: Exp Int, x :: Exp Int --- -$(runQ $ do - let - mkT :: Int -> Q [Dec] - mkT n = - let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - ts = map varT xs - name = mkName ('T':show n) - con = varT (mkName "con") - ty1 = tupT ts - ty2 = tupT (map (con `appT`) ts) - sig = foldr (\t r -> [t| $con $t -> $r |]) (appT con ty1) ts - in - sequence - [ patSynSigD name [t| IsPattern $con $ty1 $ty2 => $sig |] - , patSynD name (prefixPatSyn xs) implBidir [p| Pattern $(tupP (map varP xs)) |] - , pragCompleteD [name] (Just ''Acc) - , pragCompleteD [name] (Just ''Exp) - ] - - mkI :: Int -> Q [Dec] - mkI n = - let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - ts = map varT xs - name = mkName ('I':show n) - ix = mkName "Ix" - cst = tupT (map (\t -> [t| Elt $t |]) ts) - dim = foldl (\h t -> [t| $h :. $t |]) [t| Z |] ts - sig = foldr (\t r -> [t| Exp $t -> $r |]) [t| Exp $dim |] ts - in - sequence - [ patSynSigD name [t| $cst => $sig |] - , patSynD name (prefixPatSyn xs) implBidir (foldl (\ps p -> infixP ps ix (varP p)) [p| Z_ |] xs) - , pragCompleteD [name] Nothing - ] - -- - ts <- mapM mkT [2..16] - is <- mapM mkI [0..9] - return $ concat (ts ++ is) - ) - +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +#if __GLASGOW_HASKELL__ <= 800 +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} +#endif +-- | +-- Module : Data.Array.Accelerate.Pattern +-- Copyright : [2018..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Pattern ( + + pattern Pattern, + pattern T2, pattern T3, pattern T4, pattern T5, pattern T6, + pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, + pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, + + pattern Z_, pattern Ix, pattern (::.), + pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, + pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, + +) where + +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Smart + +import Language.Haskell.TH hiding ( Exp ) +import Language.Haskell.TH.Extra + + +-- | A pattern synonym for working with (product) data types. You can declare +-- your own pattern synonyms based off of this. +-- +pattern Pattern :: forall b a context. IsPattern context a b => b -> context a +pattern Pattern vars <- (destruct @context -> vars) + where Pattern = construct @context + +class IsPattern con a t where + construct :: t -> con a + destruct :: con a -> t + + +-- | Pattern synonyms for indices, which may be more convenient to use than +-- 'Data.Array.Accelerate.Lift.lift' and +-- 'Data.Array.Accelerate.Lift.unlift'. +-- +pattern Z_ :: Exp DIM0 +pattern Z_ = Pattern Z +{-# COMPLETE Z_ #-} + +infixl 3 ::. +pattern (::.) :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) +pattern a ::. b = Pattern (a :. b) +{-# COMPLETE (::.) #-} + +pattern Ix :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) +pattern a `Ix` b = a ::. b +{-# COMPLETE Ix #-} + +-- IsPattern instances for Shape nil and cons +-- +instance IsPattern Exp Z Z where + construct _ = Exp IndexNil + destruct _ = Z + +instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where + construct (a :. b) = Exp (a `IndexCons` b) + destruct t = Exp (IndexTail t) :. Exp (IndexHead t) + +-- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of the +-- (unremarkable) boilerplate for us, but since the implementation is a little +-- tricky it is debatable whether or not this is a good idea... +-- +$(runQ $ do + let + mkIsPattern' :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] + mkIsPattern' con cst tup prj nil snoc n = + let + xs = [ mkName ('x' : show i) | i <- [0 .. n-1]] + b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs + repr = foldl (\ts t -> [t| ($ts, $(varT t)) |]) [t| () |] xs + context = foldl (\ts t -> appT ts (appT cst (varT t))) (tupleT n) xs + -- + tix 0 = [| ZeroTupIdx |] + tix i = [| SuccTupIdx $(tix (i-1)) |] + get x i = [| $(conE con) ($prj $(tix i) $x) |] + in + [d| instance + ( IsProduct $cst a + , ProdRepr a ~ $repr + , $cst a + , $context + ) => IsPattern $(conT con) a $b where + construct $(tupP (map varP xs)) = $(conE con) ($tup $(foldl (\vs v -> appE (appE snoc vs) (varE v)) nil xs)) + destruct _x = $(tupE (map (get [|_x|]) [(n-1), (n-2) .. 0])) + |] + + mkIsPattern :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] + mkIsPattern _ _ _ _ _ _ 1 = return [] + mkIsPattern con cst smart prj nil pair n = do + let + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + a = tupT ts + b = tupT (map (conT con `appT`) ts) + context = tupT (map (cst `appT`) ts) + -- + get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] + get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) + -- + _x <- newName "_x" + [d| instance $context => IsPattern $(conT con) $a $b where + construct $(tupP (map (conP con . return . varP) xs)) = + $(conE con) $(foldl (\vs v -> appE smart (appE (appE pair vs) (varE v))) (appE smart nil) xs) + destruct $(conP con [varP _x]) = + $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0])) + |] + + mkExpPattern = mkIsPattern' (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] + mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] + -- + es <- mapM mkExpPattern [0..16] + as <- mapM mkAccPattern [0..16] + return $ concat (es ++ as) + ) + +-- | Specialised pattern synonyms for tuples, which may be more convenient to +-- use than 'Data.Array.Accelerate.Lift.lift' and +-- 'Data.Array.Accelerate.Lift.unlift'. For example, to construct a pair: +-- +-- > let a = 4 :: Exp Int +-- > let b = 2 :: Exp Float +-- > let c = T2 a b -- :: Exp (Int, Float); equivalent to 'lift (a,b)' +-- +-- Similarly they can be used to destruct values: +-- +-- > let T2 x y = c -- x :: Exp Int, y :: Exp Float; equivalent to 'let (x,y) = unlift c' +-- +-- These pattern synonyms can be used for both 'Exp' and 'Acc' terms. +-- +-- Similarly, we have patterns for constructing and destructing indices of +-- a given dimensionality: +-- +-- > let ix = Ix 2 3 -- :: Exp DIM2 +-- > let I2 y x = ix -- y :: Exp Int, x :: Exp Int +-- +$(runQ $ do + let + mkT :: Int -> Q [Dec] + mkT n = + let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + name = mkName ('T':show n) + con = varT (mkName "con") + ty1 = tupT ts + ty2 = tupT (map (con `appT`) ts) + sig = foldr (\t r -> [t| $con $t -> $r |]) (appT con ty1) ts + in + sequence + [ patSynSigD name [t| IsPattern $con $ty1 $ty2 => $sig |] + , patSynD name (prefixPatSyn xs) implBidir [p| Pattern $(tupP (map varP xs)) |] + , pragCompleteD [name] (Just ''Acc) + , pragCompleteD [name] (Just ''Exp) + ] + + mkI :: Int -> Q [Dec] + mkI n = + let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + name = mkName ('I':show n) + ix = mkName "Ix" + cst = tupT (map (\t -> [t| Elt $t |]) ts) + dim = foldl (\h t -> [t| $h :. $t |]) [t| Z |] ts + sig = foldr (\t r -> [t| Exp $t -> $r |]) [t| Exp $dim |] ts + in + sequence + [ patSynSigD name [t| $cst => $sig |] + , patSynD name (prefixPatSyn xs) implBidir (foldl (\ps p -> infixP ps ix (varP p)) [p| Z_ |] xs) + , pragCompleteD [name] Nothing + ] + -- + ts <- mapM mkT [2..16] + is <- mapM mkI [0..9] + return $ concat (ts ++ is) + ) + From aba31621536497a9ac4a6a57f18ff47763693ce5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 15:53:04 +0100 Subject: [PATCH 148/316] cleanups --- src/Data/Array/Accelerate/Prelude.hs | 158 +++++++++++++-------------- 1 file changed, 78 insertions(+), 80 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index fd1a12802..115a3cb0f 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- pattern synonyms -- | -- Module : Data.Array.Accelerate.Prelude -- Copyright : [2009..2019] The Accelerate Team @@ -175,7 +176,9 @@ imap :: (Shape sh, Elt a, Elt b) imap f xs = zipWith f (generate (shape xs) id) xs -- | Used to define the zipWith functions on more than two arrays -zipWithInduction :: (Shape sh, Elt a, Elt b) +-- +zipWithInduction + :: (Shape sh, Elt a, Elt b) => ((Exp (a,b) -> rest) -> Acc (Array sh (a,b)) -> result) -- The zipWith function operating on one fewer array -> (Exp a -> Exp b -> rest) -> Acc (Array sh a) @@ -284,7 +287,9 @@ zipWith9 = zipWithInduction zipWith8 -- | Used to define the izipWith functions on two or more arrays -izipWithInduction :: (Shape sh, Elt a, Elt b) +-- +izipWithInduction + :: (Shape sh, Elt a, Elt b) => ((Exp sh -> Exp (a,b) -> rest) -> Acc (Array sh (a,b)) -> result) -- The zipWith function operating on one fewer array -> (Exp sh -> Exp a -> Exp b -> rest) -> Acc (Array sh a) @@ -530,9 +535,9 @@ unzip3 :: (Shape sh, Elt a, Elt b, Elt 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 + get1 (T3 a _ _) = a + get2 (T3 _ b _) = b + get3 (T3 _ _ c) = c -- | Take an array of quadruples and return four arrays, analogous to 'unzip'. @@ -542,10 +547,10 @@ unzip4 :: (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)) 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 + get1 (T4 a _ _ _) = a + get2 (T4 _ b _ _) = b + get3 (T4 _ _ c _) = c + get4 (T4 _ _ _ d) = d -- | Take an array of 5-tuples and return five arrays, analogous to 'unzip'. -- @@ -554,11 +559,11 @@ unzip5 :: (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)) 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 + get1 (T5 a _ _ _ _) = a + get2 (T5 _ b _ _ _) = b + get3 (T5 _ _ c _ _) = c + get4 (T5 _ _ _ d _) = d + get5 (T5 _ _ _ _ e) = e -- | Take an array of 6-tuples and return six arrays, analogous to 'unzip'. -- @@ -568,12 +573,12 @@ unzip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f) , 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 + get1 (T6 a _ _ _ _ _) = a + get2 (T6 _ b _ _ _ _) = b + get3 (T6 _ _ c _ _ _) = c + get4 (T6 _ _ _ d _ _) = d + get5 (T6 _ _ _ _ e _) = e + get6 (T6 _ _ _ _ _ f) = f -- | Take an array of 7-tuples and return seven arrays, analogous to 'unzip'. -- @@ -586,13 +591,13 @@ 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 + get1 (T7 a _ _ _ _ _ _) = a + get2 (T7 _ b _ _ _ _ _) = b + get3 (T7 _ _ c _ _ _ _) = c + get4 (T7 _ _ _ d _ _ _) = d + get5 (T7 _ _ _ _ e _ _) = e + get6 (T7 _ _ _ _ _ f _) = f + get7 (T7 _ _ _ _ _ _ g) = g -- | Take an array of 8-tuples and return eight arrays, analogous to 'unzip'. -- @@ -605,16 +610,16 @@ 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 + get1 (T8 a _ _ _ _ _ _ _) = a + get2 (T8 _ b _ _ _ _ _ _) = b + get3 (T8 _ _ c _ _ _ _ _) = c + get4 (T8 _ _ _ d _ _ _ _) = d + get5 (T8 _ _ _ _ e _ _ _) = e + get6 (T8 _ _ _ _ _ f _ _) = f + get7 (T8 _ _ _ _ _ _ g _) = g + get8 (T8 _ _ _ _ _ _ _ h) = h --- | Take an array of 8-tuples and return eight arrays, analogous to 'unzip'. +-- | Take an array of 9-tuples and return nine 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)) @@ -625,15 +630,15 @@ 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 + get1 (T9 a _ _ _ _ _ _ _ _) = a + get2 (T9 _ b _ _ _ _ _ _ _) = b + get3 (T9 _ _ c _ _ _ _ _ _) = c + get4 (T9 _ _ _ d _ _ _ _ _) = d + get5 (T9 _ _ _ _ e _ _ _ _) = e + get6 (T9 _ _ _ _ _ f _ _ _) = f + get7 (T9 _ _ _ _ _ _ g _ _) = g + get8 (T9 _ _ _ _ _ _ _ h _) = h + get9 (T9 _ _ _ _ _ _ _ _ i) = i -- Reductions @@ -976,8 +981,6 @@ scanlSeg f z arr seg = then fill (sh ::. sz + length seg) z else scanl1Seg f arr' seg' where - sh ::. sz = shape arr - -- Segmented exclusive scan is implemented by first injecting the seed -- element at the head of each segment, and then performing a segmented -- inclusive scan. @@ -986,20 +989,20 @@ scanlSeg f z arr seg = -- overlaying the input data in all places other than at the start of -- a segment. -- - seg' = map (+1) seg - arr' = permute const - (fill (sh ::. sz + length seg) z) - (\ix -> let sx ::. i = ix - in sx ::. i + fromIntegral (inc ! I1 i)) - (take (length flags) arr) + sh ::. sz = shape arr + seg' = map (+1) seg + arr' = permute const + (fill (sh ::. sz + length seg) z) + (\(sx ::. i) -> sx ::. i + fromIntegral (inc ! I1 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 + flags = mkHeadFlags seg + inc = scanl1 (+) flags -- | Segmented version of 'scanl'' along the innermost dimension of an array. The @@ -1069,8 +1072,7 @@ scanl'Seg f z arr seg = tails = zipWith (+) seg $ prescanl (+) 0 seg' sums = backpermute (indexTail (shape arr') ::. length seg) - (\ix -> let sz ::. i = ix - in sz ::. fromIntegral (tails ! I1 i)) + (\(sz ::. i) -> sz ::. fromIntegral (tails ! I1 i)) arr' -- Slice out the body of each segment. @@ -1083,15 +1085,14 @@ scanl'Seg f z arr seg = -- offset = scanl1 (+) seg inc = scanl1 (+) - $ permute (+) (fill (index1 $ size arr + 1) 0) + $ permute (+) (fill (I1 $ size arr + 1) 0) (\ix -> index1' $ offset ! ix) (fill (shape seg) (1 :: Exp i)) - len = offset ! index1 (length offset - 1) + len = offset ! I1 (length offset - 1) body = backpermute (indexTail (shape arr) ::. fromIntegral len) - (\ix -> let sz ::. i = ix - in sz ::. i + fromIntegral (inc ! I1 i)) + (\(sz ::. i) -> sz ::. i + fromIntegral (inc ! I1 i)) arr' @@ -1213,8 +1214,7 @@ scanrSeg f z arr seg = seg' = map (+1) seg arr' = permute const (fill (sh ::. sz + length seg) z) - (\ix -> let sx ::. i = ix - in sx ::. i + fromIntegral (inc ! index1 i) - 1) + (\(sx ::. i) -> sx ::. i + fromIntegral (inc !! i) - 1) (drop (sz - length flags) arr) @@ -1270,8 +1270,7 @@ scanr'Seg f z arr seg = heads = prescanl (+) 0 seg' sums = backpermute (indexTail (shape arr') ::. length seg) - (\ix -> let sz ::.i = ix - in sz ::. fromIntegral (heads ! I1 i)) + (\(sz ::.i) -> sz ::. fromIntegral (heads ! I1 i)) arr' -- body segments @@ -1279,8 +1278,7 @@ scanr'Seg f z arr seg = inc = scanl1 (+) flags body = backpermute (indexTail (shape arr) ::. indexHead (shape flags)) - (\ix -> let sz ::. i = ix - in sz ::. i + fromIntegral (inc ! I1 i)) + (\(sz ::. i) -> sz ::. i + fromIntegral (inc ! I1 i)) arr' @@ -1349,7 +1347,7 @@ postscanrSeg f e vec seg -- Segmented scan helpers -- ---------------------- --- |Compute head flags vector from segment vector for left-scans. +-- | 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 @@ -1368,8 +1366,8 @@ mkHeadFlags 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. +-- | 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) @@ -1427,7 +1425,7 @@ flatten a | Just Refl <- matchShapeType @sh @DIM1 = a flatten a - = reshape (index1 (size a)) a + = reshape (I1 (size a)) a -- Enumeration and filling @@ -1478,7 +1476,7 @@ enumFromStepN -> Acc (Array sh e) enumFromStepN sh x y = reshape sh - $ generate (index1 $ shapeSize sh) + $ generate (I1 (shapeSize sh)) (\ix -> (fromIntegral (unindex1 ix :: Exp Int) * y) + x) -- Concatenation @@ -1640,8 +1638,8 @@ filter p arr = let keep = map p arr T2 target len = scanl' (+) 0 (map boolToInt keep) - prj ix = keep!ix ? ( index1 (target!ix), ignore ) - dummy = fill (index1 (the len)) undef + prj ix = keep!ix ? ( I1 (target!ix), ignore ) + dummy = fill (I1 (the len)) undef result = permute const dummy prj arr in if null arr @@ -1655,9 +1653,9 @@ filter p arr T2 target len = scanl' (+) 0 (map boolToInt keep) T2 offset valid = scanl' (+) 0 (flatten len) prj ix = if keep!ix - then index1 $ offset!index1 (toIndex sz (indexTail ix)) + target!ix + then I1 $ offset !! (toIndex sz (indexTail ix)) + target!ix else ignore - dummy = fill (index1 (the valid)) undef + dummy = fill (I1 (the valid)) undef result = permute const dummy prj arr in if null arr @@ -1743,8 +1741,8 @@ scatter -> 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 + pf ix = I1 (to ! ix) + input' = backpermute (shape to `intersect` shape input) id input -- | Conditionally overwrite elements of the destination by scattering values of @@ -1770,8 +1768,8 @@ scatterIf -> 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 + pf ix = pred (maskV ! ix) ? ( I1 (to ! ix), ignore ) + input' = backpermute (shape to `intersect` shape input) id input -- Permutations From 791370553c1c3a8f46485c88112999aed7ab059f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 16:33:43 +0100 Subject: [PATCH 149/316] add pattern synonym for complex numbers --- src/Data/Array/Accelerate/Data/Complex.hs | 136 ++++++++++------------ 1 file changed, 63 insertions(+), 73 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index bb5a89b90..d5f1d0e35 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -26,7 +27,7 @@ module Data.Array.Accelerate.Data.Complex ( -- * Rectangular from - Complex(..), + Complex(..), pattern (::+), real, imag, @@ -45,17 +46,23 @@ module Data.Array.Accelerate.Data.Complex ( import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Classes import Data.Array.Accelerate.Data.Functor +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude import Data.Array.Accelerate.Product import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type -import Prelude ( ($) ) import Data.Complex ( Complex(..) ) import qualified Data.Complex as C import qualified Prelude as P +infix 6 ::+ +pattern (::+) :: (Elt a, Elt (Complex a)) => Exp a -> Exp a -> Exp (Complex a) +pattern r ::+ c = Pattern (r, c) +{-# COMPLETE (::+) #-} + + -- 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 @@ -115,41 +122,32 @@ instance cst a => IsProduct cst (Complex a) where 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) + lift (r :+ i) = lift r ::+ 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 + unlift (r ::+ i) = 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 + r1 ::+ c1 == r2 ::+ c2 = r1 == r2 && c1 == c2 + r1 ::+ c1 /= r2 ::+ c2 = 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) + (+) = 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@(x ::+ y) = + if z == 0 + then z + else let r = magnitude z + in x/r ::+ y/r + abs z = magnitude z ::+ 0 + fromInteger n = 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) + fromRational x = fromRational x ::+ 0 + z / z' = (x*x''+y*y'') / d ::+ (y*x''-x*y'') / d where x :+ y = unlift z x' :+ y' = unlift z' @@ -160,69 +158,66 @@ instance (RealFloat a, Elt (Complex a)) => P.Fractional (Exp (Complex a)) where 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) = + pi = pi ::+ 0 + exp (x ::+ y) = let expx = exp x + in expx * cos y ::+ expx * sin y + log z = log (magnitude z) ::+ phase z + sqrt z@(x ::+ y) = if z == 0 then 0 - else lift $ u :+ (y < 0 ? (-v, v)) + else 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) + T2 u v = x < 0 ? (T2 v' u', T2 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) + if exp_r < 0 then inf ::+ 0 + else nan ::+ nan else if isInfinite r || isInfinite i - then if exp_r > 0 then lift (inf :+ 0) else + then if exp_r > 0 then inf ::+ 0 else if exp_r < 0 then 0 - else lift (nan :+ nan) + else nan ::+ nan else exp (log x * y) where - r :+ i = unlift x - exp_r :+ _ = unlift y + r ::+ i = x + exp_r ::+ _ = 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)) + sin (x ::+ y) = sin x * cosh y ::+ cos x * sinh y + cos (x ::+ y) = cos x * cosh y ::+ (- sin x * sinh y) + tan (x ::+ y) = (sinx*coshy ::+ cosx*sinhy) / (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) + sinh (x ::+ y) = cos y * sinh x ::+ sin y * cosh x + cosh (x ::+ y) = cos y * cosh x ::+ sin y * sinh x + tanh (x ::+ y) = (cosy*sinhx ::+ siny*coshx) / (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') + asin z@(x ::+ y) = y' ::+ (-x') where - x' :+ y' = unlift $ log ((complex ((-y):+x)) + sqrt (1 - z*z)) + x' ::+ y' = log (((-y) ::+ x) + sqrt (1 - z*z)) - acos z = complex $ y'' :+ (-x'') + acos z = y'' ::+ (-x'') where - x'' :+ y'' = unlift $ log (z + (complex ((-y') :+ x'))) - x' :+ y' = unlift $ sqrt (1 - z*z) + x'' ::+ y'' = log (z + ((-y') ::+ x')) + x' ::+ y' = sqrt (1 - z*z) - atan z@(unlift -> x :+ y) = complex $ y' :+ (-x') + atan z@(x ::+ y) = y' ::+ (-x') where - x' :+ y' = unlift $ log ((complex ((1-y):+x)) / sqrt (1+z*z)) + x' ::+ y' = log (((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))) @@ -230,22 +225,17 @@ instance (RealFloat a, Elt (Complex a)) => P.Floating (Exp (Complex a)) where instance (FromIntegral a b, Num b, Elt (Complex b)) => FromIntegral a (Complex b) where - fromIntegral x = lift (fromIntegral x :+ 0) + fromIntegral x = fromIntegral x ::+ 0 -- | @since 1.2.0.0 instance Functor Complex where - fmap f (unlift -> r :+ i) = lift (f r :+ f i) + fmap f (r ::+ i) = 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) = scaleFloat k (sqrt (sqr (scaleFloat mk r) + sqr (scaleFloat mk i))) +magnitude (r ::+ i) = scaleFloat k (sqrt (sqr (scaleFloat mk r) + sqr (scaleFloat mk i))) where k = max (exponent r) (exponent i) mk = -k @@ -257,13 +247,13 @@ magnitude (unlift -> r :+ i) = scaleFloat k (sqrt (sqr (scaleFloat mk r) + sqr ( -- @since 1.3.0.0 -- magnitude' :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp a -magnitude' (unlift -> r :+ i) = sqrt (r*r + i*i) +magnitude' (r ::+ i) = 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, Elt (Complex a)) => Exp (Complex a) -> Exp a -phase z@(unlift -> r :+ i) = +phase z@(r ::+ i) = if z == 0 then 0 else atan2 i r @@ -273,7 +263,7 @@ phase z@(unlift -> r :+ i) = -- 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) +polar z = T2 (magnitude z) (phase z) -- | Form a complex number from polar components of magnitude and phase. -- @@ -297,17 +287,17 @@ 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 +real (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 +imag (_ ::+ 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) +conjugate z = real z ::+ (- imag z) From 1d3e0d78e8a09a845db3418e42d91fc1484a256f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 16:34:11 +0100 Subject: [PATCH 150/316] use pattern synonyms instead of [un]tup* --- .../Array/Accelerate/Classes/RealFloat.hs | 76 +++++++++---------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs b/src/Data/Array/Accelerate/Classes/RealFloat.hs index 1ca0eae40..1fbe13985 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs @@ -27,6 +27,7 @@ module Data.Array.Accelerate.Classes.RealFloat ( import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -62,7 +63,7 @@ class (RealFrac a, Floating a) => RealFloat a where 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) + 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 @@ -78,14 +79,14 @@ class (RealFrac a, Floating a) => RealFloat a where -- | Corresponds to the second component of 'decodeFloat' exponent :: Exp a -> Exp Int exponent x = let (m,n) = decodeFloat x - in Exp $ Cond (m == 0) + 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)) + 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 @@ -134,8 +135,8 @@ instance RealFloat Half where isInfinite = mkIsInfinite isDenormalized = ieee754 "isDenormalized" (ieee754_f16_is_denormalized . mkBitcast) isNegativeZero = ieee754 "isNegativeZero" (ieee754_f16_is_negative_zero . mkBitcast) - decodeFloat = ieee754 "decodeFloat" (\x -> let (m,n) = untup2 $ ieee754_f16_decode (mkBitcast x) - in (fromIntegral m, n)) + decodeFloat = ieee754 "decodeFloat" (\x -> let T2 m n = ieee754_f16_decode (mkBitcast x) + in (fromIntegral m, n)) instance RealFloat Float where atan2 = mkAtan2 @@ -143,8 +144,8 @@ instance RealFloat Float where isInfinite = mkIsInfinite isDenormalized = ieee754 "isDenormalized" (ieee754_f32_is_denormalized . mkBitcast) isNegativeZero = ieee754 "isNegativeZero" (ieee754_f32_is_negative_zero . mkBitcast) - decodeFloat = ieee754 "decodeFloat" (\x -> let (m,n) = untup2 $ ieee754_f32_decode (mkBitcast x) - in (fromIntegral m, n)) + decodeFloat = ieee754 "decodeFloat" (\x -> let T2 m n = ieee754_f32_decode (mkBitcast x) + in (fromIntegral m, n)) instance RealFloat Double where atan2 = mkAtan2 @@ -152,7 +153,8 @@ instance RealFloat Double where isInfinite = mkIsInfinite isDenormalized = ieee754 "isDenormalized" (ieee754_f64_is_denormalized . mkBitcast) isNegativeZero = ieee754 "isNegativeZero" (ieee754_f64_is_negative_zero . mkBitcast) - decodeFloat = ieee754 "decodeFloat" (untup2 . ieee754_f64_decode . mkBitcast) + decodeFloat = ieee754 "decodeFloat" (\x -> let T2 m n = ieee754_f64_decode (mkBitcast x) + in (m, n)) instance RealFloat CFloat where atan2 = lift2 mkAtan2 @@ -160,7 +162,7 @@ instance RealFloat CFloat where isInfinite = mkIsInfinite . mkBitcast @Float isDenormalized = ieee754 "isDenormalized" (ieee754_f32_is_denormalized . mkBitcast) isNegativeZero = ieee754 "isNegativeZero" (ieee754_f32_is_negative_zero . mkBitcast) - decodeFloat = ieee754 "decodeFloat" (\x -> let (m,n) = untup2 $ ieee754_f32_decode (mkBitcast x) + decodeFloat = ieee754 "decodeFloat" (\x -> let T2 m n = ieee754_f32_decode (mkBitcast x) in (fromIntegral m, n)) encodeFloat x e = mkBitcast (encodeFloat @Float x e) @@ -170,7 +172,8 @@ instance RealFloat CDouble where isInfinite = mkIsInfinite . mkBitcast @Double isDenormalized = ieee754 "isDenormalized" (ieee754_f64_is_denormalized . mkBitcast) isNegativeZero = ieee754 "isNegativeZero" (ieee754_f64_is_negative_zero . mkBitcast) - decodeFloat = ieee754 "decodeFloat" (untup2 . ieee754_f64_decode . mkBitcast) + decodeFloat = ieee754 "decodeFloat" (\x -> let T2 m n = ieee754_f64_decode (mkBitcast x) + in (m, n)) encodeFloat x e = mkBitcast (encodeFloat @Double x e) @@ -321,15 +324,14 @@ ieee754_f16_decode i = exp1 = ((fromIntegral high1 `unsafeShiftR` 10) .&. 0x1F) + _HMINEXP exp2 = exp1 + 1 - (high3, exp3) - = untup2 - $ Exp $ Cond (exp1 /= _HMINEXP) + T2 high3 exp3 + = Exp $ Cond (exp1 /= _HMINEXP) -- don't add hidden bit to denorms - (tup2 (high2 .|. _HHIGHBIT, exp1)) + (T2 (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))) + (Exp $ While (\(T2 h _) -> (h .&. _HHIGHBIT) /= 0 ) + (\(T2 h e) -> T2 (h `unsafeShiftL` 1) (e-1)) + (T2 high2 exp2)) high4 = Exp $ Cond (fromIntegral i < (0 :: Exp Int16)) (-high3) high3 in @@ -356,27 +358,26 @@ ieee754_f32_decode i = exp1 = ((fromIntegral high1 `unsafeShiftR` 23) .&. 0xFF) + _FMINEXP exp2 = exp1 + 1 - (high3, exp3) - = untup2 - $ Exp $ Cond (exp1 /= _FMINEXP) + T2 high3 exp3 + = Exp $ Cond (exp1 /= _FMINEXP) -- don't add hidden bit to denorms - (tup2 (high2 .|. _FHIGHBIT, exp1)) + (T2 (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))) + (Exp $ While (\(T2 h _) -> (h .&. _FHIGHBIT) /= 0 ) + (\(T2 h e) -> T2 (h `unsafeShiftL` 1) (e-1)) + (T2 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)) + (T2 0 0) + (T2 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) + let T4 s h l e = ieee754_f64_decode2 i + in T2 (fromIntegral s * (fromIntegral h `unsafeShiftL` 32 .|. fromIntegral l)) e ieee754_f64_decode2 :: Exp Word64 -> Exp (Int, Word32, Word32, Int) ieee754_f64_decode2 i = @@ -396,21 +397,20 @@ ieee754_f64_decode2 i = high2 = high .&. (_DHIGHBIT - 1) iexp2 = iexp + 1 - (hi,lo,ie) - = untup3 - $ Exp $ Cond (iexp2 /= _DMINEXP) + T3 hi lo ie + = Exp $ Cond (iexp2 /= _DMINEXP) -- don't add hidden bit to denorms - (tup3 (high2 .|. _DHIGHBIT, low, iexp)) + (T3 (high2 .|. _DHIGHBIT) low iexp) -- a denorm, nermalise the mantissa - (Exp $ While (\(untup3 -> (h,_,_)) -> (h .&. _DHIGHBIT) /= 0) - (\(untup3 -> (h,l,e)) -> + (Exp $ While (\(T3 h _ _) -> (h .&. _DHIGHBIT) /= 0) + (\(T3 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 T3 h2 (l `unsafeShiftL` 1) (e-1)) + (T3 high2 low iexp2)) in Exp $ Cond (low == 0 && (high .&. (complement _DMSBIT)) == 0) - (tup4 (1,0,0,0)) - (tup4 (sign,hi,lo,ie)) + (T4 1 0 0 0) + (T4 sign hi lo ie) From b850fe43cd338f5555b447fa29329885ff7905d3 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jan 2020 16:37:31 +0100 Subject: [PATCH 151/316] disable specialised versions of fromInteger, fromRational This is to allow the use of RebindableSyntax in modules which mix Accelerate and plain Haskell code. This should work better now with the use of pattern synonyms rather than lift/unlift. --- src/Data/Array/Accelerate/Classes/Fractional.hs | 8 ++++---- src/Data/Array/Accelerate/Classes/Num.hs | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/Fractional.hs b/src/Data/Array/Accelerate/Classes/Fractional.hs index cd081b767..bb5fae615 100644 --- a/src/Data/Array/Accelerate/Classes/Fractional.hs +++ b/src/Data/Array/Accelerate/Classes/Fractional.hs @@ -16,7 +16,7 @@ module Data.Array.Accelerate.Classes.Fractional ( Fractional, - (P./), P.recip, fromRational, + (P./), P.recip, P.fromRational, ) where @@ -26,7 +26,7 @@ import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Num -import Prelude ( Rational, (.) ) +import Prelude ( (.) ) import qualified Prelude as P @@ -37,8 +37,8 @@ import qualified Prelude as P -- 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 +-- fromRational :: Fractional a => Rational -> Exp a +-- fromRational = P.fromRational -- | Fractional numbers, supporting real division diff --git a/src/Data/Array/Accelerate/Classes/Num.hs b/src/Data/Array/Accelerate/Classes/Num.hs index 15203639a..536be51d5 100644 --- a/src/Data/Array/Accelerate/Classes/Num.hs +++ b/src/Data/Array/Accelerate/Classes/Num.hs @@ -16,7 +16,7 @@ module Data.Array.Accelerate.Classes.Num ( Num, - (P.+), (P.-), (P.*), P.negate, P.abs, P.signum, fromInteger, + (P.+), (P.-), (P.*), P.negate, P.abs, P.signum, P.fromInteger, ) where @@ -24,7 +24,7 @@ import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type -import Prelude ( Integer, (.) ) +import Prelude ( (.) ) import qualified Prelude as P @@ -58,8 +58,8 @@ import qualified Prelude as P -- 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 +-- fromInteger :: Num a => Integer -> Exp a +-- fromInteger = P.fromInteger -- | Basic numeric class From ba678413aa4ff96367bb557bc774c6d2d8138841 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 17 Jan 2020 12:33:59 +0100 Subject: [PATCH 152/316] add pattern synonyms for Sum, Product --- src/Data/Array/Accelerate/Data/Monoid.hs | 34 +++++++++++++++--------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Monoid.hs b/src/Data/Array/Accelerate/Data/Monoid.hs index 1948c942a..d75af6cd4 100644 --- a/src/Data/Array/Accelerate/Data/Monoid.hs +++ b/src/Data/Array/Accelerate/Data/Monoid.hs @@ -3,9 +3,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE UndecidableInstances #-} @@ -28,8 +30,8 @@ module Data.Array.Accelerate.Data.Monoid ( Monoid(..), (<>), - Sum(..), - Product(..), + Sum(..), pattern Sum_, + Product(..), pattern Product_, ) where @@ -60,6 +62,10 @@ import qualified Prelude as P -- Sum: Monoid under addition -- -------------------------- +pattern Sum_ :: Elt a => Exp a -> Exp (Sum a) +pattern Sum_ x <- (unlift -> Sum x) + where Sum_ = lift . Sum + instance Elt a => Elt (Sum a) where type EltRepr (Sum a) = ((), EltRepr a) {-# INLINE eltType #-} @@ -83,8 +89,8 @@ 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) + minBound = Sum_ minBound + maxBound = Sum_ maxBound instance Num a => P.Num (Exp (Sum a)) where (+) = lift2 ((+) :: Sum (Exp a) -> Sum (Exp a) -> Sum (Exp a)) @@ -104,8 +110,8 @@ instance Ord a => Ord (Sum a) where (>) = 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 + min x y = Sum_ $ lift2 (min `on` getSum) x y + max x y = Sum_ $ lift2 (max `on` getSum) x y instance Num a => Monoid (Exp (Sum a)) where mempty = 0 @@ -121,13 +127,17 @@ instance Num a => Monoid (Exp (Sum a)) where -- | @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)) + stimes n x = Sum_ $ P.fromIntegral n * getSum (unlift x :: Sum (Exp a)) #endif -- Product: Monoid under multiplication -- ------------------------------------ +pattern Product_ :: Elt a => Exp a -> Exp (Product a) +pattern Product_ x <- (unlift -> Product x) + where Product_ = lift . Product + instance Elt a => Elt (Product a) where type EltRepr (Product a) = ((), EltRepr a) {-# INLINE eltType #-} @@ -151,8 +161,8 @@ 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) + minBound = Product_ minBound + maxBound = Product_ maxBound instance Num a => P.Num (Exp (Product a)) where (+) = lift2 ((+) :: Product (Exp a) -> Product (Exp a) -> Product (Exp a)) @@ -172,8 +182,8 @@ instance Ord a => Ord (Product a) where (>) = 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 + min x y = Product_ $ lift2 (min `on` getProduct) x y + max x y = Product_ $ lift2 (max `on` getProduct) x y instance Num a => Monoid (Exp (Product a)) where mempty = 1 @@ -189,7 +199,7 @@ instance Num a => Monoid (Exp (Product a)) where -- | @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) + stimes n x = Product_ $ getProduct (unlift x :: Product (Exp a)) ^ (P.fromIntegral n :: Exp Int) #endif From fec1ac401c6915bba64543246fcc7cfdbcf0b740 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 17 Jan 2020 12:54:09 +0100 Subject: [PATCH 153/316] add pattern synonyms for Min, Max --- src/Data/Array/Accelerate/Data/Semigroup.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Semigroup.hs b/src/Data/Array/Accelerate/Data/Semigroup.hs index 369bdcac5..01415eede 100644 --- a/src/Data/Array/Accelerate/Data/Semigroup.hs +++ b/src/Data/Array/Accelerate/Data/Semigroup.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -30,8 +31,8 @@ module Data.Array.Accelerate.Data.Semigroup ( Semigroup(..), - Min(..), - Max(..), + Min(..), pattern Min_, + Max(..), pattern Max_, ) where @@ -51,6 +52,10 @@ import Data.Semigroup import qualified Prelude as P +pattern Min_ :: Elt a => Exp a -> Exp (Min a) +pattern Min_ x <- (unlift -> Min x) + where Min_ = lift . Min + instance Elt a => Elt (Min a) where type EltRepr (Min a) = ((), EltRepr a) {-# INLINE eltType #-} @@ -107,6 +112,10 @@ instance (Ord a, Bounded a) => Monoid (Exp (Min a)) where mappend = (<>) +pattern Max_ :: Elt a => Exp a -> Exp (Max a) +pattern Max_ x <- (unlift -> Max x) + where Max_ = lift . Max + instance Elt a => Elt (Max a) where type EltRepr (Max a) = ((), EltRepr a) {-# INLINE eltType #-} From 2693873fbf7f94ee408d9f2017ff47251ee064ef Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 17 Jan 2020 14:08:27 +0100 Subject: [PATCH 154/316] clean up semigroup/monoid pattern and instance declations --- src/Data/Array/Accelerate/Data/Monoid.hs | 54 +++++------------ src/Data/Array/Accelerate/Data/Semigroup.hs | 64 +++++++-------------- 2 files changed, 35 insertions(+), 83 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Monoid.hs b/src/Data/Array/Accelerate/Data/Monoid.hs index d75af6cd4..7c217a161 100644 --- a/src/Data/Array/Accelerate/Data/Monoid.hs +++ b/src/Data/Array/Accelerate/Data/Monoid.hs @@ -42,8 +42,8 @@ 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.Pattern 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 () @@ -63,30 +63,18 @@ import qualified Prelude as P -- -------------------------- pattern Sum_ :: Elt a => Exp a -> Exp (Sum a) -pattern Sum_ x <- (unlift -> Sum x) - where Sum_ = lift . Sum - -instance Elt a => Elt (Sum a) where - type EltRepr (Sum a) = ((), EltRepr a) - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = TypeRpair TypeRunit (eltType @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 +pattern Sum_ x = Pattern x +{-# COMPLETE Sum_ #-} + +instance Elt a => Elt (Sum a) +instance Elt a => IsProduct Elt (Sum a) 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 + lift (Sum a) = Sum_ (lift a) instance Elt a => Unlift Exp (Sum (Exp a)) where - unlift t = Sum . Exp $ ZeroTupIdx `Prj` t + unlift (Sum_ a) = Sum a instance Bounded a => P.Bounded (Exp (Sum a)) where minBound = Sum_ minBound @@ -135,30 +123,18 @@ instance Num a => Semigroup (Exp (Sum a)) where -- ------------------------------------ pattern Product_ :: Elt a => Exp a -> Exp (Product a) -pattern Product_ x <- (unlift -> Product x) - where Product_ = lift . Product - -instance Elt a => Elt (Product a) where - type EltRepr (Product a) = ((), EltRepr a) - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = TypeRpair TypeRunit (eltType @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 +pattern Product_ x = Pattern x +{-# COMPLETE Product_ #-} + +instance Elt a => Elt (Product a) +instance Elt a => IsProduct Elt (Product a) 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 + lift (Product a) = Product_ (lift a) instance Elt a => Unlift Exp (Product (Exp a)) where - unlift t = Product . Exp $ ZeroTupIdx `Prj` t + unlift (Product_ a) = Product a instance Bounded a => P.Bounded (Exp (Product a)) where minBound = Product_ minBound diff --git a/src/Data/Array/Accelerate/Data/Semigroup.hs b/src/Data/Array/Accelerate/Data/Semigroup.hs index 01415eede..718527738 100644 --- a/src/Data/Array/Accelerate/Data/Semigroup.hs +++ b/src/Data/Array/Accelerate/Data/Semigroup.hs @@ -42,9 +42,9 @@ 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.Pattern import Data.Array.Accelerate.Product import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Type import Data.Function import Data.Monoid ( Monoid(..) ) @@ -53,30 +53,18 @@ import qualified Prelude as P pattern Min_ :: Elt a => Exp a -> Exp (Min a) -pattern Min_ x <- (unlift -> Min x) - where Min_ = lift . Min - -instance Elt a => Elt (Min a) where - type EltRepr (Min a) = ((), EltRepr a) - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = TypeRpair TypeRunit (eltType @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 +pattern Min_ x = Pattern x +{-# COMPLETE Min_ #-} + +instance Elt a => Elt (Min a) +instance Elt a => IsProduct Elt (Min a) 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 + lift (Min a) = Min_ (lift a) instance Elt a => Unlift Exp (Min (Exp a)) where - unlift t = Min . Exp $ ZeroTupIdx `Prj` t + unlift (Min_ a) = Min a instance Bounded a => P.Bounded (Exp (Min a)) where minBound = lift $ Min (minBound :: Exp a) @@ -113,34 +101,22 @@ instance (Ord a, Bounded a) => Monoid (Exp (Min a)) where pattern Max_ :: Elt a => Exp a -> Exp (Max a) -pattern Max_ x <- (unlift -> Max x) - where Max_ = lift . Max - -instance Elt a => Elt (Max a) where - type EltRepr (Max a) = ((), EltRepr a) - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = TypeRpair TypeRunit (eltType @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 +pattern Max_ x = Pattern x +{-# COMPLETE Max_ #-} + +instance Elt a => Elt (Max a) +instance Elt a => IsProduct Elt (Max a) 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 + lift (Max a) = Max_ (lift a) instance Elt a => Unlift Exp (Max (Exp a)) where - unlift t = Max . Exp $ ZeroTupIdx `Prj` t + unlift (Max_ a) = Max a instance Bounded a => P.Bounded (Exp (Max a)) where - minBound = lift $ Max (minBound :: Exp a) - maxBound = lift $ Max (maxBound :: Exp a) + minBound = Max_ minBound + maxBound = Max_ maxBound instance Num a => P.Num (Exp (Max a)) where (+) = lift2 ((+) :: Max (Exp a) -> Max (Exp a) -> Max (Exp a)) @@ -160,11 +136,11 @@ instance Ord a => Ord (Max a) where (>) = 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 + min x y = Max_ $ lift2 (min `on` getMax) x y + max x y = 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 + x <> y = Max_ $ lift2 (max `on` getMax) x y stimes = stimesIdempotent instance (Ord a, Bounded a) => Monoid (Exp (Max a)) where From 498311e556b4fa1830360ac58c6140a1adcc1efa Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 3 Mar 2020 15:48:30 +0100 Subject: [PATCH 155/316] stack: upgrade resolver --- .travis.yml | 2 +- stack-8.6.yaml | 2 +- stack-8.8.yaml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index cb85fc081..948582d3f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,7 +28,7 @@ addons: matrix: fast_finish: true include: - - env: GHC=8.8.1 + - env: GHC=8.8.2 compiler: "GHC 8.8" - env: GHC=8.6.5 diff --git a/stack-8.6.yaml b/stack-8.6.yaml index 855568ba2..1b11651c6 100644 --- a/stack-8.6.yaml +++ b/stack-8.6.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-14.3 +resolver: lts-14.27 packages: - . diff --git a/stack-8.8.yaml b/stack-8.8.yaml index f39de92cd..fe5ab32f3 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: nightly-2019-12-13 +resolver: lts-15.2 packages: - . From 0aea2ec62c5c9923b297ae62ce2512addedbfa0c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 3 Mar 2020 15:55:48 +0100 Subject: [PATCH 156/316] minor cleanups --- src/Data/Array/Accelerate/Prelude.hs | 37 +++++++++++++--------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 115a3cb0f..d476886c3 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -1517,7 +1517,7 @@ enumFromStepN sh x y -- 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 12, 13, 14] -- infixr 5 ++ -(++) :: forall sh e. (Shape sh, Elt e) +(++) :: (Shape sh, Elt e) => Acc (Array (sh :. Int) e) -> Acc (Array (sh :. Int) e) -> Acc (Array (sh :. Int) e) @@ -1909,7 +1909,7 @@ transposeOn dim1 dim2 xs = -- 30, 31, 32, 33, 34, -- 40, 41, 42, 43, 44] -- -take :: forall sh e. (Shape sh, Elt e) +take :: (Shape sh, Elt e) => Exp Int -> Acc (Array (sh :. Int) e) -> Acc (Array (sh :. Int) e) @@ -1936,7 +1936,7 @@ take = takeOn _1 -- 37, 38, 39, -- 47, 48, 49] -- -drop :: forall sh e. (Shape sh, Elt e) +drop :: (Shape sh, Elt e) => Exp Int -> Acc (Array (sh :. Int) e) -> Acc (Array (sh :. Int) e) @@ -1962,7 +1962,7 @@ drop = dropOn _1 -- 30, 31, 32, 33, 34, 35, 36, 37, 38, -- 40, 41, 42, 43, 44, 45, 46, 47, 48] -- -init :: forall sh e. (Shape sh, Elt e) +init :: (Shape sh, Elt e) => Acc (Array (sh :. Int) e) -> Acc (Array (sh :. Int) e) init = initOn _1 @@ -1988,7 +1988,7 @@ init = initOn _1 -- 31, 32, 33, 34, 35, 36, 37, 38, 39, -- 41, 42, 43, 44, 45, 46, 47, 48, 49] -- -tail :: forall sh e. (Shape sh, Elt e) +tail :: (Shape sh, Elt e) => Acc (Array (sh :. Int) e) -> Acc (Array (sh :. Int) e) tail = tailOn _1 @@ -1999,7 +1999,7 @@ tail = tailOn _1 -- -- > slit i n = take n . drop i -- -slit :: forall sh e. (Shape sh, Elt e) +slit :: (Shape sh, Elt e) => Exp Int -- ^ starting index -> Exp Int -- ^ length -> Acc (Array (sh :. Int) e) @@ -2212,7 +2212,7 @@ instance IfThenElse Acc where -- | Repeatedly apply a function a fixed number of times -- iterate - :: forall a. Elt a + :: Elt a => Exp Int -> (Exp a -> Exp a) -> Exp a @@ -2228,7 +2228,7 @@ iterate n f z -- | 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, Elt a, Elt b) +sfoldl :: (Shape sh, Elt a, Elt b) => (Exp a -> Exp b -> Exp a) -> Exp a -> Exp sh @@ -2245,21 +2245,21 @@ sfoldl f z ix xs -- |Extract the first component of a scalar pair. -- -fst :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp a +fst :: (Elt a, Elt b) => Exp (a, b) -> Exp a fst (T2 a _) = a -- |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 :: (Arrays a, Arrays b) => Acc (a, b) -> Acc a afst (T2 a _) = a -- |Extract the second component of a scalar pair. -- -snd :: forall a b. (Elt a, Elt b) => Exp (a, b) -> Exp b +snd :: (Elt a, Elt b) => Exp (a, b) -> Exp b snd (T2 _ b) = b -- | Extract the second component of an array pair -asnd :: forall a b. (Arrays a, Arrays b) => Acc (a, b) -> Acc b +asnd :: (Arrays a, Arrays b) => Acc (a, b) -> Acc b asnd (T2 _ b) = b -- |Converts an uncurried function to a curried function. @@ -2303,12 +2303,10 @@ 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 + :: Elt 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) +unindex2 (Z_ ::. i ::. j) = T2 i j -- | Create a rank-3 index from three Exp Int`s -- @@ -2318,15 +2316,14 @@ index3 -> Exp i -> Exp i -> Exp (Z :. i :. i :. i) -index3 k j i = lift (Z :. k :. j :. i) +index3 k j i = Z_ ::. k ::. j ::. i -- | Destruct a rank-3 index into an Exp tuple of Int`s unindex3 - :: forall i. Elt i + :: Elt 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) +unindex3 (Z_ ::. k ::. j ::. i) = T3 k j i -- Array operations with a scalar result From d708719e157bcc342d3fe257ae17d00bb0d382b9 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 5 Mar 2020 13:58:36 +0100 Subject: [PATCH 157/316] =?UTF-8?q?add=20prelude=20operation=20=E2=80=98ex?= =?UTF-8?q?pand=E2=80=99=20and=20example?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Array/Accelerate.hs | 3 + src/Data/Array/Accelerate/Prelude.hs | 103 ++++++++++++++++++++++++++- 2 files changed, 105 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index a57eaff05..39da125b3 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -198,6 +198,9 @@ module Data.Array.Accelerate ( -- *** Concatenation (++), concatOn, + -- *** Expansion + expand, + -- ** Composition -- *** Flow control (?|), acond, awhile, diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index d476886c3..8cc4957a1 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -109,6 +109,9 @@ module Data.Array.Accelerate.Prelude ( -- * Array operations with a scalar result the, null, length, + -- * Irregular data-parallelism + expand, + -- * Sequence operations -- fromSeq, fromSeqElems, fromSeqShapes, toSeqInner, toSeqOuter2, toSeqOuter3, generateSeq, @@ -2347,9 +2350,107 @@ length :: Elt e => Acc (Vector e) -> Exp Int length = unindex1 . shape +-- Operations to facilitate irregular data parallelism +-- --------------------------------------------------- + +-- | A recipe for generating flattened implementations of some kinds of +-- irregular nested parallelism. Given two functions that: +-- +-- (1) for each source element, determine how many target +-- elements it expands into; and +-- +-- (2) computes a particular target element based on a source element and +-- the target element index associated with the source +-- +-- The following example implements the Sieve of Eratosthenes, +-- a contraction style algorithm which first computes all primes less than +-- /sqrt n/, then uses this intermediate result to sieve away all numbers +-- in the range /[sqrt n .. n]/. The 'expand' function is used to calculate +-- and flatten the sieves. For each prime /p/ and upper limit /c2/, +-- function /sz/ computes the number of contributions in the sieve. Then, +-- for each prime /p/ and sieve index /i/, the function /get/ computes the +-- sieve contribution. The final step produces all the new primes in the +-- interval /[c1 .. c2]/. +-- +-- >>> :{ +-- primes :: Exp Int -> Acc (Vector Int) +-- primes n = afst loop +-- where +-- c0 = unit 2 +-- a0 = use $ fromList (Z:.0) [] +-- limit = truncate (sqrt (fromIntegral (n+1) :: Exp Float)) +-- loop = awhile +-- (\(T2 _ c) -> map (< n+1) c) +-- (\(T2 old c) -> +-- let c1 = the c +-- c2 = c1 < limit ? ( c1*c1, n+1 ) +-- -- +-- sieves = +-- let sz p = (c2 - p) `quot` p +-- get p i = (2+i)*p +-- in +-- map (subtract c1) (expand sz get old) +-- -- +-- new = +-- let m = c2-c1 +-- put i = let s = sieves ! i +-- in s >= 0 && s < m ? (I1 s, ignore) +-- in +-- afst +-- $ filter (> 0) +-- $ permute const (enumFromN (I1 m) c1) put +-- $ fill (shape sieves) 0 +-- in +-- T2 (old ++ new) (unit c2)) +-- (T2 a0 c0) +-- :} +-- +-- >>> run $ primes 100 +-- Vector (Z :. 25) [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97] +-- +-- Inspired by the paper /Data-Parallel Flattening by Expansion/ by Martin +-- Elsman, Troels Henddriksen, and Niels Gustav Westphal Serup, ARRAY'19. +-- +-- @since 1.4.0.0 +-- +expand :: (Elt a, Elt b) + => (Exp a -> Exp Int) + -> (Exp a -> Exp Int -> Exp b) + -> Acc (Vector a) + -> Acc (Vector b) +expand f g xs = + if length xs == 0 + then use $ fromList (Z:.0) [] + else + let + szs = map f xs + T2 offset len = scanl' (+) 0 szs + + m = the len + n = m + 1 + put ix = I1 (offset ! ix) + + head_flags :: Acc (Vector Int) + head_flags = permute const (fill (I1 n) 0) put (fill (shape szs) 1) + + idxs = map (subtract 1) + $ map snd + $ scanl1 (segmentedL (+)) + $ zip head_flags + $ fill (I1 m) 1 + + iotas = map snd + $ scanl1 (segmentedL const) + $ zip head_flags + $ permute const (fill (I1 n) undef) put + $ enumFromN (shape xs) 0 + in + zipWith g (gather iotas xs) idxs + + {-- -- Sequence operations --- -------------------------------------- +-- ------------------- -- | Reduce a sequence by appending all the shapes and all the elements in two -- separate vectors. From cc78ca8ba7397b445418e0646111753ec86bfcdd Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 5 Mar 2020 17:04:14 +0100 Subject: [PATCH 158/316] fix doctest --- src/Data/Array/Accelerate/Prelude.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 8cc4957a1..dbc39e2c8 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -144,6 +144,7 @@ import Data.Array.Accelerate.Classes.Ord import Data.Array.Accelerate.Data.Bits -- $setup +-- >>> :seti -XFlexibleContexts -- >>> import Data.Array.Accelerate -- >>> import Data.Array.Accelerate.Interpreter -- >>> :{ From 4c9362750201c23a72396b005c3e5349bce5b1bd Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Mon, 9 Mar 2020 17:42:58 +0100 Subject: [PATCH 159/316] Refactor tuple to pairs and use repr type for exps --- src/Data/Array/Accelerate/AST.hs | 937 +++++---- src/Data/Array/Accelerate/Analysis/Hash.hs | 213 +- src/Data/Array/Accelerate/Analysis/Match.hs | 374 ++-- src/Data/Array/Accelerate/Analysis/Shape.hs | 18 +- src/Data/Array/Accelerate/Analysis/Stencil.hs | 95 +- src/Data/Array/Accelerate/Analysis/Type.hs | 62 +- src/Data/Array/Accelerate/Array/Data.hs | 8 +- .../Array/Accelerate/Array/Remote/Class.hs | 14 +- src/Data/Array/Accelerate/Array/Remote/LRU.hs | 186 +- .../Array/Accelerate/Array/Remote/Table.hs | 230 ++- .../Array/Accelerate/Array/Representation.hs | 260 ++- src/Data/Array/Accelerate/Array/Sugar.hs | 222 +-- src/Data/Array/Accelerate/Classes/Eq.hs | 60 +- src/Data/Array/Accelerate/Classes/Floating.hs | 83 +- .../Array/Accelerate/Classes/Fractional.hs | 23 +- src/Data/Array/Accelerate/Classes/Integral.hs | 116 +- src/Data/Array/Accelerate/Classes/Num.hs | 134 +- src/Data/Array/Accelerate/Classes/Ord.hs | 175 +- .../Array/Accelerate/Classes/RealFloat.hs | 102 +- src/Data/Array/Accelerate/Classes/RealFrac.hs | 33 +- src/Data/Array/Accelerate/Data/Bits.hs | 367 ++-- src/Data/Array/Accelerate/Data/Complex.hs | 24 +- src/Data/Array/Accelerate/Data/Monoid.hs | 37 +- src/Data/Array/Accelerate/Data/Semigroup.hs | 38 +- src/Data/Array/Accelerate/Language.hs | 193 +- src/Data/Array/Accelerate/Lift.hs | 85 +- src/Data/Array/Accelerate/Pattern.hs | 62 +- src/Data/Array/Accelerate/Prelude.hs | 8 +- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 149 +- src/Data/Array/Accelerate/Pretty/Print.hs | 145 +- src/Data/Array/Accelerate/Smart.hs | 1737 +++++++++-------- src/Data/Array/Accelerate/Trafo/Algebra.hs | 395 ++-- src/Data/Array/Accelerate/Trafo/Base.hs | 200 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 1281 ++++++------ src/Data/Array/Accelerate/Trafo/Shrink.hs | 307 +-- src/Data/Array/Accelerate/Trafo/Simplify.hs | 269 +-- .../Array/Accelerate/Trafo/Substitution.hs | 375 ++-- src/Data/Array/Accelerate/Type.hs | 119 +- src/Data/Array/Accelerate/Unsafe.hs | 13 +- 39 files changed, 4679 insertions(+), 4470 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 151070dc0..6ce91b391 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -83,15 +83,17 @@ module Data.Array.Accelerate.AST ( -- * Typed de Bruijn indices - Idx(..), idxToInt, tupleIdxToInt, Vars(..), ArrayVar(..), ScalarVars(..), ArrayVars, ScalarVars, + Idx(..), idxToInt, tupleIdxToInt, Var(..), Vars(..), ArrayVar, ArrayVars, ExpVar, ExpVars, + evars, LeftHandSide(..), ALeftHandSide, ELeftHandSide, -- * Valuation environment Val(..), push, prj, -- * Accelerated array expressions PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc, - PreBoundary(..), Boundary, Stencil(..), StencilR(..), - LeftHandSide(..), HasArraysRepr(..), lhsToTupR, + PreBoundary(..), Boundary, StencilR(..), + HasArraysRepr(..), arrayRepr, lhsToTupR, + ArrayR(..), ArraysR, ShapeR(..), SliceIndex(..), -- * Accelerated sequences -- PreOpenSeq(..), Seq, @@ -99,12 +101,12 @@ module Data.Array.Accelerate.AST ( -- * Scalar expressions PreOpenFun(..), OpenFun, PreFun, Fun, PreOpenExp(..), OpenExp, PreExp, Exp, PrimConst(..), - PrimFun(..), + PrimFun(..), expType, primConstType, primFunType, -- NFData NFDataAcc, rnfPreOpenAfun, rnfPreOpenAcc, rnfPreOpenFun, rnfPreOpenExp, - rnfArrays, + rnfArrays, rnfArrayR, -- TemplateHaskell LiftAcc, @@ -114,10 +116,11 @@ module Data.Array.Accelerate.AST ( liftALhs, liftELhs, liftArray, -- Utilities - Exists(..), weakenWithLHS, (:>), + Exists(..), weakenWithLHS, (:>), weakenId, weakenSucc, weakenSucc', (.>), (>:>), + shift, shiftWithLHS, -- debugging - showPreAccOp, showPreExpOp, + showPreAccOp, showPreExpOp, showShortendArr, showElement ) where @@ -125,6 +128,7 @@ module Data.Array.Accelerate.AST ( import Control.DeepSeq import Control.Monad.ST import Data.Typeable +import Data.List ( intercalate ) import Foreign.ForeignPtr import Foreign.Marshal import Foreign.Ptr @@ -236,20 +240,20 @@ type ALeftHandSide = LeftHandSide ArrayR type ELeftHandSide = LeftHandSide ScalarType -data LeftHandSide (s :: * -> *) arrs env env' where +data LeftHandSide (s :: * -> *) v env env' where LeftHandSideSingle - :: s arrs - -> LeftHandSide s arrs env (env, arrs) + :: s v + -> LeftHandSide s v env (env, v) -- Note: a unit is represented as LeftHandSideWildcard TupRunit LeftHandSideWildcard - :: TupR s arrs - -> LeftHandSide s arrs env env + :: TupR s v + -> LeftHandSide s v env env LeftHandSidePair - :: LeftHandSide s arrs1 env env' - -> LeftHandSide s arrs2 env' env'' - -> LeftHandSide s (arrs1, arrs2) env env'' + :: LeftHandSide s v1 env env' + -> LeftHandSide s v2 env' env'' + -> LeftHandSide s (v1, v2) env env'' lhsToTupR :: LeftHandSide s arrs aenv aenv' -> TupR s arrs lhsToTupR (LeftHandSideSingle s) = TupRsingle s @@ -257,13 +261,49 @@ lhsToTupR (LeftHandSideWildcard r) = r lhsToTupR (LeftHandSidePair as bs) = TupRpair (lhsToTupR as) (lhsToTupR bs) -- The type of shifting terms from one context into another +-- This is defined as a newtype, as a type synonym containing a forall quantifier +-- may give issues with impredicative polymorphism which GHC does not support. -- -type env :> env' = forall t'. Idx env t' -> Idx env' t' +newtype env :> env' = Weaken (forall t'. Idx env t' -> Idx env' t') -- Weak or Weaken -weakenWithLHS :: LeftHandSide s arrs env env' -> env :> env' -weakenWithLHS (LeftHandSideWildcard _) = id -weakenWithLHS (LeftHandSideSingle _) = SuccIdx -weakenWithLHS (LeftHandSidePair lhs1 lhs2) = weakenWithLHS lhs2 . weakenWithLHS lhs1 +weakenId :: env :> env +weakenId = Weaken id + +(>:>) :: env :> env' -> Idx env t -> Idx env' t +(>:>) (Weaken k) ix = k ix + +weakenSucc' :: env :> env' -> env :> (env', t) +weakenSucc' (Weaken f) = Weaken (SuccIdx . f) + +weakenSucc :: (env, t) :> env' -> env :> env' +weakenSucc (Weaken f) = Weaken (f . SuccIdx) + +-- TODO: Rename to sink +shift :: forall env env' t. env :> env' -> (env, t) :> (env', t) +shift (Weaken f) = Weaken g + where + g :: Idx (env, t) t' -> Idx (env', t) t' + g ZeroIdx = ZeroIdx + g (SuccIdx ix) = SuccIdx $ f ix + +infixr 9 .> +(.>) :: env2 :> env3 -> env1 :> env2 -> env1 :> env3 +(.>) (Weaken f) (Weaken g) = Weaken (f . g) + +-- TODO: REname to sinkWithLHS +shiftWithLHS :: LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> env1 :> env2 -> env1' :> env2' +shiftWithLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k +shiftWithLHS (LeftHandSideSingle _) (LeftHandSideSingle _) k = shift k +shiftWithLHS (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k = shiftWithLHS b1 b2 $ shiftWithLHS a1 a2 k +shiftWithLHS _ _ _ = error "shiftWithLHS: left hand sides do not match" + +weakenWithLHS :: forall s t env env'. LeftHandSide s t env env' -> env :> env' +weakenWithLHS = go weakenId + where + go :: env2 :> env' -> LeftHandSide s arrs env1 env2 -> env1 :> env' + go k (LeftHandSideWildcard _) = k + go k (LeftHandSideSingle _) = weakenSucc k + go k (LeftHandSidePair l1 l2) = go (go k l2) l1 -- Often useful when working with LeftHandSide, when you need to -- existentially quantify on the resulting environment type. @@ -273,8 +313,8 @@ data Exists f where type ArrayVar = Var ArrayR type ArrayVars = Vars ArrayR -type ScalarVar = Var ScalarType -type ScalarVars = Vars ScalarType +type ExpVar = Var ScalarType +type ExpVars = Vars ScalarType data Var s env t = Var (s t) (Idx env t) data Vars s env t where @@ -282,6 +322,11 @@ data Vars s env t where VarsNil :: Vars s aenv () VarsPair :: Vars s aenv a -> Vars s aenv b -> Vars s aenv (a, b) +evars :: ExpVars env tp -> PreOpenExp acc env aenv tp +evars VarsNil = Nil +evars (VarsSingle var) = Evar var +evars (VarsPair v1 v2) = evars v1 `Pair` evars v2 + -- | Collective array computations parametrised over array variables -- represented with de Bruijn indices. -- @@ -367,8 +412,7 @@ data PreOpenAcc acc aenv a where -- Capture a scalar (or a tuple of scalars) in a singleton array -- - Unit :: TupleType e - => PreExp acc aenv e + Unit :: PreExp acc aenv e -> PreOpenAcc acc aenv (Scalar e) -- Change the shape of an array without altering its contents. @@ -384,7 +428,7 @@ data PreOpenAcc acc aenv a where -- Construct a new array by applying a function to each index. -- Generate :: ArrayR (Array sh e) - => PreExp acc aenv sh -- output shape + -> PreExp acc aenv sh -- output shape -> PreFun acc aenv (sh -> e) -- representation function -> PreOpenAcc acc aenv (Array sh e) @@ -392,7 +436,7 @@ data PreOpenAcc acc aenv a where -- transformations. -- Transform :: ArrayR (Array sh' b) - => PreExp acc aenv sh' -- dimension of the result + -> 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 @@ -401,10 +445,10 @@ data PreOpenAcc acc aenv a where -- Replicate an array across one or more dimensions as given by the first -- argument -- - Replicate :: SliceIndex (EltRepr slix) -- slice type specification - (EltRepr sl) + Replicate :: SliceIndex slix -- slice type specification + sl co - (EltRepr sh) + sh -> PreExp acc aenv slix -- slice value specification -> acc aenv (Array sl e) -- data to be replicated -> PreOpenAcc acc aenv (Array sh e) @@ -412,10 +456,10 @@ data PreOpenAcc acc aenv a where -- Index a sub-array out of an array; i.e., the dimensions not indexed -- are returned whole -- - Slice :: SliceIndex (EltRepr slix) -- slice type specification - (EltRepr sl) + Slice :: SliceIndex slix -- slice type specification + sl co - (EltRepr sh) + sh -> acc aenv (Array sh e) -- array to be indexed -> PreExp acc aenv slix -- slice value specification -> PreOpenAcc acc aenv (Array sl e) @@ -442,13 +486,13 @@ data PreOpenAcc acc aenv a where -- Fold :: PreFun acc aenv (e -> e -> e) -- combination function -> PreExp acc aenv e -- default value - -> acc aenv (Array (sh:.Int) e) -- folded array + -> acc aenv (Array (sh, Int) e) -- folded array -> PreOpenAcc acc aenv (Array sh e) -- As 'Fold' without a default value -- Fold1 :: PreFun acc aenv (e -> e -> e) -- combination function - -> acc aenv (Array (sh:.Int) e) -- folded array + -> 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 @@ -457,17 +501,17 @@ data PreOpenAcc acc aenv a where FoldSeg :: IntegralType 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 (Array (sh, Int) e) -- folded array -> acc aenv (Segments i) -- segment descriptor - -> PreOpenAcc acc aenv (Array (sh:.Int) e) + -> PreOpenAcc acc aenv (Array (sh, Int) e) -- As 'FoldSeg' without a default value -- Fold1Seg :: IntegralType i -> PreFun acc aenv (e -> e -> e) -- combination function - -> acc aenv (Array (sh:.Int) e) -- folded array + -> acc aenv (Array (sh, Int) e) -- folded array -> acc aenv (Segments i) -- segment descriptor - -> PreOpenAcc acc aenv (Array (sh:.Int) e) + -> 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 @@ -475,8 +519,8 @@ data PreOpenAcc acc aenv a where -- Scanl :: 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) + -> 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 @@ -484,34 +528,34 @@ data PreOpenAcc acc aenv a where -- Scanl' :: 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) + -> acc aenv (Array (sh, Int) e) + -> PreOpenAcc acc aenv (((), Array (sh, Int) e), Array sh e) -- Haskell-style scan without an initial value -- Scanl1 :: PreFun acc aenv (e -> e -> e) -- combination function - -> acc aenv (Array (sh:.Int) e) - -> PreOpenAcc acc aenv (Array (sh:.Int) e) + -> acc aenv (Array (sh, Int) e) + -> PreOpenAcc acc aenv (Array (sh, Int) e) -- Right-to-left version of 'Scanl' -- Scanr :: 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) + -> acc aenv (Array (sh, Int) e) + -> PreOpenAcc acc aenv (Array (sh, Int) e) -- Right-to-left version of 'Scanl\'' -- Scanr' :: 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) + -> acc aenv (Array (sh, Int) e) + -> PreOpenAcc acc aenv (((), Array (sh, Int) e), Array sh e) -- Right-to-left version of 'Scanl1' -- Scanr1 :: PreFun acc aenv (e -> e -> e) -- combination function - -> acc aenv (Array (sh:.Int) e) - -> PreOpenAcc acc aenv (Array (sh:.Int) e) + -> acc aenv (Array (sh, Int) e) + -> PreOpenAcc acc aenv (Array (sh, Int) e) -- Generalised forward permutation is characterised by a permutation function -- that determines for each element of the source array where it should go in @@ -533,8 +577,7 @@ data PreOpenAcc acc aenv a where -- function is used to combine elements, which needs to be /associative/ -- and /commutative/. -- - Permute :: ShapeR sh' - => PreFun acc aenv (e -> e -> e) -- combination function + Permute :: 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 @@ -544,7 +587,7 @@ data PreOpenAcc acc aenv a where -- be between arrays of varying shape; the permutation function must be total -- Backpermute :: ShapeR sh' - => PreExp acc aenv sh' -- dimensions of the result + -> 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) @@ -564,7 +607,7 @@ data PreOpenAcc acc aenv a where Stencil2 :: StencilR sh a stencil1 -> StencilR sh b stencil2 -> TupleType c - => PreFun acc aenv (stencil1 -> stencil2 -> c) -- stencil function + -> 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 @@ -711,22 +754,24 @@ data PreBoundary acc aenv t where Wrap :: PreBoundary acc aenv t -- Use a constant value for outlying coordinates - Constant :: Elt e - => EltRepr e + Constant :: e -> PreBoundary acc aenv (Array sh e) -- Apply the given function to outlying coordinates - Function :: (Shape sh, Elt e) - => PreFun acc aenv (sh -> e) + Function :: PreFun acc aenv (sh -> e) -> PreBoundary acc aenv (Array sh e) class HasArraysRepr f where arraysRepr :: f aenv a -> ArraysR a +arrayRepr :: HasArraysRepr f => f aenv (Array sh e) -> ArrayR (Array sh e) +arrayRepr a = case arraysRepr a of + TupRsingle repr -> repr + instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr (Alet _ _ body) = arraysRepr body - arraysRepr (Avar ArrayVar{}) = arraysRarray + arraysRepr (Avar (Var repr _)) = TupRsingle repr arraysRepr (Apair as bs) = TupRpair (arraysRepr as) (arraysRepr bs) arraysRepr Anil = TupRunit arraysRepr (Apply (Alam _ (Abody a)) _) = arraysRepr a @@ -737,29 +782,41 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr (Acond _ whenTrue _) = arraysRepr whenTrue arraysRepr (Awhile _ (Alam lhs _) _) = lhsToTupR lhs arraysRepr (Awhile _ _ _) = error "I want my, I want my MTV!" - arraysRepr Use{} = arraysRarray - arraysRepr Unit{} = arraysRarray - arraysRepr Reshape{} = arraysRarray - arraysRepr Generate{} = arraysRarray - arraysRepr Transform{} = arraysRarray - arraysRepr Replicate{} = arraysRarray - arraysRepr Slice{} = arraysRarray - arraysRepr Map{} = arraysRarray - arraysRepr ZipWith{} = arraysRarray - arraysRepr Fold{} = arraysRarray - arraysRepr Fold1{} = arraysRarray - arraysRepr FoldSeg{} = arraysRarray - arraysRepr Fold1Seg{} = arraysRarray - arraysRepr Scanl{} = arraysRarray - arraysRepr Scanl'{} = arraysRtuple2 - arraysRepr Scanl1{} = arraysRarray - arraysRepr Scanr{} = arraysRarray - arraysRepr Scanr'{} = arraysRtuple2 - arraysRepr Scanr1{} = arraysRarray - arraysRepr Permute{} = arraysRarray - arraysRepr Backpermute{} = arraysRarray - arraysRepr Stencil{} = arraysRarray - arraysRepr Stencil2{} = arraysRarray + arraysRepr (Use repr _) = TupRsingle repr + arraysRepr (Unit e) = arraysRarray ShapeRz $ expType e + arraysRepr (Reshape sh _ a) = let TupRsingle (ArrayR _ tp) = arraysRepr a + in arraysRarray sh tp + arraysRepr (Generate repr _ _) = TupRsingle repr + arraysRepr (Transform repr _ _ _ _) = TupRsingle repr + arraysRepr (Replicate slice _ a) = let TupRsingle (ArrayR _ tp) = arraysRepr a + in arraysRarray (sliceDomainR slice) tp + arraysRepr (Slice slice a _) = let TupRsingle (ArrayR _ tp) = arraysRepr a + in arraysRarray (sliceShapeR slice) tp + arraysRepr (Map tp _ a) = let TupRsingle (ArrayR sh _) = arraysRepr a + in arraysRarray sh tp + arraysRepr (ZipWith tp _ a _) = let TupRsingle (ArrayR sh _) = arraysRepr a + in arraysRarray sh tp + arraysRepr (Fold _ _ a) = let TupRsingle (ArrayR (ShapeRcons sh) tp) = arraysRepr a + in arraysRarray sh tp + arraysRepr (Fold1 _ a) = let TupRsingle (ArrayR (ShapeRcons sh) tp) = arraysRepr a + in arraysRarray sh tp + arraysRepr (FoldSeg _ _ _ a _) = arraysRepr a + arraysRepr (Fold1Seg _ _ a _) = arraysRepr a + arraysRepr (Scanl _ _ a) = arraysRepr a + arraysRepr (Scanl' _ _ a) = let TupRsingle repr@(ArrayR (ShapeRcons sh) tp) = arraysRepr a + in arraysRtuple2 repr $ ArrayR sh tp + arraysRepr (Scanl1 _ a) = arraysRepr a + arraysRepr (Scanr _ _ a) = arraysRepr a + arraysRepr (Scanr' _ _ a) = let TupRsingle repr@(ArrayR (ShapeRcons sh) tp) = arraysRepr a + in arraysRtuple2 repr $ ArrayR sh tp + arraysRepr (Scanr1 _ a) = arraysRepr a + arraysRepr (Permute _ a _ _) = arraysRepr a + arraysRepr (Backpermute sh _ _ a) = let TupRsingle (ArrayR _ tp) = arraysRepr a + in arraysRarray sh tp + arraysRepr (Stencil _ tp _ _ a) = let TupRsingle (ArrayR sh _) = arraysRepr a + in arraysRarray sh tp + arraysRepr (Stencil2 _ _ tp _ _ a _ _) = let TupRsingle (ArrayR sh _) = arraysRepr a + in arraysRarray sh tp instance HasArraysRepr OpenAcc where arraysRepr (OpenAcc a) = arraysRepr a @@ -811,7 +868,7 @@ data PreOpenExp acc env aenv t where -> PreOpenExp acc env aenv body_t -- Variable index, ranging only over tuples or scalars - EVar :: ScalarVar env t + Evar :: ExpVar env t -> PreOpenExp acc env aenv t -- Apply a backend-specific foreign function @@ -828,31 +885,39 @@ data PreOpenExp acc env aenv t where Nil :: PreOpenExp acc env aenv () + -- SIMD vectors + {- VecPrj :: VecIdx n + -> PreOpenExp (Vec n e) + -> PreOpenExp acc exp e + + Evec :: VecE n (exp e) + -> PreOpenExp acc exp (Vec n e) -} + -- Array indices & shapes -- TODO: IndexIgnore? - IndexAny :: Shape sh - => PreOpenExp acc env aenv (Any sh) + -- IndexAny :: PreOpenExp acc aenv env () + + -- Evec :: PreOpenExp ?? + -- -> PreOpenExp (Vec n e) - IndexSlice :: (Shape sh, Shape sl) - => SliceIndex slix sl co sh + IndexSlice :: SliceIndex slix sl co sh -> PreOpenExp acc env aenv slix -> PreOpenExp acc env aenv sh -> PreOpenExp acc env aenv sl - IndexFull :: (Shape sh, Shape sl) - => SliceIndex slix sl co sh + IndexFull :: SliceIndex slix sl co 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 + ToIndex :: ShapeR 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 + FromIndex :: ShapeR sh + -> PreOpenExp acc env aenv sh -- shape of the array -> PreOpenExp acc env aenv Int -- index into linear representation -> PreOpenExp acc env aenv sh @@ -897,22 +962,10 @@ data PreOpenExp acc env aenv t where -> PreOpenExp acc env aenv dim -- Number of elements of an array given its shape - ShapeSize :: 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 + ShapeSize :: ShapeR dim -> PreOpenExp acc env aenv dim + -> PreOpenExp acc env aenv Int - -- 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 :: ScalarType t @@ -925,6 +978,44 @@ data PreOpenExp acc env aenv t where -> PreOpenExp acc env aenv a -> PreOpenExp acc env aenv b +expType :: HasArraysRepr acc => PreOpenExp acc aenv env t -> TupleType t +expType expr = case expr of + Let _ _ body -> expType body + Evar (Var tp _) -> TupRsingle tp + Foreign _ (Lam _ (Body e)) _ -> expType e + Foreign _ _ _ -> error "Though you ride on the wheels of tomorrow, you still wander the fields of your sorrow." + Pair e1 e2 -> TupRpair (expType e1) (expType e2) + Nil -> TupRunit + IndexSlice si _ _ -> shapeType $ sliceShapeR si + IndexFull si _ _ -> shapeType $ sliceDomainR si + ToIndex _ _ _ -> TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType $ TypeInt + FromIndex shr _ _ -> shapeType shr + Cond _ e _ -> expType e + While _ (Lam lhs _) _ -> lhsToTupR lhs + While _ _ _ -> error "What's the matter, you're running in the shadows" + Const tp _ -> TupRsingle tp + PrimConst c -> primConstType c + PrimApp f _ -> snd $ primFunType f + Index a _ -> arrayRtype $ arrayRepr a + LinearIndex a _ -> arrayRtype $ arrayRepr a + Shape a -> shapeType $ arrayRshape $ arrayRepr a + ShapeSize _ _ -> TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType $ TypeInt + Undef tp -> TupRsingle tp + Coerce _ tp _ -> TupRsingle tp + +{- data VecE (n :: Nat) a where + VecNil :: VecE 0 a + VecCons :: a -> VecE n a -> VecE (1 + n) a + +-- Or have a VecE constructor which converts a tuple expression to a vector, and the other way around? + +instance Functor (VecE n) where + fmap _ VecNil = VecNil + fmap f (VecCons a as) = VecCons (f a) (fmap f as) + +data VecIdx n where + VecIdxZero :: VecIdx n + VecIdxSucc :: VecIdx n -> VecIdx (1 + n) -} -- |Primitive constant values -- @@ -1033,88 +1124,89 @@ data PrimFun sig where primConstType :: PrimConst a -> TupleType a primConstType prim = case prim of - PrimMinBound t -> boundedType t - PrimMaxBound t -> boundedType t - PrimPi t -> floatingType t + PrimMinBound t -> boundedTp t + PrimMaxBound t -> boundedTp t + PrimPi t -> floatingTp t where - boundedType :: BoundedType a -> TupleType a - boundedType (IntegralBoundedType t) = SingleType $ NumSingleType $ IntegralNumType t - boundedType (NonNumBoundedType t) = SingleType $ NonNumSingleType t + boundedTp :: BoundedType a -> TupleType a + boundedTp (IntegralBoundedType t) = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType t + boundedTp (NonNumBoundedType t) = TupRsingle $ SingleScalarType $ NonNumSingleType t - floatingType :: FloatingType t -> TupleType t - floatingType = numType . FloatingNumType + floatingTp :: FloatingType t -> TupleType t + floatingTp = TupRsingle . SingleScalarType . NumSingleType . FloatingNumType primFunType :: PrimFun (a -> b) -> (TupleType a, TupleType b) primFunType prim = case prim of -- Num - PrimAdd t -> binary' $ numType t - PrimSub t -> binary' $ numType t - PrimMul t -> binary' $ numType t - PrimNeg t -> unary' $ numType t - PrimAbs t -> unary' $ numType t - PrimSig t -> unary' $ numType t + PrimAdd t -> binary' $ numTp t + PrimSub t -> binary' $ numTp t + PrimMul t -> binary' $ numTp t + PrimNeg t -> unary' $ numTp t + PrimAbs t -> unary' $ numTp t + PrimSig t -> unary' $ numTp t -- Integral - PrimQuot t -> binary' $ integralType t - PrimRem t -> binary' $ integralType t - PrimQuotRem t -> divMod t - PrimIDiv t -> binary' $ integralType t - PrimMod t -> binary' $ integralType t - PrimDivMod t -> divMod t + PrimQuot t -> binary' $ integralTp t + PrimRem t -> binary' $ integralTp t + PrimQuotRem t -> divModT t + PrimIDiv t -> binary' $ integralTp t + PrimMod t -> binary' $ integralTp t + PrimDivMod t -> divModT t -- Bits & FiniteBits - PrimBAnd t -> binary' $ integralType t - PrimBOr t -> binary' $ integralType t - PrimBXor t -> binary' $ integralType t - PrimBNot t -> unary' $ integralType t - PrimBShiftL t -> (integralType t `TupRpair` typeInt, integralType t) - PrimBShiftR t -> (integralType t `TupRpair` typeInt, integralType t) - PrimBRotateL t -> (integralType t `TupRpair` typeInt, integralType t) - PrimBRotateR t -> (integralType t `TupRpair` typeInt, integralType t) - PrimPopCount t -> unary (integralType t) typeInt - PrimCountLeadingZeros t -> unary (integralType t) typeInt - PrimCountTrailingZeros t -> unary (integralType t) typeInt + PrimBAnd t -> binary' $ integralTp t + PrimBOr t -> binary' $ integralTp t + PrimBXor t -> binary' $ integralTp t + PrimBNot t -> unary' $ integralTp t + PrimBShiftL t -> (integralTp t `TupRpair` typeInt, integralTp t) + PrimBShiftR t -> (integralTp t `TupRpair` typeInt, integralTp t) + PrimBRotateL t -> (integralTp t `TupRpair` typeInt, integralTp t) + PrimBRotateR t -> (integralTp t `TupRpair` typeInt, integralTp t) + PrimPopCount t -> unary (integralTp t) typeInt + PrimCountLeadingZeros t -> unary (integralTp t) typeInt + PrimCountTrailingZeros t -> unary (integralTp t) typeInt -- Fractional, Floating - PrimFDiv t -> binary' $ floatingType t - PrimRecip t -> unary' $ floatingType t - PrimSin t -> unary' $ floatingType t - PrimCos t -> unary' $ floatingType t - PrimTan t -> unary' $ floatingType t - PrimAsin t -> unary' $ floatingType t - PrimAcos t -> unary' $ floatingType t - PrimAtan t -> unary' $ floatingType t - PrimSinh t -> unary' $ floatingType t - PrimCosh t -> unary' $ floatingType t - PrimTanh t -> unary' $ floatingType t - PrimAsinh t -> unary' $ floatingType t - PrimAcosh t -> unary' $ floatingType t - PrimAtanh t -> unary' $ floatingType t - PrimExpFloating t -> unary' $ floatingType t - PrimSqrt t -> unary' $ floatingType t - PrimLog t -> unary' $ floatingType t - PrimFPow t -> binary' $ floatingType t - PrimLogBase t -> binary' $ floatingType t + PrimFDiv t -> binary' $ floatingTp t + PrimRecip t -> unary' $ floatingTp t + PrimSin t -> unary' $ floatingTp t + PrimCos t -> unary' $ floatingTp t + PrimTan t -> unary' $ floatingTp t + PrimAsin t -> unary' $ floatingTp t + PrimAcos t -> unary' $ floatingTp t + PrimAtan t -> unary' $ floatingTp t + PrimSinh t -> unary' $ floatingTp t + PrimCosh t -> unary' $ floatingTp t + PrimTanh t -> unary' $ floatingTp t + PrimAsinh t -> unary' $ floatingTp t + PrimAcosh t -> unary' $ floatingTp t + PrimAtanh t -> unary' $ floatingTp t + PrimExpFloating t -> unary' $ floatingTp t + PrimSqrt t -> unary' $ floatingTp t + PrimLog t -> unary' $ floatingTp t + PrimFPow t -> binary' $ floatingTp t + PrimLogBase t -> binary' $ floatingTp t -- RealFrac - PrimTruncate a b -> unary (floatingType a) (integralType b) - PrimRound a b -> unary (floatingType a) (integralType b) - PrimFloor a b -> unary (floatingType a) (integralType b) - PrimCeiling a b -> unary (floatingType a) (integralType b) + PrimTruncate a b -> unary (floatingTp a) (integralTp b) + PrimRound a b -> unary (floatingTp a) (integralTp b) + PrimFloor a b -> unary (floatingTp a) (integralTp b) + PrimCeiling a b -> unary (floatingTp a) (integralTp b) -- RealFloat - PrimAtan2 t -> binary' $ floatingType t - PrimIsNaN t -> unary (floatingType t) typeBool - PrimIsInfinite t -> unary (floatingType t) typeBool + PrimAtan2 t -> binary' $ floatingTp t + PrimIsNaN t -> unary (floatingTp t) typeBool + PrimIsInfinite t -> unary (floatingTp t) typeBool -- Relational and equality - PrimLt t -> compare t - PrimGt t -> compare t - PrimLtEq t -> compare t - PrimGtEq t -> compare t - PrimEq t -> compare t - PrimMax t -> binary $ singleType t - PrimMin t -> binary $ singleType t + PrimLt t -> compare' t + PrimGt t -> compare' t + PrimLtEq t -> compare' t + PrimGtEq t -> compare' t + PrimEq t -> compare' t + PrimNEq t -> compare' t + PrimMax t -> binary' $ singleTp t + PrimMin t -> binary' $ singleTp t -- Logical PrimLAnd -> binary' typeBool @@ -1129,8 +1221,8 @@ primFunType prim = case prim of PrimBoolToInt -> unary typeBool typeInt -- general conversion between types - PrimFromIntegral a b -> unary (integralType a) (numType b) - PrimToFloating a b -> unary (numType a) (floatingType b) + PrimFromIntegral a b -> unary (integralTp a) (numTp b) + PrimToFloating a b -> unary (numTp a) (floatingTp b) where unary :: TupleType a -> TupleType b -> (TupleType a, TupleType b) @@ -1145,32 +1237,32 @@ primFunType prim = case prim of binary' :: TupleType a -> (TupleType (a, a), TupleType a) binary' a = binary a a - compare :: SingleType a -> (TupleType (a, a), TupleType Bool) - compare a = binary (singleType a) typeBool + compare' :: SingleType a -> (TupleType (a, a), TupleType Bool) + compare' a = binary (singleTp a) typeBool - singleType :: SingleType t -> TupleType t - singleType = SingleScalarType + singleTp :: SingleType t -> TupleType t + singleTp = TupRsingle . SingleScalarType - numType :: NumType t -> TupleType t - numType = SingleScalarType . NumSingleType + numTp :: NumType t -> TupleType t + numTp = TupRsingle . SingleScalarType . NumSingleType - integralType :: IntegralType t -> TupleType t - integralType = numType . IntegralNumType + integralTp :: IntegralType t -> TupleType t + integralTp = numTp . IntegralNumType - floatingType :: FloatingType t -> TupleType t - floatingType = numType . FloatingNumType + floatingTp :: FloatingType t -> TupleType t + floatingTp = numTp . FloatingNumType - divMod :: IntegralType t -> (TupleType (t, t), TupleType (t, t)) - divMod t = unary' $ integralType t `TupRpair` integralType t + divModT :: IntegralType t -> (TupleType (t, t), TupleType (t, t)) + divModT t = unary' $ integralTp t `TupRpair` integralTp t typeBool :: TupleType Bool - typeBool = SingleScalarType $ NonNumSingleType $ TypeBool + typeBool = TupRsingle $ SingleScalarType $ NonNumSingleType $ TypeBool typeChar :: TupleType Char - typeChar = SingleScalarType $ NonNumSingleType $ TypeChar + typeChar = TupRsingle $ SingleScalarType $ NonNumSingleType $ TypeChar typeInt :: TupleType Int - typeInt = SingleScalarType $ NumSingleType $ IntegralNumType TypeInt + typeInt = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType TypeInt -- NFData instances -- ================ @@ -1200,10 +1292,6 @@ 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 @@ -1214,7 +1302,7 @@ rnfPreOpenAfun :: NFDataAcc acc -> PreOpenAfun acc aenv t -> () rnfPreOpenAfun rnfA (Abody b) = rnfA b rnfPreOpenAfun rnfA (Alam lhs f) = rnfALhs lhs `seq` rnfPreOpenAfun rnfA f -rnfPreOpenAcc :: forall acc aenv t. NFDataAcc acc -> PreOpenAcc acc aenv t -> () +rnfPreOpenAcc :: forall acc aenv t. HasArraysRepr acc => NFDataAcc acc -> PreOpenAcc acc aenv t -> () rnfPreOpenAcc rnfA pacc = let rnfAF :: PreOpenAfun acc aenv' t' -> () @@ -1229,31 +1317,31 @@ rnfPreOpenAcc rnfA pacc = -- rnfS :: PreOpenSeq acc aenv' senv' t' -> () -- rnfS = rnfPreOpenSeq rnfA - rnfB :: PreBoundary acc aenv' (Array sh e) -> () + rnfB :: ArrayR (Array sh e) -> PreBoundary acc aenv' (Array sh e) -> () rnfB = rnfBoundary rnfA in case pacc of Alet lhs bnd body -> rnfALhs lhs `seq` rnfA bnd `seq` rnfA body - Avar (ArrayVar ix) -> rnfIdx ix + Avar (Var repr ix) -> rnfArrayR repr `seq` rnfIdx ix Apair as bs -> rnfA as `seq` rnfA bs Anil -> () Apply afun acc -> rnfAF afun `seq` rnfA acc - Aforeign asm afun a -> rnf (strForeign asm) `seq` rnfAF afun `seq` rnfA a + Aforeign asm afun a -> rnf (Sugar.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 arr -> rnf arr + Use repr arr -> rnfArray repr arr 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 + Reshape shr sh a -> rnfShapeR shr `seq` rnfE sh `seq` rnfA a + Generate repr sh f -> rnfArrayR repr `seq` rnfE sh `seq` rnfF f + Transform repr sh p f a -> rnfArrayR repr `seq` 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 + Map tp f a -> rnfTupleType tp `seq` rnfF f `seq` rnfA a + ZipWith tp f a1 a2 -> rnfTupleType tp `seq` 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 + FoldSeg i f z a s -> rnfIntegralType i `seq` rnfF f `seq` rnfE z `seq` rnfA a `seq` rnfA s + Fold1Seg i f a s -> rnfIntegralType i `seq` 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 @@ -1261,9 +1349,18 @@ rnfPreOpenAcc rnfA pacc = 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 + Backpermute shr sh f a -> rnfShapeR shr `seq` rnfE sh `seq` rnfF f `seq` rnfA a + Stencil sr tp f b a -> + let + TupRsingle (ArrayR shr _) = arraysRepr a + repr = ArrayR shr $ stencilElt sr + in rnfStencilR sr `seq` rnfTupR rnfScalarType tp `seq` rnfF f `seq` rnfB repr b `seq` rnfA a + Stencil2 sr1 sr2 tp f b1 a1 b2 a2 -> + let + TupRsingle (ArrayR shr _) = arraysRepr a1 + repr1 = ArrayR shr $ stencilElt sr1 + repr2 = ArrayR shr $ stencilElt sr2 + in rnfStencilR sr1 `seq` rnfStencilR sr2 `seq` rnfTupR rnfScalarType tp `seq` rnfF f `seq` rnfB repr1 b1 `seq` rnfB repr2 b2 `seq` rnfA a1 `seq` rnfA a2 -- Collect s -> rnfS s rnfLhs :: (forall b. s b -> ()) -> LeftHandSide s arrs env env' -> () @@ -1283,19 +1380,40 @@ rnfTupR rnfS (TupRsingle s) = rnfS s rnfTupR rnfS (TupRpair t1 t2) = rnfTupR rnfS t1 `seq` rnfTupR rnfS t2 rnfArrayR :: ArrayR arr -> () -rnfArrayR ArrayR = () +rnfArrayR (ArrayR shr tp) = rnfShapeR shr `seq` rnfTupR rnfScalarType tp rnfArrays :: ArraysR arrs -> arrs -> () -rnfArrays TupRunit () = () -rnfArrays (TupRsingle ArrayR) arr = rnf arr -rnfArrays (TupRpair ar1 ar2) (a1,a2) = rnfArrays ar1 a1 `seq` rnfArrays ar2 a2 +rnfArrays TupRunit () = () +rnfArrays (TupRsingle repr) arr = rnfArray repr arr +rnfArrays (TupRpair ar1 ar2) (a1,a2) = rnfArrays ar1 a1 `seq` rnfArrays ar2 a2 + +rnfShapeR :: ShapeR sh -> () +rnfShapeR ShapeRz = () +rnfShapeR (ShapeRcons shr) = rnfShapeR shr + +rnfStencilR :: StencilR sh e pat -> () +rnfStencilR (StencilRunit3 tp) = rnfTupleType tp +rnfStencilR (StencilRunit5 tp) = rnfTupleType tp +rnfStencilR (StencilRunit7 tp) = rnfTupleType tp +rnfStencilR (StencilRunit9 tp) = rnfTupleType tp +rnfStencilR (StencilRtup3 s1 s2 s3) + = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 +rnfStencilR (StencilRtup5 s1 s2 s3 s4 s5) + = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 +rnfStencilR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) + = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 + `seq` rnfStencilR s6 `seq` rnfStencilR s7 +rnfStencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) + = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 + `seq` rnfStencilR s6 `seq` rnfStencilR s7 `seq` rnfStencilR s8 `seq` rnfStencilR s9 + +rnfBoundary :: forall acc aenv sh e. NFDataAcc acc -> ArrayR (Array sh e) -> PreBoundary acc aenv (Array sh e) -> () +rnfBoundary _ _ Clamp = () +rnfBoundary _ _ Mirror = () +rnfBoundary _ _ Wrap = () +rnfBoundary _ (ArrayR _ tp) (Constant c) = rnfConst tp c +rnfBoundary rnfA _ (Function f) = rnfPreOpenFun rnfA f -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 @e) c -rnfBoundary rnfA (Function f) = rnfPreOpenFun rnfA f {-- @@ -1369,8 +1487,8 @@ rnfStuple rnfA (SnocAtup tup c) = rnfStuple rnfA tup `seq` rnfSeqConsumer rnfA c -- ------------------ rnfPreOpenFun :: NFDataAcc acc -> PreOpenFun acc env aenv t -> () -rnfPreOpenFun rnfA (Body b) = rnfPreOpenExp rnfA b -rnfPreOpenFun rnfA (Lam f) = rnfPreOpenFun rnfA f +rnfPreOpenFun rnfA (Body b) = rnfPreOpenExp rnfA b +rnfPreOpenFun rnfA (Lam lhs f) = rnfELhs lhs `seq` rnfPreOpenFun rnfA f rnfPreOpenExp :: forall acc env aenv t. NFDataAcc acc -> PreOpenExp acc env aenv t -> () rnfPreOpenExp rnfA topExp = @@ -1382,18 +1500,17 @@ rnfPreOpenExp rnfA topExp = 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 @t) t - Undef -> () + Let lhs bnd body -> rnfELhs lhs `seq` rnfE bnd `seq` rnfE body + Evar (Var tp ix) -> rnfScalarType tp `seq` rnfIdx ix + Foreign asm f x -> rnf (Sugar.strForeign asm) `seq` rnfF f `seq` rnfE x + Const tp c -> c `seq` rnfScalarType tp -- scalars should have (nf == whnf) + Undef tp -> rnfScalarType tp Pair a b -> rnfE a `seq` rnfE b Nil -> () - 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 + ToIndex shr sh ix -> rnfShapeR shr `seq` rnfE sh `seq` rnfE ix + FromIndex shr sh ix -> rnfShapeR shr `seq` 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 @@ -1401,8 +1518,8 @@ rnfPreOpenExp rnfA topExp = Index a ix -> rnfA a `seq` rnfE ix LinearIndex a ix -> rnfA a `seq` rnfE ix Shape a -> rnfA a - ShapeSize sh -> rnfE sh - Coerce e -> rnfE e + ShapeSize shr sh -> rnfShapeR shr `seq` rnfE sh + Coerce t1 t2 e -> rnfScalarType t1 `seq` rnfScalarType t2 `seq` rnfE e rnfConst :: TupleType t -> t -> () rnfConst TupRunit () = () @@ -1486,6 +1603,9 @@ rnfSliceIndex SliceNil = () rnfSliceIndex (SliceAll sh) = rnfSliceIndex sh rnfSliceIndex (SliceFixed sh) = rnfSliceIndex sh +rnfTupleType :: TupleType t -> () +rnfTupleType = rnfTupR rnfScalarType + rnfScalarType :: ScalarType t -> () rnfScalarType (SingleScalarType t) = rnfSingleType t rnfScalarType (VectorScalarType t) = rnfVectorType t @@ -1506,25 +1626,25 @@ rnfNumType (IntegralNumType t) = rnfIntegralType t rnfNumType (FloatingNumType t) = rnfFloatingType t rnfNonNumType :: NonNumType t -> () -rnfNonNumType (TypeBool NonNumDict) = () -rnfNonNumType (TypeChar NonNumDict) = () +rnfNonNumType TypeBool = () +rnfNonNumType TypeChar = () 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 TypeInt = () +rnfIntegralType TypeInt8 = () +rnfIntegralType TypeInt16 = () +rnfIntegralType TypeInt32 = () +rnfIntegralType TypeInt64 = () +rnfIntegralType TypeWord = () +rnfIntegralType TypeWord8 = () +rnfIntegralType TypeWord16 = () +rnfIntegralType TypeWord32 = () +rnfIntegralType TypeWord64 = () rnfFloatingType :: FloatingType t -> () -rnfFloatingType (TypeHalf FloatingDict) = () -rnfFloatingType (TypeFloat FloatingDict) = () -rnfFloatingType (TypeDouble FloatingDict) = () +rnfFloatingType TypeHalf = () +rnfFloatingType TypeFloat = () +rnfFloatingType TypeDouble = () -- Template Haskell @@ -1547,7 +1667,8 @@ liftPreOpenAfun liftA (Abody b) = [|| Abody $$(liftA b) ||] liftPreOpenAcc :: forall acc aenv a. - LiftAcc acc + HasArraysRepr acc + => LiftAcc acc -> PreOpenAcc acc aenv a -> Q (TExp (PreOpenAcc acc aenv a)) liftPreOpenAcc liftA pacc = @@ -1561,32 +1682,32 @@ liftPreOpenAcc liftA pacc = 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 :: ArrayR (Array sh e) -> PreBoundary acc aenv (Array sh e) -> Q (TExp (PreBoundary acc aenv (Array sh e))) liftB = liftBoundary liftA in case pacc of Alet lhs bnd body -> [|| Alet $$(liftALhs lhs) $$(liftA bnd) $$(liftA body) ||] - Avar (ArrayVar ix) -> [|| Avar (ArrayVar $$(liftIdx ix)) ||] + Avar (Var tp ix) -> [|| Avar (Var $$(liftArrayR tp) $$(liftIdx ix)) ||] Apair as bs -> [|| Apair $$(liftA as) $$(liftA bs) ||] Anil -> [|| Anil ||] Apply f a -> [|| Apply $$(liftAF f) $$(liftA a) ||] - Aforeign asm f a -> [|| Aforeign $$(liftForeign asm) $$(liftPreOpenAfun liftA f) $$(liftA a) ||] + Aforeign asm f a -> [|| Aforeign $$(Sugar.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 $$(liftArray a) ||] + Use repr a -> [|| Use $$(liftArrayR repr) $$(liftArray repr 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) ||] + Reshape shr sh a -> [|| Reshape $$(liftShapeR shr) $$(liftE sh) $$(liftA a) ||] + Generate repr sh f -> [|| Generate $$(liftArrayR repr) $$(liftE sh) $$(liftF f) ||] + Transform repr sh p f a -> [|| Transform $$(liftArrayR repr) $$(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) ||] + Map tp f a -> [|| Map $$(liftTupleType tp) $$(liftF f) $$(liftA a) ||] + ZipWith tp f a b -> [|| ZipWith $$(liftTupleType tp) $$(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) ||] + FoldSeg i f z a s -> [|| FoldSeg $$(liftIntegralType i) $$(liftF f) $$(liftE z) $$(liftA a) $$(liftA s) ||] + Fold1Seg i f a s -> [|| Fold1Seg $$(liftIntegralType i) $$(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) ||] @@ -1594,31 +1715,63 @@ liftPreOpenAcc liftA pacc = 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) ||] + Backpermute shr sh p a -> [|| Backpermute $$(liftShapeR shr) $$(liftE sh) $$(liftF p) $$(liftA a) ||] + Stencil sr tp f b a -> + let + TupRsingle (ArrayR shr _) = arraysRepr a + repr = ArrayR shr $ stencilElt sr + in [|| Stencil $$(liftStencilR sr) $$(liftTupleType tp) $$(liftF f) $$(liftB repr b) $$(liftA a) ||] + Stencil2 sr1 sr2 tp f b1 a1 b2 a2 -> + let + TupRsingle (ArrayR shr _) = arraysRepr a1 + repr1 = ArrayR shr $ stencilElt sr1 + repr2 = ArrayR shr $ stencilElt sr2 + in [|| Stencil2 $$(liftStencilR sr1) $$(liftStencilR sr2) $$(liftTupleType tp) $$(liftF f) $$(liftB repr1 b1) $$(liftA a1) $$(liftB repr2 b2) $$(liftA a2) ||] liftALhs :: ALeftHandSide arrs aenv aenv' -> Q (TExp (ALeftHandSide arrs aenv aenv')) -liftALhs (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftArraysR r) ||] -liftALhs (LeftHandSideSingle ArrayR) = [|| LeftHandSideSingle ArrayR ||] -liftALhs (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftALhs a) $$(liftALhs b) ||] +liftALhs (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftArraysR r) ||] +liftALhs (LeftHandSideSingle repr) = [|| LeftHandSideSingle $$(liftArrayR repr) ||] +liftALhs (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftALhs a) $$(liftALhs b) ||] -liftELhs :: ELeftHandSide t aenv aenv' -> Q (TExp (ELeftHandSide t aenv aenv')) +liftELhs :: ELeftHandSide t env env' -> Q (TExp (ELeftHandSide t env env')) liftELhs (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftTupleType r) ||] liftELhs (LeftHandSideSingle t) = [|| LeftHandSideSingle $$(liftScalarType t) ||] liftELhs (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftELhs a) $$(liftELhs b) ||] +liftShapeR :: ShapeR sh -> Q (TExp (ShapeR sh)) +liftShapeR ShapeRz = [|| ShapeRz ||] +liftShapeR (ShapeRcons sh) = [|| ShapeRcons $$(liftShapeR sh) ||] + +liftArrayR :: ArrayR a -> Q (TExp (ArrayR a)) +liftArrayR (ArrayR shr tp) = [|| ArrayR $$(liftShapeR shr) $$(liftTupleType tp) ||] + liftArraysR :: ArraysR arrs -> Q (TExp (ArraysR arrs)) -liftArraysR TupRunit = [|| TupRunit ||] -liftArraysR (TupRsingle ArrayR) = [|| TupRsingle ArrayR ||] -liftArraysR (TupRpair a b) = [|| TupRpair $$(liftArraysR a) $$(liftArraysR b) ||] +liftArraysR TupRunit = [|| TupRunit ||] +liftArraysR (TupRsingle repr) = [|| TupRsingle $$(liftArrayR repr) ||] +liftArraysR (TupRpair a b) = [|| TupRpair $$(liftArraysR a) $$(liftArraysR b) ||] + +liftStencilR :: StencilR sh e pat -> Q (TExp (StencilR sh e pat)) +liftStencilR (StencilRunit3 tp) = [|| StencilRunit3 $$(liftTupleType tp) ||] +liftStencilR (StencilRunit5 tp) = [|| StencilRunit5 $$(liftTupleType tp) ||] +liftStencilR (StencilRunit7 tp) = [|| StencilRunit7 $$(liftTupleType tp) ||] +liftStencilR (StencilRunit9 tp) = [|| StencilRunit9 $$(liftTupleType tp) ||] +liftStencilR (StencilRtup3 s1 s2 s3) + = [|| StencilRtup3 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) ||] +liftStencilR (StencilRtup5 s1 s2 s3 s4 s5) + = [|| StencilRtup5 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) ||] +liftStencilR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) + = [|| StencilRtup7 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) + $$(liftStencilR s6) $$(liftStencilR s7) ||] +liftStencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) + = [|| StencilRtup9 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) + $$(liftStencilR s6) $$(liftStencilR s7) $$(liftStencilR s8) $$(liftStencilR s9) ||] 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) ||] +liftPreOpenFun liftA (Lam lhs f) = [|| Lam $$(liftELhs lhs) $$(liftPreOpenFun liftA f) ||] +liftPreOpenFun liftA (Body b) = [|| Body $$(liftPreOpenExp liftA b) ||] liftPreOpenExp :: forall acc env aenv t. @@ -1634,18 +1787,17 @@ liftPreOpenExp liftA pexp = liftF = liftPreOpenFun liftA in case pexp of - Let lhs bnd body -> [|| Let $$(liftElhs lhs) $$(liftPreOpenExp liftA bnd) $$(liftPreOpenExp liftA body) ||] - Var var -> [|| Var $$(liftScalarVar var) ||] - Foreign asm f x -> [|| Foreign $$(liftForeign asm) $$(liftPreOpenFun liftA f) $$(liftE x) ||] - Const c -> [|| Const $$(liftConst (eltType @t) c) ||] - Undef -> [|| Undef ||] + Let lhs bnd body -> [|| Let $$(liftELhs lhs) $$(liftPreOpenExp liftA bnd) $$(liftPreOpenExp liftA body) ||] + Evar var -> [|| Evar $$(liftExpVar var) ||] + Foreign asm f x -> [|| Foreign $$(Sugar.liftForeign asm) $$(liftPreOpenFun liftA f) $$(liftE x) ||] + Const tp c -> [|| Const $$(liftScalarType tp) $$(liftConst (TupRsingle tp) c) ||] + Undef tp -> [|| Undef $$(liftScalarType tp) ||] Pair a b -> [|| Pair $$(liftE a) $$(liftE b) ||] Nil -> [|| Nil ||] - 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) ||] + ToIndex shr sh ix -> [|| ToIndex $$(liftShapeR shr) $$(liftE sh) $$(liftE ix) ||] + FromIndex shr sh ix -> [|| FromIndex $$(liftShapeR shr) $$(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) ||] @@ -1653,32 +1805,52 @@ liftPreOpenExp liftA pexp = 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) ||] - Coerce e -> [|| Coerce $$(liftE e) ||] + ShapeSize shr ix -> [|| ShapeSize $$(liftShapeR shr) $$(liftE ix) ||] + Coerce t1 t2 e -> [|| Coerce $$(liftScalarType t1) $$(liftScalarType t2) $$(liftE e) ||] -liftScalarVar :: ScalarVar env t -> Q (TExp (ScalarVar env t)) -liftScalarVar (ScalarVar tp ix) = [|| ScalarVar $$(liftScalarType tp) $$(liftIdx ix) ||] +liftExpVar :: ExpVar env t -> Q (TExp (ExpVar env t)) +liftExpVar (Var tp ix) = [|| Var $$(liftScalarType tp) $$(liftIdx ix) ||] -liftArray :: forall sh e. Shape sh => TupleType -> Array sh e -> Q (TExp (Array sh e)) -liftArray tp (Array sh adata) = - [|| Array $$(liftConst (eltType @sh) sh) $$(go arrayElt adata) ||] `sigE` typeRepToType (typeOf (undefined::Array sh e)) +liftArray :: forall sh e. ArrayR (Array sh e) -> Array sh e -> Q (TExp (Array sh e)) +liftArray (ArrayR shr tp) (Array sh adata) = + [|| Array $$(liftConst (shapeType shr) sh) $$(go tp adata) ||] `sigE` [t| Array $(typeToQType $ shapeType shr) $(typeToQType tp) |] where sz :: Int - sz = size sh + sz = size shr 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) + typeToQType :: TupleType t -> Q TH.Type + typeToQType TupRunit = [t| () |] + typeToQType (TupRpair t1 t2) = [t| ($(typeToQType t1), $(typeToQType t2)) |] + typeToQType (TupRsingle t) = scalarTypeToQType t + + scalarTypeToQType :: ScalarType t -> Q TH.Type + scalarTypeToQType (SingleScalarType t) = singleTypeToQType t + scalarTypeToQType (VectorScalarType t) = vectorTypeToQType t + + singleTypeToQType :: SingleType t -> Q TH.Type + singleTypeToQType (NumSingleType (IntegralNumType t)) = case t of + TypeInt -> [t| Int |] + TypeInt8 -> [t| Int8 |] + TypeInt16 -> [t| Int16 |] + TypeInt32 -> [t| Int32 |] + TypeInt64 -> [t| Int64 |] + TypeWord -> [t| Word |] + TypeWord8 -> [t| Word8 |] + TypeWord16 -> [t| Word16 |] + TypeWord32 -> [t| Word32 |] + TypeWord64 -> [t| Word64 |] + singleTypeToQType (NumSingleType (FloatingNumType t)) = case t of + TypeHalf -> [t| Half |] + TypeFloat -> [t| Float |] + TypeDouble -> [t| Double |] + singleTypeToQType (NonNumSingleType TypeBool) = [t| Bool |] + singleTypeToQType (NonNumSingleType TypeChar) = [t| Char |] + + vectorTypeToQType :: VectorType (Vec n a) -> Q TH.Type + vectorTypeToQType (VectorType _ stp) = [t| Vec $(undefined) $(singleTypeToQType stp) |] -- TODO: make sure that the resulting array is 16-byte aligned... arr :: forall a. Storable a => UniqueArray a -> Q (TExp (UniqueArray a)) @@ -1690,37 +1862,68 @@ liftArray tp (Array sh adata) = 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 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 ArrayEltRbool (AD_Bool ua) = [|| AD_Bool $$(arr ua) ||] - go ArrayEltRchar (AD_Char ua) = [|| AD_Char $$(arr ua) ||] - go (ArrayEltRpair r1 r2) (AD_Pair a1 a2) = [|| AD_Pair $$(go r1 a1) $$(go r2 a2) ||] - go (ArrayEltRvec r) (AD_Vec w# a) = TH.unsafeTExpCoerce $ [| AD_Vec $(liftInt# w#) $(TH.unTypeQ (go r a)) |] - + go :: TupleType e' -> ArrayData e' -> Q (TExp (ArrayData e')) + go TupRunit () = [|| () ||] + go (TupRpair t1 t2) (a1, a2) = [|| ($$(go t1 a1), $$(go t2 a2)) ||] + go (TupRsingle stp) a = goScalar stp a + + goScalar :: ScalarType e' -> ArrayData e' -> Q (TExp (ArrayData e')) + goScalar (SingleScalarType stp) a = goSingle stp a + goScalar (VectorScalarType (VectorType _ stp)) a = goVector stp a + + goSingle :: SingleType e' -> ArrayData e' -> Q (TExp (ArrayData e')) + goSingle (NumSingleType (IntegralNumType itp)) = case itp of + TypeInt -> arr + TypeInt8 -> arr + TypeInt16 -> arr + TypeInt32 -> arr + TypeInt64 -> arr + TypeWord -> arr + TypeWord8 -> arr + TypeWord16 -> arr + TypeWord32 -> arr + TypeWord64 -> arr + goSingle (NumSingleType (FloatingNumType ftp)) = case ftp of + TypeHalf -> arr + TypeFloat -> arr + TypeDouble -> arr + goSingle (NonNumSingleType TypeChar) = arr + goSingle (NonNumSingleType TypeBool) = arr + + -- This function has the same implementation as goSingle, but different types. + -- We could convince the type system to have this written as a single function, + -- as ArrayData uses a type family to create a structure of arrays, containing + -- scalars, where the scalars are again handled by a type family (ScalarDataRepr) + goVector :: SingleType e' -> ArrayData (Vec n e') -> Q (TExp (ArrayData (Vec n e'))) + goVector (NumSingleType (IntegralNumType itp)) = case itp of + TypeInt -> arr + TypeInt8 -> arr + TypeInt16 -> arr + TypeInt32 -> arr + TypeInt64 -> arr + TypeWord -> arr + TypeWord8 -> arr + TypeWord16 -> arr + TypeWord32 -> arr + TypeWord64 -> arr + goVector (NumSingleType (FloatingNumType ftp)) = case ftp of + TypeHalf -> arr + TypeFloat -> arr + TypeDouble -> arr + goVector (NonNumSingleType TypeChar) = arr + goVector (NonNumSingleType TypeBool) = arr liftBoundary :: forall acc aenv sh e. LiftAcc acc + -> ArrayR (Array sh e) -> 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 @e) v) ||] -liftBoundary liftA (Function f) = [|| Function $$(liftPreOpenFun liftA f) ||] +liftBoundary _ _ Clamp = [|| Clamp ||] +liftBoundary _ _ Mirror = [|| Mirror ||] +liftBoundary _ _ Wrap = [|| Wrap ||] +liftBoundary _ (ArrayR _ tp) (Constant v) = [|| Constant $$(liftConst tp 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 ||] @@ -1879,25 +2082,25 @@ liftFloating TypeDouble{} x = [|| 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 TypeInt{} = [|| TypeInt ||] +liftIntegralType TypeInt8{} = [|| TypeInt8 ||] +liftIntegralType TypeInt16{} = [|| TypeInt16 ||] +liftIntegralType TypeInt32{} = [|| TypeInt32 ||] +liftIntegralType TypeInt64{} = [|| TypeInt64 ||] +liftIntegralType TypeWord{} = [|| TypeWord ||] +liftIntegralType TypeWord8{} = [|| TypeWord8 ||] +liftIntegralType TypeWord16{} = [|| TypeWord16 ||] +liftIntegralType TypeWord32{} = [|| TypeWord32 ||] +liftIntegralType TypeWord64{} = [|| TypeWord64 ||] liftFloatingType :: FloatingType t -> Q (TExp (FloatingType t)) -liftFloatingType TypeHalf{} = [|| TypeHalf FloatingDict ||] -liftFloatingType TypeFloat{} = [|| TypeFloat FloatingDict ||] -liftFloatingType TypeDouble{} = [|| TypeDouble FloatingDict ||] +liftFloatingType TypeHalf{} = [|| TypeHalf ||] +liftFloatingType TypeFloat{} = [|| TypeFloat ||] +liftFloatingType TypeDouble{} = [|| TypeDouble ||] liftNonNumType :: NonNumType t -> Q (TExp (NonNumType t)) -liftNonNumType TypeBool{} = [|| TypeBool NonNumDict ||] -liftNonNumType TypeChar{} = [|| TypeChar NonNumDict ||] +liftNonNumType TypeBool{} = [|| TypeBool ||] +liftNonNumType TypeChar{} = [|| TypeChar ||] liftNumType :: NumType t -> Q (TExp (NumType t)) liftNumType (IntegralNumType t) = [|| IntegralNumType $$(liftIntegralType t) ||] @@ -1924,8 +2127,8 @@ liftVectorType (VectorType n t) = [|| VectorType n $$(liftSingleType t) ||] showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String showPreAccOp Alet{} = "Alet" -showPreAccOp (Avar (ArrayVar ix)) = "Avar a" ++ show (idxToInt ix) -showPreAccOp (Use a) = "Use " ++ showShortendArr a +showPreAccOp (Avar (Var _ ix)) = "Avar a" ++ show (idxToInt ix) +showPreAccOp (Use repr a) = "Use " ++ showShortendArr repr a showPreAccOp Apply{} = "Apply" showPreAccOp Aforeign{} = "Aforeign" showPreAccOp Acond{} = "Acond" @@ -1957,25 +2160,25 @@ showPreAccOp Stencil2{} = "Stencil2" -- showPreAccOp Collect{} = "Collect" -showShortendArr :: TupleType -> Array sh e -> String -showShortendArr tp arr +showShortendArr :: ArrayR (Array sh e) -> Array sh e -> String +showShortendArr repr@(ArrayR _ tp) arr | length l > cutoff = "[" ++ elements ++ ", ..]" | otherwise = "[" ++ elements ++ "]" where - l = toList arr + l = toList repr arr cutoff = 5 elements = intercalate ", " $ map (showElement tp) $ take cutoff l -showPreExpOp :: forall acc env aenv t. PreOpenExp acc env aenv t -> String +showPreExpOp :: forall acc aenv env t. PreOpenExp acc aenv env t -> String showPreExpOp Let{} = "Let" -showPreExpOp (EVar (Var _ ix)) = "Var x" ++ show (idxToInt ix) -showPreExpOp (Const tp c) = "Const " ++ showElement tp c -showPreExpOp Undef = "Undef" +showPreExpOp (Evar (Var _ ix)) = "Var x" ++ show (idxToInt ix) +showPreExpOp (Const tp c) = "Const " ++ showElement (TupRsingle tp) c +showPreExpOp Undef{} = "Undef" showPreExpOp Foreign{} = "Foreign" showPreExpOp Pair{} = "Pair" showPreExpOp Nil{} = "Nil" -showPreExpOp IndexAny = "IndexAny" +-- showPreExpOp VecPrj{} = "VecPrj" showPreExpOp IndexSlice{} = "IndexSlice" showPreExpOp IndexFull{} = "IndexFull" showPreExpOp ToIndex{} = "ToIndex" @@ -1989,49 +2192,3 @@ showPreExpOp LinearIndex{} = "LinearIndex" showPreExpOp Shape{} = "Shape" showPreExpOp ShapeSize{} = "ShapeSize" showPreExpOp Coerce{} = "Coerce" - -showElement :: TupleType e -> e -> String -showElement tuple value = showElement' tuple value "" - where - showElement' :: TupleType e -> e -> ShowS - showElement' TupRunit () = showString "()" - showElement' (TupRpair t1 t2) (e1, e2) = showString "(" . showElement' t1 e1 . showString ", " . showElement' t2 e2 . showString ")" - showElement' (TupRsingle tp) val = showScalar tp val - - showScalar :: ScalarType e -> e -> ShowS - showScalar (SingleScalarType t) e = showString $ showSingle t e - showScalar (VectorScalarType t) e = showString $ showVector t e - - showSingle :: SingleType e -> e -> String - showSingle (NumSingleType t) e = showNum t e - showSingle (NonNumSingleType t) e = showNonNum t e - - showNum :: NumType e -> e -> String - showNum (IntegralNumType t) e = showIntegral t e - showNum (FloatingNumType t) e = showFloating t e - - showIntegral :: IntegralType e -> e -> String - showIntegral TypeInt{} e = show e - showIntegral TypeInt8{} e = show e - showIntegral TypeInt16{} e = show e - showIntegral TypeInt32{} e = show e - showIntegral TypeInt64{} e = show e - showIntegral TypeWord{} e = show e - showIntegral TypeWord8{} e = show e - showIntegral TypeWord16{} e = show e - showIntegral TypeWord32{} e = show e - showIntegral TypeWord64{} e = show e - - showFloating :: FloatingType e -> e -> String - showFloating TypeHalf{} e = show e - showFloating TypeFloat{} e = show e - showFloating TypeDouble{} e = show e - - showNonNum :: NonNumType e -> e -> String - showNonNum TypeChar e = show e - showNonNum TypeBool e = show e - - showVector :: VectorType (Vec n a) e -> String - showVector (VectorType _ scalar) vec = "<" ++ (intercalate ", " $ showScalar scalar $ vecToArray vec) ++ ">" - - diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 9da93010a..fba76156a 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -38,9 +38,7 @@ module Data.Array.Accelerate.Analysis.Hash ( 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.Array.Representation import Data.Array.Accelerate.Type import Crypto.Hash @@ -94,33 +92,33 @@ defaultHashOptions = HashOptions True {-# INLINEABLE hashPreOpenAcc #-} -hashPreOpenAcc :: EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash +hashPreOpenAcc :: HasArraysRepr acc => EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash hashPreOpenAcc = hashPreOpenAccWith defaultHashOptions {-# INLINEABLE hashPreOpenFun #-} -hashPreOpenFun :: EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash +hashPreOpenFun :: HasArraysRepr acc => EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash hashPreOpenFun = hashPreOpenFunWith defaultHashOptions {-# INLINEABLE hashPreOpenExp #-} -hashPreOpenExp :: EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash +hashPreOpenExp :: HasArraysRepr acc => EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash hashPreOpenExp = hashPreOpenExpWith defaultHashOptions {-# INLINEABLE hashPreOpenAccWith #-} -hashPreOpenAccWith :: HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash +hashPreOpenAccWith :: HasArraysRepr acc => HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash hashPreOpenAccWith options encodeAcc = hashlazy . toLazyByteString . encodePreOpenAcc options encodeAcc {-# INLINEABLE hashPreOpenFunWith #-} -hashPreOpenFunWith :: HashOptions -> EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash +hashPreOpenFunWith :: HasArraysRepr acc => HashOptions -> EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash hashPreOpenFunWith options encodeAcc = hashlazy . toLazyByteString . encodePreOpenFun options encodeAcc {-# INLINEABLE hashPreOpenExpWith #-} -hashPreOpenExpWith :: HashOptions -> EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash +hashPreOpenExpWith :: HasArraysRepr acc => HashOptions -> EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash hashPreOpenExpWith options encodeAcc = hashlazy . toLazyByteString @@ -134,8 +132,8 @@ type EncodeAcc acc = forall aenv a. HashOptions -> acc aenv a -> Builder {-# INLINEABLE encodePreOpenAcc #-} encodePreOpenAcc - :: forall acc aenv arrs. - HashOptions + :: forall acc aenv arrs. HasArraysRepr acc + => HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv arrs -> Builder @@ -153,55 +151,52 @@ encodePreOpenAcc options encodeAcc pacc = travF :: PreOpenFun acc env' aenv' f -> Builder travF = encodePreOpenFun options encodeAcc - travB :: PreBoundary acc aenv' (Array sh e) -> Builder + travB :: TupleType e -> PreBoundary acc aenv' (Array sh e) -> Builder travB = encodePreBoundary options encodeAcc deep :: Builder -> Builder deep | perfect options = id | otherwise = const mempty - deepE :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder + deepE :: forall env' aenv' e. PreOpenExp acc env' aenv' e -> Builder deepE e | perfect options = travE e - | otherwise = encodeTupleType (eltType @e) - - arrayHash :: (Shape sh, Elt e, arrs ~ Array sh e) => Builder - arrayHash = encodeArrayType @arrs + | otherwise = encodeTupleType $ expType e in case pacc of - Alet lhs bnd body -> intHost $(hashQ "Alet") <> encodeLeftHandSide lhs <> travA bnd <> travA body - Avar (ArrayVar v) -> intHost $(hashQ "Avar") <> arrayHash <> deep (encodeIdx v) - Apair a1 a2 -> intHost $(hashQ "Apair") <> travA a1 <> travA a2 - Anil -> intHost $(hashQ "Anil") - Apply f a -> intHost $(hashQ "Apply") <> travAF f <> travA a - Aforeign _ f a -> intHost $(hashQ "Aforeign") <> travAF f <> travA a - Use a -> intHost $(hashQ "Use") <> arrayHash <> deep (encodeArray a) - Awhile p f a -> intHost $(hashQ "Awhile") <> travAF f <> travAF p <> travA a - Unit e -> intHost $(hashQ "Unit") <> travE e - Generate e f -> intHost $(hashQ "Generate") <> deepE e <> travF f + Alet lhs bnd body -> intHost $(hashQ "Alet") <> encodeLeftHandSide encodeArrayType lhs <> travA bnd <> travA body + Avar (Var repr v) -> intHost $(hashQ "Avar") <> encodeArrayType repr <> deep (encodeIdx v) + Apair a1 a2 -> intHost $(hashQ "Apair") <> travA a1 <> travA a2 + Anil -> intHost $(hashQ "Anil") + Apply f a -> intHost $(hashQ "Apply") <> travAF f <> travA a + Aforeign _ f a -> intHost $(hashQ "Aforeign") <> travAF f <> travA a + Use repr a -> intHost $(hashQ "Use") <> encodeArrayType repr <> deep (encodeArray a) + Awhile p f a -> intHost $(hashQ "Awhile") <> travAF f <> travAF p <> travA a + Unit e -> intHost $(hashQ "Unit") <> travE e + Generate _ e f -> intHost $(hashQ "Generate") <> deepE e <> travF f -- We don't need to encode the type of 'e' when perfect is False, as 'e' is an expression of type Bool. -- We thus use `deep (travE e)` instead of `deepE e`. - Acond e a1 a2 -> intHost $(hashQ "Acond") <> deep (travE e) <> travA a1 <> travA a2 - Reshape sh a -> intHost $(hashQ "Reshape") <> deepE sh <> travA a - Backpermute sh f a -> intHost $(hashQ "Backpermute") <> deepE sh <> travF f <> travA a - Transform sh f1 f2 a -> intHost $(hashQ "Transform") <> deepE sh <> travF f1 <> travF f2 <> travA a - Replicate spec ix a -> intHost $(hashQ "Replicate") <> deepE ix <> travA a <> encodeSliceIndex spec - Slice spec a ix -> intHost $(hashQ "Slice") <> deepE 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 - 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 + Acond e a1 a2 -> intHost $(hashQ "Acond") <> deep (travE e) <> travA a1 <> travA a2 + Reshape _ sh a -> intHost $(hashQ "Reshape") <> deepE sh <> travA a + Backpermute _ sh f a -> intHost $(hashQ "Backpermute") <> deepE sh <> travF f <> travA a + Transform _ sh f1 f2 a -> intHost $(hashQ "Transform") <> deepE sh <> travF f1 <> travF f2 <> travA a + Replicate spec ix a -> intHost $(hashQ "Replicate") <> deepE ix <> travA a <> encodeSliceIndex spec + Slice spec a ix -> intHost $(hashQ "Slice") <> deepE 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 + Permute f1 a1 f2 a2 -> intHost $(hashQ "Permute") <> travF f1 <> travA a1 <> travF f2 <> travA a2 + Stencil s _ f b a -> intHost $(hashQ "Stencil") <> travF f <> travB (stencilElt s) b <> travA a + Stencil2 s1 s2 _ f b1 a1 b2 a2 -> intHost $(hashQ "Stencil2") <> travF f <> travB (stencilElt s1) b1 <> travA a1 <> travB (stencilElt s2) b2 <> travA a2 {-- {-# INLINEABLE encodePreOpenSeq #-} @@ -252,24 +247,27 @@ encodePreOpenSeq encodeAcc s = encodeIdx :: Idx env t -> Builder encodeIdx = intHost . idxToInt -encodeTupleIdx :: TupleIdx tup e -> Builder -encodeTupleIdx = intHost . tupleIdxToInt - -encodeArray :: (Shape sh, Elt e) => Array sh e -> Builder +encodeArray :: Array sh e -> Builder encodeArray ad = intHost . unsafePerformIO $! hashStableName <$> makeStableName ad -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 @a +encodeTupR :: (forall b. s b -> Builder) -> TupR s a -> Builder +encodeTupR _ TupRunit = intHost $(hashQ "TupRunit") +encodeTupR f (TupRpair r1 r2) = intHost $(hashQ "TupRpair") <> encodeTupR f r1 <> encodeTupR f r2 +encodeTupR f (TupRsingle s) = intHost $(hashQ "TupRsingle") <> f s + +encodeLeftHandSide :: (forall b. s b -> Builder) -> LeftHandSide s a env env' -> Builder +encodeLeftHandSide f (LeftHandSideWildcard r) = intHost $(hashQ "LeftHandSideWildcard") <> encodeTupR f r +encodeLeftHandSide f (LeftHandSidePair r1 r2) = intHost $(hashQ "LeftHandSidePair") <> encodeLeftHandSide f r1 <> encodeLeftHandSide f r2 +encodeLeftHandSide f (LeftHandSideSingle s) = intHost $(hashQ "LeftHandSideArray") <> f s + +encodeArrayType :: ArrayR a -> Builder +encodeArrayType (ArrayR shr tp) = encodeShapeR shr <> encodeTupleType tp -encodeLeftHandSide :: forall a env env'. LeftHandSide a env env' -> Builder -encodeLeftHandSide (LeftHandSideWildcard r) = intHost $(hashQ "LeftHandSideWildcard") <> encodeArraysType r -encodeLeftHandSide (LeftHandSidePair r1 r2) = intHost $(hashQ "LeftHandSidePair") <> encodeLeftHandSide r1 <> encodeLeftHandSide r2 -encodeLeftHandSide LeftHandSideArray = intHost $(hashQ "LeftHandSideArray") <> encodeArrayType @a +encodeArraysType :: ArraysR arrs -> Builder +encodeArraysType = encodeTupR encodeArrayType -encodeArrayType :: forall array sh e. (array ~ Array sh e, Shape sh, Elt e) => Builder -encodeArrayType = encodeTupleType (eltType @sh) <> encodeTupleType (eltType @e) +encodeShapeR :: ShapeR sh -> Builder +encodeShapeR = intHost . rank encodePreOpenAfun :: forall acc aenv f. @@ -279,8 +277,8 @@ encodePreOpenAfun -> Builder encodePreOpenAfun options travA afun = let - travL :: forall aenv1 aenv2 a b. LeftHandSide a aenv1 aenv2 -> PreOpenAfun acc aenv2 b -> Builder - travL lhs l = encodeLeftHandSide lhs <> encodePreOpenAfun options travA l + travL :: forall aenv1 aenv2 a b. ALeftHandSide a aenv1 aenv2 -> PreOpenAfun acc aenv2 b -> Builder + travL lhs l = encodeLeftHandSide encodeArrayType lhs <> encodePreOpenAfun options travA l in case afun of Abody b -> intHost $(hashQ "Abody") <> travA options b @@ -291,13 +289,14 @@ encodePreBoundary :: forall acc aenv sh e. HashOptions -> EncodeAcc acc + -> TupleType e -> 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 @e) c -encodePreBoundary o h (Function f) = intHost $(hashQ "Function") <> encodePreOpenFun o h f +encodePreBoundary _ _ _ Wrap = intHost $(hashQ "Wrap") +encodePreBoundary _ _ _ Clamp = intHost $(hashQ "Clamp") +encodePreBoundary _ _ _ Mirror = intHost $(hashQ "Mirror") +encodePreBoundary _ _ tp (Constant c) = intHost $(hashQ "Constant") <> encodeConst tp c +encodePreBoundary o h _ (Function f) = intHost $(hashQ "Function") <> encodePreOpenFun o h f encodeSliceIndex :: SliceIndex slix sl co sh -> Builder encodeSliceIndex SliceNil = intHost $(hashQ "SliceNil") @@ -317,34 +316,26 @@ encodePreOpenExp -> Builder encodePreOpenExp options encodeAcc exp = let - travA :: forall aenv' a. Arrays a => acc aenv' a -> Builder - travA a = encodeArraysType (arrays @a) <> encodeAcc options a + travA :: forall aenv' a. acc aenv' a -> Builder + travA a = encodeAcc options a - travE :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder - travE e = encodeTupleType (eltType @e) <> encodePreOpenExp options encodeAcc e + travE :: forall env' aenv' e. PreOpenExp acc env' aenv' e -> Builder + travE e = encodePreOpenExp options encodeAcc e travF :: PreOpenFun acc env' aenv' f -> Builder travF = encodePreOpenFun options encodeAcc - - nacl :: Elt exp => Builder - nacl = encodeTupleType (eltType @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 options encodeAcc 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 @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 + Let lhs bnd body -> intHost $(hashQ "Let") <> encodeLeftHandSide encodeScalarType lhs <> travE bnd <> travE body + Evar (Var tp ix) -> intHost $(hashQ "Evar") <> encodeScalarType tp <> encodeIdx ix + Nil -> intHost $(hashQ "Nil") + Pair e1 e2 -> intHost $(hashQ "Pair") <> travE e1 <> travE e2 + Const tp c -> intHost $(hashQ "Const") <> encodeScalarConst tp c + Undef tp -> intHost $(hashQ "Undef") <> encodeScalarType tp 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 + 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 @@ -352,11 +343,9 @@ encodePreOpenExp options encodeAcc exp = 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 + ShapeSize _ sh -> intHost $(hashQ "ShapeSize") <> travE sh Foreign _ f e -> intHost $(hashQ "Foreign") <> travF f <> travE e - Coerce e -> intHost $(hashQ "Coerce") <> travE e + Coerce _ tp e -> intHost $(hashQ "Coerce") <> encodeScalarType tp <> travE e {-# INLINEABLE encodePreOpenFun #-} @@ -368,29 +357,21 @@ encodePreOpenFun -> Builder encodePreOpenFun options travA fun = let - travB :: forall env' aenv' e. Elt e => PreOpenExp acc env' aenv' e -> Builder - travB b = encodeTupleType (eltType @e) <> encodePreOpenExp options travA b + travB :: forall env' aenv' e. PreOpenExp acc env' aenv' e -> Builder + travB b = encodePreOpenExp options travA b - travL :: forall env' aenv' a b. Elt a => PreOpenFun acc (env',a) aenv' b -> Builder - travL l = encodeTupleType (eltType @a) <> encodePreOpenFun options travA l + travL :: forall env' aenv' b. PreOpenFun acc env' aenv' b -> Builder + travL l = encodePreOpenFun options travA l in case fun of Body b -> intHost $(hashQ "Body") <> travB b - Lam l -> intHost $(hashQ "Lam") <> travL l - -encodeTuple - :: HashOptions - -> EncodeAcc acc - -> Tuple (PreOpenExp acc env aenv) e - -> Builder -encodeTuple _ _ NilTup = intHost $(hashQ "NilTup") -encodeTuple o h (SnocTup t e) = intHost $(hashQ "SnocTup") <> encodeTuple o h t <> encodePreOpenExp o h e + Lam lhs l -> intHost $(hashQ "Lam") <> encodeLeftHandSide encodeScalarType lhs <> travL l 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 +encodeConst TupRunit () = intHost $(hashQ "nil") +encodeConst (TupRsingle t) c = encodeScalarConst t c +encodeConst (TupRpair ta tb) (a,b) = intHost $(hashQ "pair") <> encodeConst ta a <> encodeConst tb b encodeScalarConst :: ScalarType t -> t -> Builder encodeScalarConst (SingleScalarType t) = encodeSingleConst t @@ -506,15 +487,15 @@ encodePrimFun PrimBoolToInt = intHost $(hashQ "PrimBoolToInt") 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) +encodeTupleType TupRunit = intHost $(hashQ "TupRunit") +encodeTupleType (TupRsingle t) = intHost $(hashQ "TupRsingle") <> encodeScalarType t +encodeTupleType (TupRpair a b) = intHost $(hashQ "TupRpair") <> encodeTupleType a <> intHost (depthTypeR a) + <> encodeTupleType b <> intHost (depthTypeR b) depthTypeR :: TupleType t -> Int -depthTypeR TypeRunit = 0 -depthTypeR TypeRscalar{} = 1 -depthTypeR (TypeRpair a b) = depthTypeR a + depthTypeR b +depthTypeR TupRunit = 0 +depthTypeR TupRsingle{} = 1 +depthTypeR (TupRpair a b) = depthTypeR a + depthTypeR b encodeScalarType :: ScalarType t -> Builder encodeScalarType (SingleScalarType t) = intHost $(hashQ "SingleScalarType") <> encodeSingleType t diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index ecbae8dde..edfeb60cf 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -29,9 +29,9 @@ module Data.Array.Accelerate.Analysis.Match ( matchPrimFun, matchPrimFun', -- auxiliary - matchIdx, matchArrayVar, matchArrayVars, matchTupleType, matchShapeType, - matchIntegralType, matchFloatingType, matchNumType, matchScalarType, - matchLeftHandSide, matchLeftHandSide', + matchIdx, matchVar, matchVars, matchArrayR, matchArraysR, matchTupleType, matchShapeR, + matchShapeType, matchIntegralType, matchFloatingType, matchNumType, matchScalarType, + matchLeftHandSide, matchALeftHandSide, matchELeftHandSide, matchSingleType, matchTupR ) where @@ -45,10 +45,9 @@ import Prelude hiding ( exp ) -- friends import Data.Array.Accelerate.Analysis.Hash -import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Representation +import qualified Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Type @@ -62,8 +61,8 @@ type MatchAcc acc = forall aenv s t. acc aenv s -> acc aenv t -> Maybe (s :~: t) -- {-# INLINEABLE matchPreOpenAcc #-} matchPreOpenAcc - :: forall acc aenv s t. - MatchAcc acc + :: forall acc aenv s t. HasArraysRepr acc + => MatchAcc acc -> EncodeAcc acc -> PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t @@ -78,13 +77,13 @@ matchPreOpenAcc matchAcc encodeAcc = match match :: PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t -> Maybe (s :~: t) match (Alet lhs1 x1 a1) (Alet lhs2 x2 a2) - | Just Refl <- matchLeftHandSide lhs1 lhs2 + | Just Refl <- matchALeftHandSide lhs1 lhs2 , Just Refl <- matchAcc x1 x2 , Just Refl <- matchAcc a1 a2 = Just Refl - match (Avar (ArrayVar v1)) (Avar (ArrayVar v2)) - = matchIdx v1 v2 + match (Avar v1) (Avar v2) + = matchVar v1 v2 match (Apair a1 a2) (Apair b1 b2) | Just Refl <- matchAcc a1 b1 @@ -119,47 +118,49 @@ matchPreOpenAcc matchAcc encodeAcc = match , Just Refl <- matchPreOpenAfun matchAcc f1 f2 = Just Refl - match (Use a1) (Use a2) - | Just Refl <- matchArray a1 a2 + match (Use repr1 a1) (Use repr2 a2) + | Just Refl <- matchArray repr1 repr2 a1 a2 = Just Refl match (Unit e1) (Unit e2) | Just Refl <- matchExp e1 e2 = Just Refl - match (Reshape sh1 a1) (Reshape sh2 a2) + 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) + 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) + 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 + match (Replicate si1 ix1 a1) (Replicate si2 ix2 a2) + | Just Refl <- matchSliceIndex si1 si2 + , Just Refl <- matchExp ix1 ix2 , Just Refl <- matchAcc a1 a2 - = gcast Refl -- slice specification ?? + = Just Refl - match (Slice _ a1 ix1) (Slice _ a2 ix2) - | Just Refl <- matchAcc a1 a2 + match (Slice si1 a1 ix1) (Slice si2 a2 ix2) + | Just Refl <- matchSliceIndex si1 si2 + , Just Refl <- matchAcc a1 a2 , Just Refl <- matchExp ix1 ix2 - = gcast Refl -- slice specification ?? + = Just Refl - match (Map f1 a1) (Map f2 a2) + 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) + match (ZipWith _ f1 a1 b1) (ZipWith _ f2 a2 b2) | Just Refl <- matchFun f1 f2 , Just Refl <- matchAcc a1 a2 , Just Refl <- matchAcc b1 b2 @@ -176,14 +177,14 @@ matchPreOpenAcc matchAcc encodeAcc = match , Just Refl <- matchAcc a1 a2 = Just Refl - match (FoldSeg f1 z1 a1 s1) (FoldSeg f2 z2 a2 s2) + 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) + match (Fold1Seg _ f1 a1 s1) (Fold1Seg _ f2 a2 s2) | Just Refl <- matchFun f1 f2 , Just Refl <- matchAcc a1 a2 , Just Refl <- matchAcc s1 s2 @@ -230,24 +231,24 @@ matchPreOpenAcc matchAcc encodeAcc = match , Just Refl <- matchAcc a1 a2 = Just Refl - match (Backpermute sh1 ix1 a1) (Backpermute sh2 ix2 a2) + 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) + match (Stencil s1 _ f1 b1 a1) (Stencil _ _ f2 b2 a2) | Just Refl <- matchFun f1 f2 , Just Refl <- matchAcc a1 a2 - , matchBoundary matchAcc encodeAcc b1 b2 + , matchBoundary matchAcc encodeAcc (stencilElt s1) b1 b2 = Just Refl - match (Stencil2 f1 b1 a1 b2 a2) (Stencil2 f2 b1' a1' b2' a2') + match (Stencil2 s1 s2 _ 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' + , matchBoundary matchAcc encodeAcc (stencilElt s1) b1 b1' + , matchBoundary matchAcc encodeAcc (stencilElt s2) b2 b2' = Just Refl -- match (Collect s1) (Collect s2) @@ -265,56 +266,50 @@ matchPreOpenAfun -> PreOpenAfun acc aenv t -> Maybe (s :~: t) matchPreOpenAfun m (Alam lhs1 s) (Alam lhs2 t) - | Just Refl <- matchLeftHandSide lhs1 lhs2 + | Just Refl <- matchALeftHandSide lhs1 lhs2 , Just Refl <- matchPreOpenAfun m s t = Just Refl matchPreOpenAfun m (Abody s) (Abody t) = m s t matchPreOpenAfun _ _ _ = Nothing -matchLeftHandSide :: forall aenv aenv1 aenv2 arr1 arr2. LeftHandSide arr1 aenv aenv1 -> LeftHandSide arr2 aenv aenv2 -> Maybe (LeftHandSide arr1 aenv aenv1 :~: LeftHandSide arr2 aenv aenv2) -matchLeftHandSide (LeftHandSideWildcard repr1) (LeftHandSideWildcard repr2) - | Just Refl <- matchArraysR repr1 repr2 - = Just Refl -matchLeftHandSide LeftHandSideArray LeftHandSideArray - | Just Refl <- gcast @arr1 @arr2 Refl - = Just Refl -matchLeftHandSide (LeftHandSidePair a1 a2) (LeftHandSidePair b1 b2) - | Just Refl <- matchLeftHandSide a1 b1 - , Just Refl <- matchLeftHandSide a2 b2 - = Just Refl -matchLeftHandSide _ _ = Nothing +matchALeftHandSide :: forall aenv aenv1 aenv2 t1 t2. ALeftHandSide t1 aenv aenv1 -> ALeftHandSide t2 aenv aenv2 -> Maybe (ALeftHandSide t1 aenv aenv1 :~: ALeftHandSide t2 aenv aenv2) +matchALeftHandSide = matchLeftHandSide matchArrayR -matchLeftHandSide' :: forall aenv aenv1 aenv2 arr1 arr2. LeftHandSide arr1 aenv1 aenv -> LeftHandSide arr2 aenv2 aenv -> Maybe (LeftHandSide arr1 aenv1 aenv :~: LeftHandSide arr2 aenv2 aenv) -matchLeftHandSide' (LeftHandSideWildcard repr1) (LeftHandSideWildcard repr2) - | Just Refl <- matchArraysR repr1 repr2 +matchELeftHandSide :: forall env env1 env2 t1 t2. ELeftHandSide t1 env env1 -> ELeftHandSide t2 env env2 -> Maybe (ELeftHandSide t1 env env1 :~: ELeftHandSide t2 env env2) +matchELeftHandSide = matchLeftHandSide matchScalarType + +matchLeftHandSide :: forall s env env1 env2 t1 t2. (forall x y. s x -> s y -> Maybe (x :~: y)) -> LeftHandSide s t1 env env1 -> LeftHandSide s t2 env env2 -> Maybe (LeftHandSide s t1 env env1 :~: LeftHandSide s t2 env env2) +matchLeftHandSide f (LeftHandSideWildcard repr1) (LeftHandSideWildcard repr2) + | Just Refl <- matchTupR f repr1 repr2 = Just Refl -matchLeftHandSide' LeftHandSideArray LeftHandSideArray - | Just Refl <- gcast @arr1 @arr2 Refl +matchLeftHandSide f (LeftHandSideSingle x) (LeftHandSideSingle y) + | Just Refl <- f x y = Just Refl -matchLeftHandSide' (LeftHandSidePair a1 a2) (LeftHandSidePair b1 b2) - | Just Refl <- matchLeftHandSide' a2 b2 - , Just Refl <- matchLeftHandSide' a1 b1 +matchLeftHandSide f (LeftHandSidePair a1 a2) (LeftHandSidePair b1 b2) + | Just Refl <- matchLeftHandSide f a1 b1 + , Just Refl <- matchLeftHandSide f a2 b2 = Just Refl -matchLeftHandSide' _ _ = Nothing +matchLeftHandSide _ _ _ = Nothing -- Match stencil boundaries -- matchBoundary - :: forall acc aenv sh t. Elt t + :: HasArraysRepr acc => MatchAcc acc -> EncodeAcc acc + -> TupleType t -> 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 @t) s t -matchBoundary m h (Function f) (Function g) +matchBoundary _ _ _ Clamp Clamp = True +matchBoundary _ _ _ Mirror Mirror = True +matchBoundary _ _ _ Wrap Wrap = True +matchBoundary _ _ tp (Constant s) (Constant t) = matchConst tp s t +matchBoundary m h _ (Function f) (Function g) | Just Refl <- matchPreOpenFun m h f g = True -matchBoundary _ _ _ _ +matchBoundary _ _ _ _ _ = False @@ -401,33 +396,39 @@ matchSeq m h = match -- As a convenience, we are just comparing the stable names, but we could also -- walk the structure comparing the underlying ptrsOfArrayData. -- -matchArray :: (Shape sh1, Elt e1, Shape sh2, Elt e2) - => Array sh1 e1 -> Array sh2 e2 -> Maybe (Array sh1 e1 :~: Array sh2 e2) -matchArray (Array _ ad1) (Array _ ad2) - | unsafePerformIO $ do +matchArray :: ArrayR (Array sh1 e1) + -> ArrayR (Array sh2 e2) + -> Array sh1 e1 + -> Array sh2 e2 + -> Maybe (Array sh1 e1 :~: Array sh2 e2) +matchArray repr1 repr2 (Array _ ad1) (Array _ ad2) + | Just Refl <- matchArrayR repr1 repr2 + , unsafePerformIO $ do + sn1 <- makeStableName ad1 sn2 <- makeStableName ad2 return $! hashStableName sn1 == hashStableName sn2 - = gcast Refl + = Just Refl -matchArray _ _ +matchArray _ _ _ _ = Nothing -matchArraysR :: ArraysR s -> ArraysR t -> Maybe (s :~: t) -matchArraysR ArraysRunit ArraysRunit - = Just Refl - -matchArraysR (ArraysRpair a1 b1) (ArraysRpair a2 b2) - | Just Refl <- matchArraysR a1 a2 - , Just Refl <- matchArraysR b1 b2 - = Just Refl +matchTupR :: (forall u1 u2. s u1 -> s u2 -> Maybe (u1 :~: u2)) -> TupR s t1 -> TupR s t2 -> Maybe (t1 :~: t2) +matchTupR _ TupRunit TupRunit = Just Refl +matchTupR f (TupRsingle x) (TupRsingle y) = f x y +matchTupR f (TupRpair x1 x2) (TupRpair y1 y2) + | Just Refl <- matchTupR f x1 y1 + , Just Refl <- matchTupR f x2 y2 = Just Refl +matchTupR _ _ _ = Nothing -matchArraysR ArraysRarray ArraysRarray - = gcast Refl - -matchArraysR _ _ - = Nothing +matchArraysR :: ArraysR s -> ArraysR t -> Maybe (s :~: t) +matchArraysR = matchTupR matchArrayR +matchArrayR :: ArrayR s -> ArrayR t -> Maybe (s :~: t) +matchArrayR (ArrayR shr1 tp1) (ArrayR shr2 tp2) + | Just Refl <- matchShapeR shr1 shr2 + , Just Refl <- matchTupleType tp1 tp2 = Just Refl +matchArrayR _ _ = Nothing -- Compute the congruence of two scalar expressions. Two nodes are congruent if @@ -441,8 +442,8 @@ matchArraysR _ _ -- {-# INLINEABLE matchPreOpenExp #-} matchPreOpenExp - :: forall acc env aenv s t. - MatchAcc acc + :: forall acc env aenv s t. HasArraysRepr acc + => MatchAcc acc -> EncodeAcc acc -> PreOpenExp acc env aenv s -> PreOpenExp acc env aenv t @@ -453,13 +454,14 @@ matchPreOpenExp matchAcc encodeAcc = match 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 + match (Let lhs1 x1 e1) (Let lhs2 x2 e2) + | Just Refl <- matchELeftHandSide lhs1 lhs2 + , Just Refl <- match x1 x2 , Just Refl <- match e1 e2 = Just Refl - match (Var v1) (Var v2) - = matchIdx v1 v2 + match (Evar v1) (Evar v2) + = matchVar v1 v2 match (Foreign ff1 _ e1) (Foreign ff2 _ e2) | Just Refl <- match e1 e2 @@ -469,66 +471,44 @@ matchPreOpenExp matchAcc encodeAcc = match return $! hashStableName sn1 == hashStableName sn2 = gcast Refl - match (Const c1) (Const c2) - | Just Refl <- matchTupleType (eltType @s') (eltType @t') - , matchConst (eltType @s') c1 c2 - = gcast Refl -- surface/representation type - - match Undef Undef - | Just Refl <- matchTupleType (eltType @s') (eltType @t') - = gcast Refl - - match (Coerce e1) (Coerce e2) - | Just Refl <- matchTupleType (eltType @s') (eltType @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 + match (Const t1 c1) (Const t2 c2) + | Just Refl <- matchScalarType t1 t2 + , matchConst (TupRsingle t1) c1 c2 = Just Refl - match IndexAny IndexAny - = gcast Refl -- ??? - - match IndexNil IndexNil - = Just Refl + match (Undef t1) (Undef t2) = matchScalarType t1 t2 - match (IndexCons sl1 a1) (IndexCons sl2 a2) - | Just Refl <- match sl1 sl2 - , Just Refl <- match a1 a2 + match (Coerce _ t1 e1) (Coerce _ t2 e2) + | Just Refl <- matchScalarType t1 t2 + , Just Refl <- match e1 e2 = Just Refl - match (IndexHead sl1) (IndexHead sl2) - | Just Refl <- match sl1 sl2 + match (Pair a1 b1) (Pair a2 b2) + | Just Refl <- match a1 a2 + , Just Refl <- match b1 b2 = Just Refl - match (IndexTail sl1) (IndexTail sl2) - | Just Refl <- match sl1 sl2 + match Nil Nil = 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 + , Just Refl <- matchSliceIndex sliceIndex1 sliceIndex2 + = Just Refl 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 + , Just Refl <- matchSliceIndex sliceIndex1 sliceIndex2 + = Just Refl - match (ToIndex sh1 i1) (ToIndex sh2 i2) + 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) + match (FromIndex _ sh1 i1) (FromIndex _ sh2 i2) | Just Refl <- match i1 i2 , Just Refl <- match sh1 sh2 = Just Refl @@ -573,20 +553,10 @@ matchPreOpenExp matchAcc encodeAcc = match | Just Refl <- matchAcc a1 a2 -- should only be array indices = Just Refl - match (ShapeSize sh1) (ShapeSize sh2) + 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 @@ -595,18 +565,16 @@ matchPreOpenExp matchAcc encodeAcc = match -- {-# INLINEABLE matchPreOpenFun #-} matchPreOpenFun - :: MatchAcc acc + :: HasArraysRepr acc + => 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 +matchPreOpenFun m h (Lam lhs1 s) (Lam lhs2 t) + | Just Refl <- matchELeftHandSide lhs1 lhs2 , 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 @@ -614,9 +582,9 @@ matchPreOpenFun _ _ _ _ = Nothing -- Matching constants -- 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 +matchConst TupRunit () () = True +matchConst (TupRsingle ty) a b = evalEq ty (a,b) +matchConst (TupRpair 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 @@ -642,87 +610,38 @@ matchIdx ZeroIdx ZeroIdx = Just Refl matchIdx (SuccIdx u) (SuccIdx v) = matchIdx u v matchIdx _ _ = Nothing -{-# INLINEABLE matchArrayVar #-} -matchArrayVar :: ArrayVar env s -> ArrayVar env t -> Maybe (s :~: t) -matchArrayVar (ArrayVar v1) (ArrayVar v2) = matchIdx v1 v2 - -{-# INLINEABLE matchArrayVars #-} -matchArrayVars :: ArrayVars env s -> ArrayVars env t -> Maybe (s :~: t) -matchArrayVars ArrayVarsNil ArrayVarsNil = Just Refl -matchArrayVars (ArrayVarsArray v1) (ArrayVarsArray v2) - | Just Refl <- matchArrayVar v1 v2 = Just Refl -matchArrayVars (ArrayVarsPair v w) (ArrayVarsPair x y) - | Just Refl <- matchArrayVars v x - , Just Refl <- matchArrayVars w y = Just Refl -matchArrayVars _ _ = 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 --- -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 +{-# INLINEABLE matchVar #-} +matchVar :: Var s env t1 -> Var s env t2 -> Maybe (t1 :~: t2) +matchVar (Var _ v1) (Var _ v2) = matchIdx v1 v2 -matchTuple _ _ _ _ = Nothing +{-# INLINEABLE matchVars #-} +matchVars :: Vars s env t1 -> Vars s env t2 -> Maybe (t1 :~: t2) +matchVars VarsNil VarsNil = Just Refl +matchVars (VarsSingle v1) (VarsSingle v2) + | Just Refl <- matchVar v1 v2 = Just Refl +matchVars (VarsPair v w) (VarsPair x y) + | Just Refl <- matchVars v x + , Just Refl <- matchVars w y = Just Refl +matchVars _ _ = 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 +matchSliceIndex :: SliceIndex slix1 sl1 co1 sh1 -> SliceIndex slix2 sl2 co2 sh2 -> Maybe (SliceIndex slix1 sl1 co1 sh1 :~: SliceIndex slix2 sl2 co2 sh2) +matchSliceIndex SliceNil SliceNil = Just Refl -matchSliceExtend (SliceAll sl1) (SliceAll sl2) - | Just Refl <- matchSliceExtend sl1 sl2 +matchSliceIndex (SliceAll sl1) (SliceAll sl2) + | Just Refl <- matchSliceIndex sl1 sl2 = Just Refl -matchSliceExtend (SliceFixed sl1) (SliceFixed sl2) - | Just Refl <- matchSliceExtend sl1 sl2 +matchSliceIndex (SliceFixed sl1) (SliceFixed sl2) + | Just Refl <- matchSliceIndex sl1 sl2 = Just Refl -matchSliceExtend _ _ +matchSliceIndex _ _ = Nothing - -- Primitive constants and functions -- matchPrimConst :: PrimConst s -> PrimConst t -> Maybe (s :~: t) @@ -902,15 +821,7 @@ matchPrimFun' _ _ -- {-# 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 +matchTupleType = matchTupR matchScalarType -- Match shapes (dimensionality) @@ -922,9 +833,9 @@ matchTupleType _ _ -- a known branch. -- {-# INLINEABLE matchShapeType #-} -matchShapeType :: forall s t. (Shape s, Shape t) => Maybe (s :~: t) +matchShapeType :: forall s t. (Sugar.Shape s, Sugar.Shape t) => Maybe (s :~: t) matchShapeType - | Just Refl <- matchTupleType (eltType @s) (eltType @t) + | Just Refl <- matchShapeR (Sugar.shapeR @s) (Sugar.shapeR @t) #ifdef ACCELERATE_INTERNAL_CHECKS = gcast Refl #else @@ -933,6 +844,13 @@ matchShapeType | otherwise = Nothing +{-# INLINEABLE matchShapeR #-} +matchShapeR :: forall s t. ShapeR s -> ShapeR t -> Maybe (s :~: t) +matchShapeR ShapeRz ShapeRz = Just Refl +matchShapeR (ShapeRcons shr1) (ShapeRcons shr2) + | Just Refl <- matchShapeR shr1 shr2 = Just Refl +matchShapeR _ _ = Nothing + -- Match reified type dictionaries -- @@ -1007,8 +925,8 @@ matchNonNumType _ _ = Nothing -- commutativity. -- commutes - :: forall acc env aenv a r. - EncodeAcc acc + :: forall acc env aenv a r. HasArraysRepr acc + => EncodeAcc acc -> PrimFun (a -> r) -> PreOpenExp acc env aenv a -> Maybe (PreOpenExp acc env aenv a) @@ -1028,8 +946,8 @@ commutes h f x = case f of 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) + | (a `Pair` b) <- exp + , hashPreOpenExp h a > hashPreOpenExp h b = b `Pair` a -- | otherwise = exp diff --git a/src/Data/Array/Accelerate/Analysis/Shape.hs b/src/Data/Array/Accelerate/Analysis/Shape.hs index 14f7c549d..188da0b8b 100644 --- a/src/Data/Array/Accelerate/Analysis/Shape.hs +++ b/src/Data/Array/Accelerate/Analysis/Shape.hs @@ -24,24 +24,22 @@ module Data.Array.Accelerate.Analysis.Shape ( import Data.Array.Accelerate.AST import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Representation -- |Reify the dimensionality of the result type of an array computation -- accDim :: forall acc aenv sh e. HasArraysRepr acc => acc aenv (Array sh e) -> Int -accDim acc = case arraysRepr acc of - ArraysRarray -> rank @sh +accDim = rank . arrayRshape . arrayRepr -- |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 @sh) - +expDim :: forall acc env aenv sh. HasArraysRepr acc => PreOpenExp acc env aenv sh -> Int +expDim = ndim . expType -- 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 +ndim :: TupR s a -> Int +ndim TupRunit = 0 +ndim TupRsingle{} = 1 +ndim (TupRpair a b) = ndim a + ndim b diff --git a/src/Data/Array/Accelerate/Analysis/Stencil.hs b/src/Data/Array/Accelerate/Analysis/Stencil.hs index 283f7b2c1..5de30afab 100644 --- a/src/Data/Array/Accelerate/Analysis/Stencil.hs +++ b/src/Data/Array/Accelerate/Analysis/Stencil.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -12,10 +13,10 @@ -- Portability : non-portable (GHC extensions) -- -module Data.Array.Accelerate.Analysis.Stencil (offsets, offsets2) where +module Data.Array.Accelerate.Analysis.Stencil (positionsR) where import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Representation -- |Calculate the offset coordinates for each stencil element relative to the @@ -23,68 +24,58 @@ import Data.Array.Accelerate.Array.Sugar -- 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 StencilRunit3{} = map ((), ) [ -1, 0, 1 ] +positionsR StencilRunit5{} = map ((), ) [ -2,-1, 0, 1, 2 ] +positionsR StencilRunit7{} = map ((), ) [ -3,-2,-1, 0, 1, 2, 3 ] +positionsR StencilRunit9{} = map ((), ) [-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 ] + [ map (innermost shr (, -1)) $ positionsR c + , map (innermost shr (, 0)) $ positionsR b + , map (innermost shr (, 1)) $ positionsR a ] + where + shr = stencilShape 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 ] + [ map (innermost shr (, -2)) $ positionsR e + , map (innermost shr (, -1)) $ positionsR d + , map (innermost shr (, 0)) $ positionsR c + , map (innermost shr (, 1)) $ positionsR b + , map (innermost shr (, 2)) $ positionsR a ] + where + shr = stencilShape 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 ] + [ map (innermost shr (, -3)) $ positionsR g + , map (innermost shr (, -2)) $ positionsR f + , map (innermost shr (, -1)) $ positionsR e + , map (innermost shr (, 0)) $ positionsR d + , map (innermost shr (, 1)) $ positionsR c + , map (innermost shr (, 2)) $ positionsR b + , map (innermost shr (, 3)) $ positionsR a ] + where + shr = stencilShape 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 ] + [ map (innermost shr (, -4)) $ positionsR i + , map (innermost shr (, -3)) $ positionsR h + , map (innermost shr (, -2)) $ positionsR g + , map (innermost shr (, -1)) $ positionsR f + , map (innermost shr (, 0)) $ positionsR e + , map (innermost shr (, 1)) $ positionsR d + , map (innermost shr (, 2)) $ positionsR c + , map (innermost shr (, 3)) $ positionsR b + , map (innermost shr (, 4)) $ positionsR a ] + where + shr = stencilShape a -- Inject a dimension component inner-most -- -innermost :: Shape sh => (sh -> sh :. Int) -> sh -> sh :. Int -innermost f = invertShape . f . invertShape +innermost :: ShapeR sh -> (sh -> (sh, Int)) -> sh -> (sh, Int) +innermost shr f = invertShape (ShapeRcons shr) . f . invertShape shr -invertShape :: Shape sh => sh -> sh -invertShape = listToShape . reverse . shapeToList +invertShape :: ShapeR sh -> sh -> sh +invertShape shr = listToShape shr . reverse . shapeToList shr diff --git a/src/Data/Array/Accelerate/Analysis/Type.hs b/src/Data/Array/Accelerate/Analysis/Type.hs index 4fb6cd509..677dc71dc 100644 --- a/src/Data/Array/Accelerate/Analysis/Type.hs +++ b/src/Data/Array/Accelerate/Analysis/Type.hs @@ -24,8 +24,7 @@ module Data.Array.Accelerate.Analysis.Type ( - arrayType, - accType, expType, + accType, sizeOf, sizeOfScalarType, @@ -38,73 +37,26 @@ module Data.Array.Accelerate.Analysis.Type ( -- friends import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Representation 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. Elt e => Array sh e -> TupleType (EltRepr e) -arrayType _ = eltType @e - - -- |Determine the type of an expressions -- ------------------------------------- -accType :: forall acc aenv sh e. HasArraysRepr acc => acc aenv (Array sh e) -> TupleType (EltRepr e) -accType acc = case arraysRepr acc of - ArraysRarray -> eltType @e - --- |Reify the result types of of a scalar expression using the expression AST before tying the --- knot. --- -expType :: forall acc aenv env t. - HasArraysRepr acc - => PreOpenExp acc aenv env t - -> TupleType (EltRepr t) -expType e = - case e of - Let _ _ -> eltType @t - Var _ -> eltType @t - Const _ -> eltType @t - Undef -> eltType @t - Tuple _ -> eltType @t - Prj _ _ -> eltType @t - IndexNil -> eltType @t - IndexCons _ _ -> eltType @t - IndexHead _ -> eltType @t - IndexTail _ -> eltType @t - IndexAny -> eltType @t - IndexSlice _ _ _ -> eltType @t - IndexFull _ _ _ -> eltType @t - ToIndex _ _ -> eltType @t - FromIndex _ _ -> eltType @t - Cond _ t _ -> expType t - While _ _ _ -> eltType @t - PrimConst _ -> eltType @t - PrimApp _ _ -> eltType @t - Index acc _ -> accType acc - LinearIndex acc _ -> accType acc - Shape _ -> eltType @t - ShapeSize _ -> eltType @t - Intersect _ _ -> eltType @t - Union _ _ -> eltType @t - Foreign _ _ _ -> eltType @t - Coerce _ -> eltType @t +accType :: forall acc aenv sh e. HasArraysRepr acc => acc aenv (Array sh e) -> TupleType e +accType = arrayRtype . arrayRepr -- |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 +sizeOf TupRunit = 0 +sizeOf (TupRpair a b) = sizeOf a + sizeOf b +sizeOf (TupRsingle t) = sizeOfScalarType t sizeOfScalarType :: ScalarType t -> Int sizeOfScalarType (SingleScalarType t) = sizeOfSingleType t diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index a7936c225..fe5f393ab 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -32,7 +32,7 @@ module Data.Array.Accelerate.Array.Data ( -- * Array operations and representations - ArrayData, MutableArrayData, runArrayData, GArrayData, rnfArrayData, ScalarData, + ArrayData, MutableArrayData, runArrayData, GArrayData, rnfArrayData, ScalarData, ScalarDataRepr, unsafeIndexArrayData, ptrOfArrayData, touchArrayData, newArrayData, unsafeReadArrayData, unsafeWriteArrayData, -- * Type macros @@ -41,6 +41,9 @@ module Data.Array.Accelerate.Array.Data ( -- * Allocator internals registerForeignPtrAllocator, + -- * Utilities for type classes + ScalarDict(..), scalarDict, singleDict + ) where -- friends @@ -60,6 +63,7 @@ import Control.DeepSeq import Data.Bits import Data.IORef import Data.Primitive ( sizeOf# ) +import Data.Typeable ( Typeable ) import Foreign.ForeignPtr import Foreign.Storable import Language.Haskell.TH hiding ( Type ) @@ -150,7 +154,7 @@ type family ScalarDataRepr tp where -- Utilities for working with the type families & type class instances data ScalarDict e where - ScalarDict :: (Storable (ScalarDataRepr e), Prim (ScalarDataRepr e), ArrayData e ~ ScalarData e) => ScalarDict e + ScalarDict :: (Typeable e, Typeable (ScalarDataRepr e), Storable (ScalarDataRepr e), Prim (ScalarDataRepr e), ArrayData e ~ ScalarData e) => ScalarDict e {-# INLINE scalarDict #-} scalarDict :: ScalarType e -> (Int, ScalarDict e) diff --git a/src/Data/Array/Accelerate/Array/Remote/Class.hs b/src/Data/Array/Accelerate/Array/Remote/Class.hs index 86b93b6a2..c8af43cef 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Class.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Class.hs @@ -27,27 +27,21 @@ module Data.Array.Accelerate.Array.Remote.Class ( - RemoteMemory(..), PrimElt + RemoteMemory(..) ) where import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Type (ScalarType) import Control.Applicative import Control.Monad.Catch import Data.Int import Data.Kind -import Data.Typeable import Data.Word -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. @@ -62,10 +56,10 @@ class (Applicative m, Monad m, MonadCatch m, MonadMask m) => RemoteMemory m wher 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 () + pokeRemote :: ScalarType e -> Int -> RemotePtr m (ScalarDataRepr e) -> 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 () + peekRemote :: ScalarType e -> Int -> RemotePtr m (ScalarDataRepr e) -> MutableArrayData e -> m () -- | Cast a remote pointer. castRemotePtr :: RemotePtr m a -> RemotePtr m b diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs index 5f414c344..aedea5c1e 100644 --- a/src/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/src/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -43,18 +43,21 @@ import Control.Monad.IO.Class ( MonadIO, liftI import Data.Functor import Data.Int ( Int64 ) import Data.Maybe ( isNothing ) -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.Type +import Data.Array.Accelerate.Analysis.Type ( sizeOfScalarType ) +import Data.Array.Accelerate.Analysis.Match ( matchScalarType, (:~:)(..) ) +import Data.Array.Accelerate.Array.Data ( ArrayData, ScalarData, ScalarDataRepr, ScalarDict(..), scalarDict ) 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 +import Data.Array.Accelerate.Array.Unique ( touchUniqueArray ) -- We build cached memory tables on top of a basic memory table. @@ -80,13 +83,14 @@ data Status = Clean -- Array in remote memory matches array in host memory. type Timestamp = Integer data Used task where - Used :: PrimElt e a + Used :: ArrayData e ~ ScalarData e => !Timestamp -> !Status -> {-# UNPACK #-} !Int -- Use count -> ![task] -- Asynchronous tasks using the array - -> {-# UNPACK #-} !Int -- Array size - -> {-# UNPACK #-} !(Weak (ArrayData e)) + -> {-# UNPACK #-} !Int -- Number of elements + -> !(ScalarType e) + -> {-# UNPACK #-} !(Weak (ScalarData e)) -> Used task -- | A Task represents a process executing asynchronously that can be polled for @@ -129,55 +133,59 @@ new release = do -- more accesses of the remote pointer. -- withRemote - :: forall task m a b c. (PrimElt a b, Task task, RemoteMemory m, MonadIO m, Functor m) + :: forall task m a c. (Task task, RemoteMemory m, MonadIO m, Functor m) => MemoryTable (RemotePtr m) task + -> ScalarType a -> ArrayData a - -> (RemotePtr m b -> m (task, c)) + -> (RemotePtr m (ScalarDataRepr a) -> 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) +withRemote (MemoryTable !mt !ref _) !tp !arr run + | (_, ScalarDict) <- scalarDict tp = do + key <- Basic.makeStableArray tp 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 @m mt tp 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 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 + 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 + updateTask (Used _ status count tasks n tp' weak_arr) task = do ts <- getCPUTime tasks' <- cleanUses tasks - return (Used ts status (count - 1) (task : tasks') n weak_arr) + return (Used ts status (count - 1) (task : tasks') n tp' 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 + copyBack :: UT task -> Used task -> m (RemotePtr m (ScalarDataRepr a)) + copyBack utbl (Used ts _ count tasks n tp' weak_arr) + | Just Refl <- matchScalarType tp tp' = do + message "withRemote/reuploading-evicted-array" + p <- mallocWithUsage mt utbl tp arr (Used ts Clean count tasks n tp weak_arr) + pokeRemote tp n p arr + return p + | otherwise = $internalError "withRemote" "Type mismatch" -- 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 :: ArrayData a ~ ScalarData a => StableArray -> RemotePtr m (ScalarDataRepr a) -> m c go key ptr = do message ("withRemote/using: " ++ show key) (task, c) <- run ptr @@ -188,7 +196,7 @@ withRemote (MemoryTable !mt !ref _) !arr run = do u' <- updateTask u task return (Just u', ()) -- - touchArrayData arr + touchUniqueArray arr return c @@ -207,15 +215,18 @@ withRemote (MemoryTable !mt !ref _) !arr run = do -- 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) +malloc :: forall e m task. (RemoteMemory m, MonadIO m, Task task) => MemoryTable (RemotePtr m) task + -> ScalarType e -> ArrayData e -> Bool -- ^ True if host array is frozen. - -> Int + -> Int -- ^ Number of elements -> m Bool -- ^ Was the array allocated successfully? -malloc (MemoryTable mt ref weak_utbl) !ad !frozen !n = do +malloc (MemoryTable mt ref weak_utbl) !tp !ad !frozen !n + | (_, ScalarDict) <- scalarDict tp -- Required for ArrayData e ~ ScalarData e + = do ts <- liftIO $ getCPUTime - key <- Basic.makeStableArray ad + key <- Basic.makeStableArray tp ad -- let status = if frozen then Clean @@ -225,30 +236,32 @@ malloc (MemoryTable mt ref weak_utbl) !ad !frozen !n = 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) + weak_arr <- liftIO $ makeWeakArrayData tp ad ad (Just $ finalizer key weak_utbl) + _ <- mallocWithUsage mt utbl tp ad (Used ts status 0 [] n tp weak_arr) return True else return False mallocWithUsage - :: forall a e m task. (PrimElt e a, RemoteMemory m, MonadIO m, Task task) + :: forall e m task. (RemoteMemory m, MonadIO m, Task task, ArrayData e ~ ScalarData e) => Basic.MemoryTable (RemotePtr m) -> UT task + -> ScalarType e -> ArrayData e -> Used task - -> m (RemotePtr m a) -mallocWithUsage !mt !utbl !ad !usage@(Used _ _ _ _ n _) = malloc' + -> m (RemotePtr m (ScalarDataRepr e)) +mallocWithUsage !mt !utbl !tp !ad !usage@(Used _ _ _ _ n _ _) = malloc' where + malloc' :: m (RemotePtr m (ScalarDataRepr e)) malloc' = do - mp <- Basic.malloc mt ad n :: m (Maybe (RemotePtr m a)) + mp <- Basic.malloc @e @m mt tp ad n :: m (Maybe (RemotePtr m (ScalarDataRepr e))) 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 + key <- Basic.makeStableArray tp ad HT.insert utbl key usage return p @@ -260,7 +273,7 @@ evictLRU 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 + Just (sa, Used ts status count tasks n tp weak_arr) -> do mad <- liftIO $ deRefWeak weak_arr case mad of Nothing -> liftIO $ do @@ -277,28 +290,28 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do Just arr -> do message ("evictLRU/evicting " ++ show sa) - copyIfNecessary status n arr - liftIO $ D.didEvictBytes (remoteBytes n weak_arr) + copyIfNecessary status n tp arr + liftIO $ D.didEvictBytes (remoteBytes tp n) liftIO $ Basic.freeStable @m mt sa - liftIO $ HT.insert utbl sa (Used ts Evicted count tasks n weak_arr) + liftIO $ HT.insert utbl sa (Used ts Evicted count tasks n tp 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 + eldest prev (sa, used@(Used ts status count tasks n tp weak_arr)) | count == 0 , evictable status = do tasks' <- cleanUses tasks - HT.insert utbl sa (Used ts status count tasks' n weak_arr) + HT.insert utbl sa (Used ts status count tasks' n tp weak_arr) case tasks' of - [] | Just (_, Used ts' _ _ _ _ _) <- prev + [] | 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)) + remoteBytes :: ScalarType e -> Int -> Int64 + remoteBytes tp n = fromIntegral (sizeOfScalarType tp) * fromIntegral n evictable :: Status -> Bool evictable Clean = True @@ -306,28 +319,29 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do 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 + copyIfNecessary :: Status -> Int -> ScalarType e -> ArrayData e -> m () + copyIfNecessary Clean _ _ _ = return () + copyIfNecessary Unmanaged _ _ _ = return () + copyIfNecessary Evicted _ _ _ = $internalError "evictLRU" "Attempting to evict already evicted array" + copyIfNecessary Dirty n tp ad = do + mp <- liftIO $ Basic.lookup @m mt tp ad case mp of Nothing -> return () -- RCE: I think this branch is actually impossible. - Just p -> peekRemote n p ad + Just p -> peekRemote tp 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 :: forall m a b task. (RemoteMemory m, PrimElt a b) +free :: forall m a task. (RemoteMemory m) => MemoryTable (RemotePtr m) task + -> ScalarType a -> ArrayData a -> IO () -free (MemoryTable !mt !ref _) !arr +free (MemoryTable !mt !ref _) !tp !arr = withMVar' ref $ \utbl -> do - key <- Basic.makeStableArray arr + key <- Basic.makeStableArray tp arr delete utbl key Basic.freeStable @m mt key @@ -338,20 +352,22 @@ free (MemoryTable !mt !ref _) !arr -- This typically only has use for backends that provide an FFI. -- insertUnmanaged - :: (PrimElt e a, MonadIO m) - => MemoryTable p task + :: (MonadIO m, RemoteMemory m) + => MemoryTable (RemotePtr m) task + -> ScalarType e -> ArrayData e - -> p a + -> RemotePtr m (ScalarDataRepr e) -> m () -insertUnmanaged (MemoryTable mt ref weak_utbl) !arr !ptr - = liftIO - . withMVar ref - $ \utbl -> do - key <- Basic.makeStableArray arr - () <- Basic.insertUnmanaged mt arr ptr +insertUnmanaged (MemoryTable mt ref weak_utbl) !tp !arr !ptr + | (_, ScalarDict) <- scalarDict tp = do -- Gives evidence that ArrayData e ~ ScalarData e + key <- Basic.makeStableArray tp arr + () <- Basic.insertUnmanaged mt tp arr ptr + liftIO + $ withMVar ref + $ \utbl -> do ts <- getCPUTime - weak_arr <- makeWeakArrayData arr arr (Just $ finalizer key weak_utbl) - HT.insert utbl key (Used ts Unmanaged 0 [] 0 weak_arr) + weak_arr <- makeWeakArrayData tp arr arr (Just $ finalizer key weak_utbl) + HT.insert utbl key (Used ts Unmanaged 0 [] 0 tp weak_arr) -- Removing entries @@ -383,7 +399,7 @@ cache_finalizer !tbl $ HT.mapM_ (\(_,u) -> f u) tbl where f :: Used task -> IO () - f (Used _ _ _ _ _ w) = finalize w + f (Used _ _ _ _ _ _ w) = finalize w -- Miscellaneous -- ------------- @@ -392,10 +408,10 @@ 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 +incCount (Used ts status count uses n tp weak_arr) = Used ts status (count + 1) uses n tp weak_arr isEvicted :: Used task -> Bool -isEvicted (Used _ status _ _ _ _) = status == Evicted +isEvicted (Used _ status _ _ _ _ _) = status == Evicted {-# INLINE withMVar' #-} withMVar' :: (MonadIO m, MonadMask m) => MVar a -> (a -> m b) -> m b diff --git a/src/Data/Array/Accelerate/Array/Remote/Table.hs b/src/Data/Array/Accelerate/Array/Remote/Table.hs index cf469cb3d..c90b4c751 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Table.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Table.hs @@ -10,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} @@ -35,7 +36,8 @@ module Data.Array.Accelerate.Array.Remote.Table ( -- Internals StableArray, makeStableArray, - makeWeakArrayData + makeWeakArrayData, + -- AsSingleType(..), toSingleType ) where @@ -46,7 +48,6 @@ import Control.Monad.IO.Class ( MonadIO, liftI import Data.Functor import Data.Hashable ( hash, Hashable ) import Data.Maybe ( isJust ) -import Data.Typeable ( Typeable, gcast, typeOf ) import Data.Word import Foreign.Storable ( sizeOf ) import System.Mem ( performGC ) @@ -55,12 +56,10 @@ import Text.Printf 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.Type import Data.Array.Accelerate.Array.Unique ( UniqueArray(..) ) -import Data.Array.Accelerate.Array.Data ( ArrayData, GArrayData(..), - ArrayPtrs, ArrayElt, arrayElt, ArrayEltR(..) ) +import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Array.Remote.Class import Data.Array.Accelerate.Array.Remote.Nursery ( Nursery(..) ) import Data.Array.Accelerate.Lifetime @@ -89,8 +88,7 @@ data MemoryTable p = MemoryTable {-# UNPACK #-} !(MT p) (p Word8 -> IO ()) data RemoteArray p where - RemoteArray :: Typeable e - => !(p e) -- The actual remote pointer + RemoteArray :: !(p Word8) -- The actual remote pointer -> {-# UNPACK #-} !Int -- The array size in bytes -> {-# UNPACK #-} !(Weak ()) -- Keep track of host array liveness -> RemoteArray p @@ -122,36 +120,37 @@ new release = do -- | Look for the remote pointer corresponding to a given host-side array. -- -lookup :: PrimElt a b - => MemoryTable p +lookup :: forall m a. + RemoteMemory m + => MemoryTable (RemotePtr m) + -> ScalarType a -> 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 p _ w) -> 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 - + -> IO (Maybe (RemotePtr m (ScalarDataRepr a))) +lookup (MemoryTable !ref _ _ _) !tp !arr + | (_, ScalarDict) <- scalarDict tp = do + sa <- makeStableArray tp arr + mw <- withMVar ref (`HT.lookup` sa) + case mw of + Nothing -> trace ("lookup/not found: " ++ show sa) $ return Nothing + Just (RemoteArray p _ w) -> do + mv <- deRefWeak w + case mv of + Just{} -> trace ("lookup/found: " ++ show sa) $ return (Just $ castRemotePtr @m p) + + -- 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 tp 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. @@ -159,45 +158,46 @@ lookup (MemoryTable !ref _ _ _) !arr = do -- 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) +malloc :: forall a m. (RemoteMemory m, MonadIO m) => MemoryTable (RemotePtr m) + -> ScalarType a -> 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)) `quot` f - bytes = chunk * multiple (n * sizeOf (undefined::b)) chunk - -- - message $ printf "malloc %d bytes (%d x %d bytes, type=%s, pagesize=%d)" bytes n (sizeOf (undefined::b)) (show (typeOf (undefined::a))) chunk - -- - mp <- - fmap (castRemotePtr @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 mp - + -> m (Maybe (RemotePtr m (ScalarDataRepr a))) +malloc mt@(MemoryTable _ _ !nursery _) !tp !ad !n + | (_, ScalarDict) <- scalarDict tp = 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)) `quot` f + bytes = chunk * multiple (n * sizeOf (undefined::(ScalarDataRepr a))) chunk + -- + message $ printf "malloc %d bytes (%d x %d bytes, type=%s, pagesize=%d)" bytes n (sizeOf (undefined:: (ScalarDataRepr a))) (show tp) chunk + -- + mp <- + fmap (castRemotePtr @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 tp ad p' bytes + return mp where {-# INLINE orElse #-} orElse :: m (Maybe x) -> m (Maybe x) -> m (Maybe x) @@ -220,12 +220,13 @@ malloc mt@(MemoryTable _ _ !nursery _) !ad !n = do -- | Deallocate the device array associated with the given host-side array. -- Typically this should only be called in very specific circumstances. -- -free :: forall m a b. (RemoteMemory m, PrimElt a b) +free :: forall m a. (RemoteMemory m) => MemoryTable (RemotePtr m) + -> ScalarType a -> ArrayData a -> IO () -free mt !arr = do - sa <- makeStableArray arr +free mt tp !arr = do + sa <- makeStableArray tp arr freeStable @m mt sa @@ -257,18 +258,20 @@ freeStable (MemoryTable !ref _ !nrs _) !sa = -- collected. -- insert - :: forall m a b. (PrimElt a b, RemoteMemory m, MonadIO m) + :: forall m a. (RemoteMemory m, MonadIO m) => MemoryTable (RemotePtr m) + -> ScalarType a -> ArrayData a - -> RemotePtr m b + -> RemotePtr m (ScalarDataRepr a) -> Int -> m () -insert mt@(MemoryTable !ref _ _ _) !arr !ptr !bytes = do - key <- makeStableArray arr - weak <- liftIO $ makeWeakArrayData arr () (Just $ freeStable @m mt key) +insert mt@(MemoryTable !ref _ _ _) !tp !arr !ptr !bytes + | (_, ScalarDict) <- scalarDict tp = do + key <- makeStableArray tp arr + weak <- liftIO $ makeWeakArrayData tp arr () (Just $ freeStable @m mt key) message $ "insert: " ++ show key liftIO $ D.increaseCurrentBytesRemote (fromIntegral bytes) - liftIO $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray ptr bytes weak) + liftIO $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray (castRemotePtr @m ptr) bytes weak) -- | Record an association between a host-side array and a remote memory area @@ -278,16 +281,18 @@ insert mt@(MemoryTable !ref _ _ _) !arr !ptr !bytes = do -- This typically only has use for backends that provide an FFI. -- insertUnmanaged - :: (PrimElt a b, MonadIO m) - => MemoryTable p + :: forall m a. (MonadIO m, RemoteMemory m) + => MemoryTable (RemotePtr m) + -> ScalarType a -> ArrayData a - -> p b + -> RemotePtr m (ScalarDataRepr a) -> 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 ptr 0 weak) +insertUnmanaged (MemoryTable !ref !weak_ref _ _) tp !arr !ptr + | (_, ScalarDict) <- scalarDict tp = do + key <- makeStableArray tp arr + weak <- liftIO $ makeWeakArrayData tp arr () (Just $ remoteFinalizer weak_ref key) + message $ "insertUnmanaged: " ++ show key + liftIO $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray (castRemotePtr @m ptr) 0 weak) -- Removing entries @@ -351,11 +356,13 @@ remoteFinalizer !weak_ref !key = do -- {-# INLINE makeStableArray #-} makeStableArray - :: (MonadIO m, Typeable a, Typeable e, ArrayPtrs a ~ Ptr e, ArrayElt a) - => ArrayData a + :: MonadIO m + => ScalarType a + -> ArrayData a -> m StableArray -makeStableArray !ad = return $! StableArray (id arrayElt ad) - where +makeStableArray !tp !ad + | (_, ScalarDict) <- scalarDict tp = return $! StableArray (uniqueArrayId 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 @@ -377,6 +384,7 @@ makeStableArray !ad = return $! StableArray (id arrayElt ad) id _ _ = error "I do have a cause, though. It is obscenity. I'm for it." #endif +-} -- Weak arrays @@ -386,12 +394,22 @@ makeStableArray !ad = return $! StableArray (id arrayElt ad) -- this guarantees finalisers won't fire early. -- makeWeakArrayData - :: forall a e c. (ArrayElt e, ArrayPtrs e ~ Ptr a) - => ArrayData e + :: forall e c. + ScalarType e + -> ArrayData e -> c -> Maybe (IO ()) -> IO (Weak c) -makeWeakArrayData !ad !c !mf = mw arrayElt ad +makeWeakArrayData !tp !ad !c !mf + | (_, ScalarDict) <- scalarDict tp = do + let !uad = uniqueArrayData ad + case mf of + Nothing -> return () + Just f -> addFinalizer uad f + mkWeak uad c + {- + + mw arrayElt ad where mw :: (ArrayPtrs e' ~ Ptr a') => ArrayEltR e' -> ArrayData e' -> IO (Weak c) mw ArrayEltRint (AD_Int ua) = mkWeak' ua @@ -416,13 +434,8 @@ makeWeakArrayData !ad !c !mf = mw arrayElt ad #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 - + mkWeak' !ua = +-} -- Debug -- ----- @@ -462,4 +475,11 @@ management msg nrs next = do else next - +{- +data AsSingleType tp where + AsSingleType :: ScalarDataRepr tp ~ ScalarDataRepr tp' => SingleType tp' -> AsSingleType tp + +toSingleType :: ScalarType tp -> AsSingleType tp +toSingleType (SingleScalarType tp) = AsSingleType tp +toSingleType (VectorScalarType (VectorType _ tp)) = AsSingleType tp +-} diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index ac5386432..036f5a5ef 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -23,20 +23,26 @@ module Data.Array.Accelerate.Array.Representation ( -- * Array data type in terms of representation types - Array(..), ArrayR(..), arraysRarray, arraysRtuple2, - ArraysR, TupleType, Scalar, Vector, Matrix, fromList, toList, + Array(..), ArrayR(..), arraysRarray, arraysRtuple2, arrayRshape, arrayRtype, rnfArray, rnfShape, + ArraysR, TupleType, Scalar, Vector, Matrix, fromList, toList, Segments, shape, reshape, concatVectors, + showArrayR, showArraysR, -- * Array shapes, indices, and slices ShapeR(..), Slice(..), SliceIndex(..), - DIM0, DIM1, DIM2, + DIM0, DIM1, DIM2, (!), (!!), -- * Shape functions rank, size, empty, ignore, intersect, union, toIndex, fromIndex, iter, iter1, rangeToShape, shapeToRange, shapeToList, listToShape, listToShape', shapeType, -- * Slice shape functions - sliceShape, sliceShapeR, enumSlices, + sliceShape, sliceShapeR, sliceDomainR, enumSlices, + -- * Stencils + StencilR(..), stencilElt, stencilShape, stencilType, stencilArrayR, + + -- * Show + showShape, showElement, showArray, showArray', ) where -- friends @@ -46,6 +52,10 @@ import Data.Array.Accelerate.Array.Data -- standard library import GHC.Base ( quotInt, remInt ) +import Prelude hiding ((!!)) +import Data.List ( intercalate ) +import Text.Show ( showListWith ) +import qualified Data.Vector.Unboxed as U -- |Array data type, where the type arguments regard the representation types of the shape and elements. data Array sh e where @@ -53,6 +63,38 @@ data Array sh e where -> ArrayData e -- array payload -> Array sh e +{-# INLINE shape #-} +shape :: Array sh e -> sh +shape (Array sh _) = sh + +{-# INLINE reshape #-} +reshape :: ShapeR sh -> sh -> ShapeR sh' -> Array sh' e -> Array sh e +reshape shr sh shr' (Array sh' adata) + = $boundsCheck "reshape" "shape mismatch" (size shr sh == size shr' sh') + $ Array sh adata + +{-# INLINE [1] (!) #-} +(!) :: (ArrayR (Array sh e), Array sh e) -> sh -> e +(!) (ArrayR shr tp, Array sh adata) ix = unsafeIndexArrayData tp adata $ toIndex shr sh ix + +{-# INLINE [1] (!!) #-} +(!!) :: (TupleType e, Array sh e) -> Int -> e +(tp, Array _ adata) !! i = unsafeIndexArrayData tp adata i + +{-# INLINEABLE concatVectors #-} +concatVectors :: TupleType e -> [Vector e] -> Vector e +concatVectors tp vs = adata `seq` Array ((), len) adata + where + dim1 = ShapeRcons ShapeRz + offsets = scanl (+) 0 (map (size dim1 . shape) vs) + len = last offsets + (adata, _) = runArrayData $ do + arr <- newArrayData tp len + sequence_ [ unsafeWriteArrayData tp arr (i + k) (unsafeIndexArrayData tp ad i) + | (Array ((), n) ad, k) <- vs `zip` offsets + , i <- [0 .. n - 1] ] + return (arr, undefined) + {-# INLINEABLE fromList #-} fromList :: ArrayR (Array sh e) -> sh -> [e] -> Array sh e fromList (ArrayR shr tp) sh xs = adata `seq` Array sh adata @@ -88,16 +130,38 @@ type ArraysR = TupR ArrayR data ArrayR a where ArrayR :: ShapeR sh -> TupleType e -> ArrayR (Array sh e) +arrayRshape :: ArrayR (Array sh e) -> ShapeR sh +arrayRshape (ArrayR sh _) = sh + +arrayRtype :: ArrayR (Array sh e) -> TupleType e +arrayRtype (ArrayR _ tp) = tp + arraysRarray :: ShapeR sh -> TupleType e -> ArraysR (Array sh e) arraysRarray shr tp = TupRsingle $ ArrayR shr tp arraysRtuple2 :: ArrayR a -> ArrayR b -> ArraysR (((), a), b) arraysRtuple2 a b = TupRpair TupRunit (TupRsingle a) `TupRpair` TupRsingle b +showArrayR :: ArrayR a -> ShowS +showArrayR (ArrayR shr tp) = showString "Array DIM" . shows (rank shr) . showString " " . showType tp + +showArraysR :: ArraysR tp -> ShowS +showArraysR TupRunit = showString "()" +showArraysR (TupRsingle repr) = showArrayR repr +showArraysR (TupRpair t1 t2) = showString "(" . showArraysR t1 . showString ", " . showArraysR t2 . showString ")" + type Scalar = Array DIM0 type Vector = Array DIM1 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 + -- |Index representation -- type DIM0 = () @@ -270,6 +334,11 @@ sliceShapeR SliceNil = ShapeRz sliceShapeR (SliceAll sl) = ShapeRcons $ sliceShapeR sl sliceShapeR (SliceFixed sl) = sliceShapeR sl +sliceDomainR :: SliceIndex slix sl co dim -> ShapeR dim +sliceDomainR SliceNil = ShapeRz +sliceDomainR (SliceAll sl) = ShapeRcons $ sliceDomainR sl +sliceDomainR (SliceFixed sl) = ShapeRcons $ sliceDomainR sl + -- | Enumerate all slices within a given bound. The innermost dimension changes -- most rapidly. -- @@ -283,3 +352,186 @@ 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]] + +-- | GADT reifying the 'Stencil' class +-- +data StencilR sh e pat where + StencilRunit3 :: TupleType e -> StencilR DIM1 e (Tup3 e e e) + StencilRunit5 :: TupleType e -> StencilR DIM1 e (Tup5 e e e e e) + StencilRunit7 :: TupleType e -> StencilR DIM1 e (Tup7 e e e e e e e) + StencilRunit9 :: TupleType e -> StencilR DIM1 e (Tup9 e e e e e e e e e) + + StencilRtup3 :: StencilR sh e pat1 + -> StencilR sh e pat2 + -> StencilR sh e pat3 + -> StencilR (sh, Int) e (Tup3 pat1 pat2 pat3) + + StencilRtup5 :: StencilR sh e pat1 + -> StencilR sh e pat2 + -> StencilR sh e pat3 + -> StencilR sh e pat4 + -> StencilR sh e pat5 + -> StencilR (sh, Int) e (Tup5 pat1 pat2 pat3 pat4 pat5) + + StencilRtup7 :: 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 (Tup7 pat1 pat2 pat3 pat4 pat5 pat6 pat7) + + StencilRtup9 :: 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 (Tup9 pat1 pat2 pat3 pat4 pat5 pat6 pat7 pat8 pat9) + +stencilElt :: StencilR sh e pat -> TupleType e +stencilElt (StencilRunit3 tp) = tp +stencilElt (StencilRunit5 tp) = tp +stencilElt (StencilRunit7 tp) = tp +stencilElt (StencilRunit9 tp) = tp +stencilElt (StencilRtup3 sr _ _) = stencilElt sr +stencilElt (StencilRtup5 sr _ _ _ _) = stencilElt sr +stencilElt (StencilRtup7 sr _ _ _ _ _ _) = stencilElt sr +stencilElt (StencilRtup9 sr _ _ _ _ _ _ _ _) = stencilElt sr + +stencilShape :: StencilR sh e pat -> ShapeR sh +stencilShape (StencilRunit3 _) = ShapeRcons ShapeRz +stencilShape (StencilRunit5 _) = ShapeRcons ShapeRz +stencilShape (StencilRunit7 _) = ShapeRcons ShapeRz +stencilShape (StencilRunit9 _) = ShapeRcons ShapeRz +stencilShape (StencilRtup3 sr _ _) = ShapeRcons $ stencilShape sr +stencilShape (StencilRtup5 sr _ _ _ _) = ShapeRcons $ stencilShape sr +stencilShape (StencilRtup7 sr _ _ _ _ _ _) = ShapeRcons $ stencilShape sr +stencilShape (StencilRtup9 sr _ _ _ _ _ _ _ _) = ShapeRcons $ stencilShape sr + +stencilType :: StencilR sh e pat -> TupleType pat +stencilType (StencilRunit3 tp) = tupR3 tp tp tp +stencilType (StencilRunit5 tp) = tupR5 tp tp tp tp tp +stencilType (StencilRunit7 tp) = tupR7 tp tp tp tp tp tp tp +stencilType (StencilRunit9 tp) = tupR9 tp tp tp tp tp tp tp tp tp +stencilType (StencilRtup3 s1 s2 s3) = tupR3 (stencilType s1) (stencilType s2) (stencilType s3) +stencilType (StencilRtup5 s1 s2 s3 s4 s5) = tupR5 (stencilType s1) (stencilType s2) (stencilType s3) + (stencilType s4) (stencilType s5) +stencilType (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) = tupR7 (stencilType s1) (stencilType s2) (stencilType s3) + (stencilType s4) (stencilType s5) (stencilType s6) + (stencilType s7) +stencilType (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) = tupR9 (stencilType s1) (stencilType s2) (stencilType s3) + (stencilType s4) (stencilType s5) (stencilType s6) + (stencilType s7) (stencilType s8) (stencilType s9) + +stencilArrayR :: StencilR sh e pat -> ArrayR (Array sh e) +stencilArrayR stencil = ArrayR (stencilShape stencil) (stencilElt stencil) + +rnfArray :: ArrayR a -> a -> () +rnfArray (ArrayR shr tp) (Array sh ad) = rnfShape shr sh `seq` rnfArrayData tp ad + +rnfShape :: ShapeR sh -> sh -> () +rnfShape ShapeRz () = () +rnfShape (ShapeRcons shr) (sh, s) = s `seq` rnfShape shr sh + +-- | Nicely format a shape as a string +-- +showShape :: ShapeR sh -> sh -> String +showShape shr = foldr (\sh str -> str ++ " :. " ++ show sh) "Z" . shapeToList shr + +showElement :: TupleType e -> e -> String +showElement tuple value = showElement' tuple value "" + where + showElement' :: TupleType e -> e -> ShowS + showElement' TupRunit () = showString "()" + showElement' (TupRpair t1 t2) (e1, e2) = showString "(" . showElement' t1 e1 . showString ", " . showElement' t2 e2 . showString ")" + showElement' (TupRsingle tp) val = showScalar tp val + + showScalar :: ScalarType e -> e -> ShowS + showScalar (SingleScalarType t) e = showString $ showSingle t e + showScalar (VectorScalarType t) e = showString $ showVector t e + + showSingle :: SingleType e -> e -> String + showSingle (NumSingleType t) e = showNum t e + showSingle (NonNumSingleType t) e = showNonNum t e + + showNum :: NumType e -> e -> String + showNum (IntegralNumType t) e = showIntegral t e + showNum (FloatingNumType t) e = showFloating t e + + showIntegral :: IntegralType e -> e -> String + showIntegral TypeInt{} e = show e + showIntegral TypeInt8{} e = show e + showIntegral TypeInt16{} e = show e + showIntegral TypeInt32{} e = show e + showIntegral TypeInt64{} e = show e + showIntegral TypeWord{} e = show e + showIntegral TypeWord8{} e = show e + showIntegral TypeWord16{} e = show e + showIntegral TypeWord32{} e = show e + showIntegral TypeWord64{} e = show e + + showFloating :: FloatingType e -> e -> String + showFloating TypeHalf{} e = show e + showFloating TypeFloat{} e = show e + showFloating TypeDouble{} e = show e + + showNonNum :: NonNumType e -> e -> String + showNonNum TypeChar e = show e + showNonNum TypeBool e = show e + + showVector :: VectorType (Vec n a) -> Vec n a -> String + showVector (VectorType _ single) vec + | IsPrim <- getPrim single = "<" ++ (intercalate ", " $ showSingle single <$> vecToArray vec) ++ ">" + +showArray :: ArrayR (Array sh e) -> Array sh e -> String +showArray repr@(ArrayR _ tp) = showArray' (showString . showElement tp) repr + +{-# INLINE showArray' #-} +showArray' :: (e -> ShowS) -> ArrayR (Array sh e) -> Array sh e -> String +showArray' f repr@(ArrayR shr tp) arr@(Array sh _) = case shr of + ShapeRz -> "Scalar Z " ++ list + ShapeRcons ShapeRz -> "Vector (" ++ shapeString ++ ") " ++ list + ShapeRcons (ShapeRcons ShapeRz) -> "Matrix (" ++ shapeString ++ ") " ++ showMatrix f tp arr + _ -> "Array (" ++ shapeString ++ ") " ++ list + where + shapeString = showShape shr sh + list = showListWith f (toList repr arr) "" + +-- 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. +-- +showMatrix :: (e -> ShowS) -> TupleType e -> Array DIM2 e -> String +showMatrix f tp arr@(Array sh _) + | rows * cols == 0 = "[]" + | otherwise = "\n [" ++ ppMat 0 0 + where + (((), rows), cols) = sh + lengths = U.generate (rows*cols) (\i -> length (f ((tp, arr) !! i) "")) + widths = U.generate cols (\c -> U.maximum (U.generate rows (\r -> lengths U.! (r*cols+c)))) + -- + 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) ' ' ++ f ((tp, 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 diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 9443bc84d..89c808a67 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -36,15 +36,12 @@ module Data.Array.Accelerate.Array.Sugar ( TupR(..), -- * Array representation - Array(..), Scalar, Vector, Matrix, Segments, + Array(..), Scalar, Vector, Matrix, Segments, arrayR, Arrays(..), Repr.ArraysR, Repr.ArrayR(..), Repr.arraysRarray, Repr.arraysRtuple2, -- * Class of supported surface element types and their mapping to representation types Elt(..), TupleType, - -- * Stencils - Stencil(..), StencilR(..), - -- * Derived functions liftToElt, liftToElt2, sinkFromElt, sinkFromElt2, @@ -73,7 +70,6 @@ import Data.Typeable import System.IO.Unsafe ( unsafePerformIO ) import Language.Haskell.TH hiding ( Foreign, Type ) import Prelude hiding ( (!!) ) -import qualified Data.Vector.Unboxed as U import GHC.Exts ( IsList ) import GHC.Generics @@ -347,22 +343,26 @@ instance Elt All where fromElt All = () toElt () = All -instance Elt (Any Z) where - type EltRepr (Any Z) = () - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = TupRunit - fromElt _ = () - toElt _ = Any +type family AnyRepr sh +type instance AnyRepr () = () +type instance AnyRepr (sh, Int) = (AnyRepr sh, ()) + +instance Shape sh => Elt (Any sh) where + type EltRepr (Any sh) = AnyRepr (EltRepr sh) -instance Shape sh => Elt (Any (sh:.Int)) where - type EltRepr (Any (sh:.Int)) = (EltRepr (Any sh), ()) {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TupRpair (eltType @(Any sh)) TupRunit - fromElt _ = (fromElt (Any @sh), ()) + eltType = go $ shapeR @sh + where + go :: Repr.ShapeR sh' -> TupleType (AnyRepr sh') + go Repr.ShapeRz = TupRunit + go (Repr.ShapeRcons shr) = TupRpair (go shr) TupRunit + fromElt _ = go $ shapeR @sh + where + go :: Repr.ShapeR sh' -> AnyRepr sh' + go Repr.ShapeRz = () + go (Repr.ShapeRcons shr) = (go shr, ()) toElt _ = Any instance (Elt a, Elt b) => Elt (a, b) @@ -425,115 +425,6 @@ sinkFromElt2 f x y = fromElt $ f (toElt x) (toElt y) "toElt/fromElt" forall e. toElt (fromElt e) = 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 - - -- Foreign functions -- ----------------- @@ -682,8 +573,8 @@ instance (Shape sh, Elt e) => Arrays (Array sh e) where {-# INLINE [1] fromArr #-} {-# INLINE [1] toArr #-} arrays = Repr.arraysRarray (shapeR @sh) (eltType @e) - fromArr (Array sh arrayData) = Repr.Array sh arrayData - toArr (Repr.Array sh arrayData) = Array sh arrayData + fromArr (Array arr) = arr + toArr (arr) = Array arr instance (Arrays a, Arrays b) => Arrays (a, b) instance (Arrays a, Arrays b, Arrays c) => Arrays (a, b, c) @@ -755,10 +646,8 @@ instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, -- Section "Getting data in" lists functions for getting data into and out of -- the 'Array' type. -- -data Array sh e where - Array :: EltRepr sh -- extent of dimensions = shape - -> ArrayData (EltRepr e) -- array payload - -> Array sh e +newtype Array sh e = Array (Repr.Array (EltRepr sh) (EltRepr e)) + -- -- Note: [Embedded class constraints on Array] -- @@ -794,47 +683,7 @@ instance (Shape sh, Elt e, Eq sh, Eq e) => Eq (Array sh e) where -- matrices may not always be shown with their appropriate format. -- instance (Shape sh, Elt e) => Show (Array sh e) where - show arr = case shapeToList $ shape arr of - [] -> "Scalar Z " ++ show (toList arr) - [_] -> "Vector (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) - [cols, rows] -> showMatrix rows cols arr - _ -> "Array (" ++ showShape (shape arr) ++ ") " ++ show (toList arr) - --- 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. --- -showMatrix :: (Shape sh, Elt e) => Int -> Int -> Array sh e -> String -showMatrix rows cols arr = - "Matrix (" ++ showShape (shape arr) ++ ") " ++ showMat - where - 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 + show (Array arr) = Repr.showArray' (shows . toElt @e) (arrayR @sh @e) arr instance Elt e => IsList (Vector e) where type Item (Vector e) = e @@ -843,7 +692,7 @@ instance Elt e => IsList (Vector e) where fromList xs = GHC.fromListN (length xs) xs instance (Shape sh, Elt e) => NFData (Array sh e) where - rnf (Array sh ad) = Repr.size (shapeR @sh) sh `seq` rnfArrayData (eltType @e) ad + rnf (Array arr) = Repr.rnfArray (arrayR @sh @e) $ arr -- | Scalar arrays hold a single element -- @@ -1071,28 +920,26 @@ instance (Shape sh, Slice sh) => Division (Divide sh) where -- {-# INLINE shape #-} shape :: Shape sh => Array sh e -> sh -shape (Array sh _) = toElt sh +shape (Array arr) = toElt $ Repr.shape arr -- | Change the shape of an array without altering its contents. The 'size' of -- the source and result arrays must be identical. -- {-# INLINE reshape #-} reshape :: forall sh sh' e. (Shape sh, Shape sh') => sh -> Array sh' e -> Array sh e -reshape sh (Array sh' adata) - = $boundsCheck "reshape" "shape mismatch" (size sh == Repr.size (shapeR @sh') sh') - $ Array (fromElt sh) adata +reshape sh (Array arr) = Array $ Repr.reshape (shapeR @sh) (fromElt sh) (shapeR @sh') arr -- | Array indexing -- infixl 9 ! {-# INLINE [1] (!) #-} (!) :: forall sh e. (Shape sh, Elt e) => Array sh e -> sh -> e -(!) (Array sh adata) ix = toElt (unsafeIndexArrayData (eltType @e) adata $ toIndex (toElt sh) ix) +(!) (Array arr) ix = toElt $ (arrayR @sh @e, arr) Repr.! fromElt ix infixl 9 !! {-# INLINE [1] (!!) #-} (!!) :: forall sh e. Elt e => Array sh e -> Int -> e -(!!) (Array _ adata) i = toElt (unsafeIndexArrayData (eltType @e) adata i) +(!!) (Array arr) i = toElt $ (eltType @e, arr) Repr.!! i {-# RULES "indexArray/DIM0" forall arr. arr ! Z = arr !! 0 @@ -1124,23 +971,14 @@ fromFunctionM sh f = do write (i+1) -- write 0 - return $! arr `seq` Array (fromElt sh) arr + return $! arr `seq` Array $ Repr.Array (fromElt sh) arr -- | Create a vector from the concatenation of the given list of vectors. -- {-# INLINEABLE concatVectors #-} concatVectors :: forall e. 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 (eltType @e) len - sequence_ [ unsafeWriteArrayData (eltType @e) arr (i + k) (unsafeIndexArrayData (eltType @e) ad i) - | (Array ((), n) ad, k) <- vs `zip` offsets - , i <- [0 .. n - 1] ] - return (arr, undefined) +concatVectors = toArr . Repr.concatVectors (eltType @e) . map fromArr -- | Creates a new, uninitialized Accelerate array. -- @@ -1148,7 +986,7 @@ concatVectors vs = adata `seq` Array ((), len) adata allocateArray :: forall sh e. (Shape sh, Elt e) => sh -> IO (Array sh e) allocateArray sh = do adata <- newArrayData (eltType @e) (size sh) - return $! Array (fromElt sh) adata + return $! Array $ Repr.Array (fromElt sh) adata -- | Convert elements of a list into an Accelerate 'Array'. diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 276f77f28..09c21d262 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -113,36 +113,36 @@ instance Eq Word64 where (/=) = mkNEq instance Eq CInt where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CUInt where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CLong where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CULong where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CLLong where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CULLong where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CShort where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CUShort where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq Bool where (==) = mkEq @@ -153,16 +153,16 @@ instance Eq Char where (/=) = mkNEq instance Eq CChar where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CUChar where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CSChar where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq Half where (==) = mkEq @@ -177,12 +177,12 @@ instance Eq Double where (/=) = mkNEq instance Eq CFloat where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq CDouble where - (==) = lift2 mkEq - (/=) = lift2 mkNEq + (==) = mkEq + (/=) = mkNEq instance Eq Z where (==) _ _ = constant True @@ -323,11 +323,3 @@ instance P.Eq (Exp a) where preludeError :: String -> String -> a preludeError x y = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x y) - -lift2 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b -> Exp Bool) - -> Exp a - -> Exp a - -> Exp Bool -lift2 f x y = f (mkUnsafeCoerce x) (mkUnsafeCoerce y) - diff --git a/src/Data/Array/Accelerate/Classes/Floating.hs b/src/Data/Array/Accelerate/Classes/Floating.hs index 344d3758b..5b451ffb6 100644 --- a/src/Data/Array/Accelerate/Classes/Floating.hs +++ b/src/Data/Array/Accelerate/Classes/Floating.hs @@ -30,7 +30,6 @@ module Data.Array.Accelerate.Classes.Floating ( ) where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -106,54 +105,40 @@ instance P.Floating (Exp Double) where instance P.Floating (Exp CFloat) where pi = mkBitcast (mkPi @Float) - sin = lift1 mkSin - cos = lift1 mkCos - tan = lift1 mkTan - asin = lift1 mkAsin - acos = lift1 mkAcos - atan = lift1 mkAtan - sinh = lift1 mkSinh - cosh = lift1 mkCosh - tanh = lift1 mkTanh - asinh = lift1 mkAsinh - acosh = lift1 mkAcosh - atanh = lift1 mkAtanh - exp = lift1 mkExpFloating - sqrt = lift1 mkSqrt - log = lift1 mkLog - (**) = lift2 mkFPow - logBase = lift2 mkLogBase + 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 = mkBitcast (mkPi @Double) - sin = lift1 mkSin - cos = lift1 mkCos - tan = lift1 mkTan - asin = lift1 mkAsin - acos = lift1 mkAcos - atan = lift1 mkAtan - sinh = lift1 mkSinh - cosh = lift1 mkCosh - tanh = lift1 mkTanh - asinh = lift1 mkAsinh - acosh = lift1 mkAcosh - atanh = lift1 mkAtanh - exp = lift1 mkExpFloating - sqrt = lift1 mkSqrt - log = lift1 mkLog - (**) = lift2 mkFPow - logBase = lift2 mkLogBase - -lift1 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b) - -> Exp a - -> Exp a -lift1 f x = mkUnsafeCoerce (f (mkUnsafeCoerce x)) - -lift2 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b -> Exp b) - -> Exp a - -> Exp a - -> Exp a -lift2 f x y = mkUnsafeCoerce (f (mkUnsafeCoerce x) (mkUnsafeCoerce y)) - + 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 diff --git a/src/Data/Array/Accelerate/Classes/Fractional.hs b/src/Data/Array/Accelerate/Classes/Fractional.hs index cd081b767..e4502e8a1 100644 --- a/src/Data/Array/Accelerate/Classes/Fractional.hs +++ b/src/Data/Array/Accelerate/Classes/Fractional.hs @@ -20,7 +20,6 @@ module Data.Array.Accelerate.Classes.Fractional ( ) where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -62,25 +61,11 @@ instance P.Fractional (Exp Double) where fromRational = constant . P.fromRational instance P.Fractional (Exp CFloat) where - (/) = lift2 mkFDiv - recip = lift1 mkRecip + (/) = mkFDiv + recip = mkRecip fromRational = constant . P.fromRational instance P.Fractional (Exp CDouble) where - (/) = lift2 mkFDiv - recip = lift1 mkRecip + (/) = mkFDiv + recip = mkRecip fromRational = constant . P.fromRational - -lift1 :: (Elt a, Elt b, b ~ EltRepr a) - => (Exp b -> Exp b) - -> Exp a - -> Exp a -lift1 f = mkUnsafeCoerce . f . mkUnsafeCoerce - -lift2 :: (Elt a, Elt b, b ~ EltRepr a) - => (Exp b -> Exp b -> Exp b) - -> Exp a - -> Exp a - -> Exp a -lift2 f x y = mkUnsafeCoerce (f (mkUnsafeCoerce x) (mkUnsafeCoerce y)) - diff --git a/src/Data/Array/Accelerate/Classes/Integral.hs b/src/Data/Array/Accelerate/Classes/Integral.hs index e03751a66..4d6f9e96c 100644 --- a/src/Data/Array/Accelerate/Classes/Integral.hs +++ b/src/Data/Array/Accelerate/Classes/Integral.hs @@ -26,7 +26,6 @@ module Data.Array.Accelerate.Classes.Integral ( ) where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -135,90 +134,73 @@ instance P.Integral (Exp Word64) where toInteger = error "Prelude.toInteger not supported for Accelerate types" instance P.Integral (Exp CInt) where - quot = lift2 mkQuot - rem = lift2 mkRem - div = lift2 mkIDiv - mod = lift2 mkMod - quotRem = lift2' mkQuotRem - divMod = lift2' mkDivMod + 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 = lift2 mkQuot - rem = lift2 mkRem - div = lift2 mkIDiv - mod = lift2 mkMod - quotRem = lift2' mkQuotRem - divMod = lift2' mkDivMod + 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 = lift2 mkQuot - rem = lift2 mkRem - div = lift2 mkIDiv - mod = lift2 mkMod - quotRem = lift2' mkQuotRem - divMod = lift2' mkDivMod + 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 = lift2 mkQuot - rem = lift2 mkRem - div = lift2 mkIDiv - mod = lift2 mkMod - quotRem = lift2' mkQuotRem - divMod = lift2' mkDivMod + 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 = lift2 mkQuot - rem = lift2 mkRem - div = lift2 mkIDiv - mod = lift2 mkMod - quotRem = lift2' mkQuotRem - divMod = lift2' mkDivMod + 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 = lift2 mkQuot - rem = lift2 mkRem - div = lift2 mkIDiv - mod = lift2 mkMod - quotRem = lift2' mkQuotRem - divMod = lift2' mkDivMod + 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 = lift2 mkQuot - rem = lift2 mkRem - div = lift2 mkIDiv - mod = lift2 mkMod - quotRem = lift2' mkQuotRem - divMod = lift2' mkDivMod + 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 = lift2 mkQuot - rem = lift2 mkRem - div = lift2 mkIDiv - mod = lift2 mkMod - quotRem = lift2' mkQuotRem - divMod = lift2' mkDivMod - toInteger = error "Prelude.toInteger not supported for Accelerate types" - -lift2 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b -> Exp b) - -> Exp a - -> Exp a - -> Exp a -lift2 f x y = mkUnsafeCoerce (f (mkUnsafeCoerce x) (mkUnsafeCoerce y)) - -lift2' :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b -> (Exp b, Exp b)) - -> Exp a - -> Exp a - -> (Exp a, Exp a) -lift2' f x y = - let (u,v) = f (mkUnsafeCoerce x) (mkUnsafeCoerce y) - in (mkUnsafeCoerce u, mkUnsafeCoerce v) - + quot = mkQuot + rem = mkRem + div = mkIDiv + mod = mkMod + quotRem = mkQuotRem + divMod = mkDivMod + toInteger = error "Prelude.toInteger not supported for Accelerate types" diff --git a/src/Data/Array/Accelerate/Classes/Num.hs b/src/Data/Array/Accelerate/Classes/Num.hs index 15203639a..5f4cc6dd8 100644 --- a/src/Data/Array/Accelerate/Classes/Num.hs +++ b/src/Data/Array/Accelerate/Classes/Num.hs @@ -158,75 +158,75 @@ instance P.Num (Exp Word64) where fromInteger = constant . P.fromInteger instance P.Num (Exp CInt) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger instance P.Num (Exp CUInt) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger instance P.Num (Exp CLong) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger instance P.Num (Exp CULong) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger instance P.Num (Exp CLLong) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger instance P.Num (Exp CULLong) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger instance P.Num (Exp CShort) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger instance P.Num (Exp CUShort) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger instance P.Num (Exp Half) where @@ -257,33 +257,19 @@ instance P.Num (Exp Double) where fromInteger = constant . P.fromInteger instance P.Num (Exp CFloat) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger instance P.Num (Exp CDouble) where - (+) = lift2 mkAdd - (-) = lift2 mkSub - (*) = lift2 mkMul - negate = lift1 mkNeg - abs = lift1 mkAbs - signum = lift1 mkSig + (+) = mkAdd + (-) = mkSub + (*) = mkMul + negate = mkNeg + abs = mkAbs + signum = mkSig fromInteger = constant . P.fromInteger - -lift1 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b) - -> Exp a - -> Exp a -lift1 f = mkUnsafeCoerce . f . mkUnsafeCoerce - -lift2 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b -> Exp b) - -> Exp a - -> Exp a - -> Exp a -lift2 f x y = mkUnsafeCoerce (f (mkUnsafeCoerce x) (mkUnsafeCoerce y)) - diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 095615a8d..9a45c4e29 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -68,7 +68,7 @@ class Eq a => Ord a where -- 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 +ifThenElse (Exp c) (Exp x) (Exp y) = Exp $ SmartExp $ Cond c x y instance Ord () where (<) _ _ = constant False @@ -160,68 +160,68 @@ instance Ord Word64 where max = mkMax instance Ord CInt where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CUInt where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CLong where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CULong where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CLLong where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CULLong where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CShort where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CUShort where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord Bool where (<) = mkLt @@ -240,28 +240,28 @@ instance Ord Char where max = mkMax instance Ord CChar where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CUChar where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CSChar where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord Half where (<) = mkLt @@ -288,20 +288,20 @@ instance Ord Double where max = mkMax instance Ord CFloat where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord CDouble where - (<) = liftB mkLt - (>) = liftB mkGt - (<=) = liftB mkLtEq - (>=) = liftB mkGtEq - min = lift2 mkMin - max = lift2 mkMax + (<) = mkLt + (>) = mkGt + (<=) = mkLtEq + (>=) = mkGtEq + min = mkMin + max = mkMax instance Ord Z where (<) _ _ = constant False @@ -522,7 +522,7 @@ instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g, Ord h, Ord i, Ord j, instance Elt Ordering where type EltRepr Ordering = Int8 - eltType = TypeRscalar scalarType + eltType = TupRsingle scalarType fromElt = P.fromIntegral . P.fromEnum toElt = P.toEnum . P.fromIntegral @@ -564,18 +564,3 @@ preludeError x y , "constraints for subsequent classes in the standard Haskell numeric" , "hierarchy." ] - -lift2 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b -> Exp b) - -> Exp a - -> Exp a - -> Exp a -lift2 f x y = mkUnsafeCoerce (f (mkUnsafeCoerce x) (mkUnsafeCoerce y)) - -liftB :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b -> Exp Bool) - -> Exp a - -> Exp a - -> Exp Bool -liftB f x y = f (mkUnsafeCoerce x) (mkUnsafeCoerce y) - diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs b/src/Data/Array/Accelerate/Classes/RealFloat.hs index 1ca0eae40..009d941da 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs @@ -78,9 +78,9 @@ class (RealFrac a, Floating a) => RealFloat a where -- | 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) + in cond (m == 0) + 0 + (n + floatDigits x) -- | Corresponds to the first component of 'decodeFloat' significand :: Exp a -> Exp a @@ -90,8 +90,8 @@ class (RealFrac a, Floating a) => RealFloat a where -- | 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) + cond (k == 0 || isFix) x + $ encodeFloat m (n + clamp b) where isFix = x == 0 || isNaN x || isInfinite x (m,n) = decodeFloat x @@ -155,7 +155,7 @@ instance RealFloat Double where decodeFloat = ieee754 "decodeFloat" (untup2 . ieee754_f64_decode . mkBitcast) instance RealFloat CFloat where - atan2 = lift2 mkAtan2 + atan2 = mkAtan2 isNaN = mkIsNaN . mkBitcast @Float isInfinite = mkIsInfinite . mkBitcast @Float isDenormalized = ieee754 "isDenormalized" (ieee754_f32_is_denormalized . mkBitcast) @@ -165,7 +165,7 @@ instance RealFloat CFloat where encodeFloat x e = mkBitcast (encodeFloat @Float x e) instance RealFloat CDouble where - atan2 = lift2 mkAtan2 + atan2 = mkAtan2 isNaN = mkIsNaN . mkBitcast @Double isInfinite = mkIsInfinite . mkBitcast @Double isDenormalized = ieee754 "isDenormalized" (ieee754_f64_is_denormalized . mkBitcast) @@ -198,13 +198,6 @@ preludeError x ] -lift2 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b -> Exp b) - -> Exp a - -> Exp a - -> Exp a -lift2 f x y = mkUnsafeCoerce (f (mkUnsafeCoerce x) (mkUnsafeCoerce y)) - ieee754 :: forall a b. P.RealFloat a => String -> (Exp a -> b) -> Exp a -> b ieee754 name f x | P.isIEEE (undefined::a) = f x @@ -323,19 +316,19 @@ ieee754_f16_decode i = (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 + $ cond (exp1 /= _HMINEXP) + -- don't add hidden bit to denorms + (tup2 (high2 .|. _HHIGHBIT, exp1)) + -- a denorm, normalise the mantissa + (while (\(untup2 -> (h,_)) -> (h .&. _HHIGHBIT) /= 0 ) + (\(untup2 -> (h,e)) -> tup2 (h `unsafeShiftL` 1, e-1)) + (tup2 (high2, exp2))) + + high4 = cond (fromIntegral i < (0 :: Exp Int16)) (-high3) high3 in - Exp $ Cond (high1 .&. complement _HMSBIT == 0) - (tup2 (0,0)) - (tup2 (high4, exp3)) + cond (high1 .&. complement _HMSBIT == 0) + (tup2 (0,0)) + (tup2 (high4, exp3)) -- From: ghc/rts/StgPrimFloat.c @@ -358,19 +351,19 @@ ieee754_f32_decode i = (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 + $ cond (exp1 /= _FMINEXP) + -- don't add hidden bit to denorms + (tup2 (high2 .|. _FHIGHBIT, exp1)) + -- a denorm, normalise the mantissa + (while (\(untup2 -> (h,_)) -> (h .&. _FHIGHBIT) /= 0 ) + (\(untup2 -> (h,e)) -> tup2 (h `unsafeShiftL` 1, e-1)) + (tup2 (high2, exp2))) + + high4 = cond (fromIntegral i < (0 :: Exp Int32)) (-high3) high3 in - Exp $ Cond (high1 .&. complement _FMSBIT == 0) - (tup2 (0,0)) - (tup2 (high4, exp3)) + cond (high1 .&. complement _FMSBIT == 0) + (tup2 (0,0)) + (tup2 (high4, exp3)) ieee754_f64_decode :: Exp Word64 -> Exp (Int64, Int) @@ -391,26 +384,31 @@ ieee754_f64_decode2 i = high = fromIntegral (i `unsafeShiftR` 32) iexp = (fromIntegral ((high `unsafeShiftR` 20) .&. 0x7FF) + _DMINEXP) - sign = Exp $ Cond (fromIntegral i < (0 :: Exp Int64)) (-1) 1 + sign = 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))) + $ cond (iexp2 /= _DMINEXP) + -- don't add hidden bit to denorms + (tup3 (high2 .|. _DHIGHBIT, low, iexp)) + -- a denorm, nermalise the mantissa + (while (\(untup3 -> (h,_,_)) -> (h .&. _DHIGHBIT) /= 0) + (\(untup3 -> (h,l,e)) -> + let h1 = h `unsafeShiftL` 1 + h2 = 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)) + cond (low == 0 && (high .&. (complement _DMSBIT)) == 0) + (tup4 (1,0,0,0)) + (tup4 (sign,hi,lo,ie)) + +cond :: Exp Bool -> Exp a -> Exp a -> Exp a +cond (Exp c) (Exp x) (Exp y) = Exp $ SmartExp $ Cond c x y +while :: forall e. Elt e => (Exp e -> Exp Bool) -> (Exp e -> Exp e) -> Exp e -> Exp e +while c f (Exp e) = Exp $ SmartExp $ While (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs b/src/Data/Array/Accelerate/Classes/RealFrac.hs index 8bc4e0dbd..5d47dba40 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -128,17 +129,17 @@ instance RealFrac Double where instance RealFrac CFloat where properFraction = defaultProperFraction - truncate = lift1 defaultTruncate - round = lift1 defaultRound - ceiling = lift1 defaultCeiling - floor = lift1 defaultFloor + truncate = defaultTruncate + round = defaultRound + ceiling = defaultCeiling + floor = defaultFloor instance RealFrac CDouble where properFraction = defaultProperFraction - truncate = lift1 defaultTruncate - round = lift1 defaultRound - ceiling = lift1 defaultCeiling - floor = lift1 defaultFloor + truncate = defaultTruncate + round = defaultRound + ceiling = defaultCeiling + floor = defaultFloor -- Must test for ±0.0 to avoid returning -0.0 in the second component of the @@ -196,6 +197,7 @@ defaultFloor x | otherwise = let (n, r) = properFraction x in cond (r < 0) (n-1) n +-- mkRound :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b defaultRound :: forall a b. (RealFrac a, Integral b, FromIntegral Int64 b) => Exp a -> Exp b defaultRound x | Just IsFloatingDict <- isFloating @a @@ -219,10 +221,10 @@ data IsFloatingDict a where data IsIntegralDict a where IsIntegralDict :: IsIntegral a => IsIntegralDict a -isFloating :: forall a. Elt a => Maybe (IsFloatingDict a) +isFloating :: forall a. Elt a => Maybe (IsFloatingDict (EltRepr a)) isFloating | Just Refl <- eqT @a @(EltRepr a) - , TypeRscalar t <- eltType @a + , TupRsingle t <- eltType @a , SingleScalarType s <- t , NumSingleType n <- s , FloatingNumType f <- n @@ -234,10 +236,10 @@ isFloating | otherwise = Nothing -isIntegral :: forall a. Elt a => Maybe (IsIntegralDict a) +isIntegral :: forall a. Elt a => Maybe (IsIntegralDict (EltRepr a)) isIntegral | Just Refl <- eqT @a @(EltRepr a) - , TypeRscalar t <- eltType @a + , TupRsingle t <- eltType @a , SingleScalarType s <- t , NumSingleType n <- s , IntegralNumType i <- n @@ -274,10 +276,3 @@ preludeError x , "These Prelude.RealFrac instances are present only to fulfil superclass" , "constraints for subsequent classes in the standard Haskell numeric hierarchy." ] - -lift1 :: (Elt a, Elt b, Elt c, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp c) - -> Exp a - -> Exp c -lift1 f x = f (mkUnsafeCoerce x) - diff --git a/src/Data/Array/Accelerate/Data/Bits.hs b/src/Data/Array/Accelerate/Data/Bits.hs index 013e20acd..ad17ec9fe 100644 --- a/src/Data/Array/Accelerate/Data/Bits.hs +++ b/src/Data/Array/Accelerate/Data/Bits.hs @@ -366,200 +366,200 @@ instance Bits Word64 where popCount = mkPopCount instance Bits CInt where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @Int32 testBit b = testBitDefault (mkBitcast @Int32 b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @Int32 instance Bits CUInt where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @Word32 testBit b = testBitDefault (mkBitcast @Word32 b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @Word32 instance Bits CLong where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @HTYPE_CLONG testBit b = testBitDefault (mkBitcast @HTYPE_CLONG b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @HTYPE_CLONG instance Bits CULong where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @HTYPE_CULONG testBit b = testBitDefault (mkBitcast @HTYPE_CULONG b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @HTYPE_CULONG instance Bits CLLong where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @Int64 testBit b = testBitDefault (mkBitcast @Int64 b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @Int64 instance Bits CULLong where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @Word64 testBit b = testBitDefault (mkBitcast @Word64 b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @Word64 instance Bits CShort where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @Int16 testBit b = testBitDefault (mkBitcast @Int16 b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @Int16 instance Bits CUShort where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @Word16 testBit b = testBitDefault (mkBitcast @Word16 b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @Word16 instance Bits CChar where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @HTYPE_CCHAR testBit b = testBitDefault (mkBitcast @HTYPE_CCHAR b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @HTYPE_CCHAR instance Bits CSChar where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @Int8 testBit b = testBitDefault (mkBitcast @Int8 b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @Int8 instance Bits CUChar where - (.&.) = lift2 mkBAnd - (.|.) = lift2 mkBOr - xor = lift2 mkBXor - complement = lift1 mkBNot + (.&.) = mkBAnd + (.|.) = mkBOr + xor = mkBXor + complement = mkBNot bit = mkBitcast . bitDefault @Word8 testBit b = testBitDefault (mkBitcast @Word8 b) - shift = lift2' shiftDefault - shiftL = lift2' shiftLDefault - shiftR = lift2' shiftRDefault - unsafeShiftL = lift2' mkBShiftL - unsafeShiftR = lift2' mkBShiftR - rotate = lift2' rotateDefault - rotateL = lift2' rotateLDefault - rotateR = lift2' rotateRDefault + shift = shiftDefault + shiftL = shiftLDefault + shiftR = shiftRDefault + unsafeShiftL = mkBShiftL + unsafeShiftR = mkBShiftR + rotate = rotateDefault + rotateL = rotateLDefault + rotateR = rotateRDefault isSigned = isSignedDefault popCount = mkPopCount . mkBitcast @Word8 @@ -569,176 +569,154 @@ instance Bits CUChar where -- ------------------------ instance FiniteBits Bool where - finiteBitSize _ = constant 8 -- stored as Word8 {- (B.finiteBitSize (undefined::Bool)) -} + finiteBitSize _ = constInt 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)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Int)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits Int8 where - finiteBitSize _ = constant (B.finiteBitSize (undefined::Int8)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Int8)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits Int16 where - finiteBitSize _ = constant (B.finiteBitSize (undefined::Int16)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Int16)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits Int32 where - finiteBitSize _ = constant (B.finiteBitSize (undefined::Int32)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Int32)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits Int64 where - finiteBitSize _ = constant (B.finiteBitSize (undefined::Int64)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Int64)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits Word where - finiteBitSize _ = constant (B.finiteBitSize (undefined::Word)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Word)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits Word8 where - finiteBitSize _ = constant (B.finiteBitSize (undefined::Word8)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Word8)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits Word16 where - finiteBitSize _ = constant (B.finiteBitSize (undefined::Word16)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Word16)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits Word32 where - finiteBitSize _ = constant (B.finiteBitSize (undefined::Word32)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Word32)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits Word64 where - finiteBitSize _ = constant (B.finiteBitSize (undefined::Word64)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::Word64)) countLeadingZeros = mkCountLeadingZeros countTrailingZeros = mkCountTrailingZeros instance FiniteBits CInt where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CInt)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CInt)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @Int32 countTrailingZeros = mkCountTrailingZeros . mkBitcast @Int32 instance FiniteBits CUInt where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CUInt)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CUInt)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @Word32 countTrailingZeros = mkCountTrailingZeros . mkBitcast @Word32 instance FiniteBits CLong where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CLong)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CLong)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @HTYPE_CLONG countTrailingZeros = mkCountTrailingZeros . mkBitcast @HTYPE_CLONG instance FiniteBits CULong where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CULong)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CULong)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @HTYPE_CULONG countTrailingZeros = mkCountTrailingZeros . mkBitcast @HTYPE_CULONG instance FiniteBits CLLong where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CLLong)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CLLong)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @Int64 countTrailingZeros = mkCountTrailingZeros . mkBitcast @Int64 instance FiniteBits CULLong where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CULLong)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CULLong)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @Word64 countTrailingZeros = mkCountTrailingZeros . mkBitcast @Word64 instance FiniteBits CShort where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CShort)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CShort)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @Int16 countTrailingZeros = mkCountTrailingZeros . mkBitcast @Int16 instance FiniteBits CUShort where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CUShort)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CUShort)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @Word16 countTrailingZeros = mkCountTrailingZeros . mkBitcast @Word16 instance FiniteBits CChar where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CChar)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CChar)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @HTYPE_CCHAR countTrailingZeros = mkCountTrailingZeros . mkBitcast @HTYPE_CCHAR instance FiniteBits CSChar where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CSChar)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CSChar)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @Int8 countTrailingZeros = mkCountTrailingZeros . mkBitcast @Int8 instance FiniteBits CUChar where - finiteBitSize _ = constant (B.finiteBitSize (undefined::CUChar)) + finiteBitSize _ = constInt (B.finiteBitSize (undefined::CUChar)) countLeadingZeros = mkCountLeadingZeros . mkBitcast @Word8 countTrailingZeros = mkCountTrailingZeros . mkBitcast @Word8 -- Default implementations -- ----------------------- +bitDefault :: (IsIntegral (EltRepr t), Bits t) => Exp Int -> Exp t +bitDefault x = constInt 1 `shiftL` x -lift1 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b) - -> Exp a - -> Exp a -lift1 f x = mkUnsafeCoerce (f (mkUnsafeCoerce x)) - -lift2 :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp b -> Exp b) - -> Exp a - -> Exp a - -> Exp a -lift2 f x y = mkUnsafeCoerce (f (mkUnsafeCoerce x) (mkUnsafeCoerce y)) - -lift2' :: (Elt a, Elt b, IsScalar b, b ~ EltRepr a) - => (Exp b -> Exp Int -> Exp b) - -> Exp a - -> Exp Int - -> Exp a -lift2' f x y = mkUnsafeCoerce (f (mkUnsafeCoerce x) y) +testBitDefault :: (IsIntegral (EltRepr t), Bits t) => Exp t -> Exp Int -> Exp Bool +testBitDefault x i = (x .&. bit i) /= constInt 0 - -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 :: (FiniteBits t, IsIntegral (EltRepr 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 :: (FiniteBits t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t shiftLDefault x i - = cond (i >= finiteBitSize x) (constant 0) + = cond (i >= finiteBitSize x) (constInt 0) $ mkBShiftL x i -shiftRDefault :: forall t. (B.Bits t, FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t +shiftRDefault :: forall t. (B.Bits t, FiniteBits t, IsIntegral (EltRepr 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 :: (FiniteBits t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t shiftRADefault x i - = cond (i >= finiteBitSize x) (cond (mkLt x (constant 0)) (constant (-1)) (constant 0)) + = cond (i >= finiteBitSize x) (cond (mkLt x (constInt 0)) (constInt (-1)) (constInt 0)) $ mkBShiftR x i -- Shift the argument right (unsigned) -shiftRLDefault :: (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t +shiftRLDefault :: (FiniteBits t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t shiftRLDefault x i - = cond (i >= finiteBitSize x) (constant 0) + = cond (i >= finiteBitSize x) (constInt 0) $ mkBShiftR x i -rotateDefault :: forall t. (FiniteBits t, IsIntegral t) => Exp t -> Exp Int -> Exp t +rotateDefault :: forall t. (FiniteBits t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t rotateDefault = - case (integralType :: IntegralType t) of + case integralType :: IntegralType (EltRepr t) of TypeInt{} -> rotateDefault' (undefined::Word) TypeInt8{} -> rotateDefault' (undefined::Word8) TypeInt16{} -> rotateDefault' (undefined::Word16) @@ -751,7 +729,7 @@ rotateDefault = TypeWord64{} -> rotateDefault' (undefined::Word64) 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)) + :: forall i w. (Elt w, FiniteBits i, IsIntegral (EltRepr i), IsIntegral (EltRepr w), IsIntegral (EltRepr i), IsIntegral (EltRepr w), BitSizeEq (EltRepr i) (EltRepr w), BitSizeEq (EltRepr w) (EltRepr i)) => w {- dummy -} -> Exp i -> Exp Int @@ -767,12 +745,12 @@ rotateDefault' _ x i i' = i `mkBAnd` (wsib - 1) wsib = finiteBitSize x -rotateLDefault :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t +rotateLDefault :: (Elt t, IsIntegral (EltRepr 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 :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t rotateRDefault x i = cond (i == 0) x $ mkBRotateR x i @@ -780,6 +758,9 @@ rotateRDefault x i isSignedDefault :: forall b. B.Bits b => Exp b -> Exp Bool isSignedDefault _ = constant (B.isSigned (undefined::b)) +constInt :: IsIntegral (EltRepr e) => EltRepr e -> Exp e +constInt = exp . Const (SingleScalarType $ NumSingleType $ IntegralNumType $ integralType) + {-- _popCountDefault :: forall a. (B.FiniteBits a, IsScalar a, Bits a, Num a) => Exp a -> Exp Int _popCountDefault = diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index bb5a89b90..74fe2ee5d 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -47,7 +47,7 @@ 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.Smart hiding (exp) import Data.Array.Accelerate.Type import Prelude ( ($) ) @@ -67,7 +67,7 @@ instance Elt (Complex Half) where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRscalar scalarType + eltType = TupRsingle scalarType toElt (V2 r i) = r :+ i fromElt (r :+ i) = V2 r i @@ -76,7 +76,7 @@ instance Elt (Complex Float) where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRscalar scalarType + eltType = TupRsingle scalarType toElt (V2 r i) = r :+ i fromElt (r :+ i) = V2 r i @@ -85,7 +85,7 @@ instance Elt (Complex Double) where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRscalar scalarType + eltType = TupRsingle scalarType toElt (V2 r i) = r :+ i fromElt (r :+ i) = V2 r i @@ -94,7 +94,7 @@ instance Elt (Complex CFloat) where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRscalar scalarType + eltType = TupRsingle scalarType toElt (V2 r i) = CFloat r :+ CFloat i fromElt (CFloat r :+ CFloat i) = V2 r i @@ -103,24 +103,18 @@ instance Elt (Complex CDouble) where {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRscalar scalarType + eltType = TupRsingle scalarType toElt (V2 r i) = CDouble r :+ CDouble i fromElt (CDouble r :+ CDouble i) = V2 r i -instance cst a => IsProduct cst (Complex a) where - type ProdRepr (Complex a) = ProdRepr (a,a) - fromProd (r :+ i) = fromProd @cst (r,i) - toProd p = let (r,i) = toProd @cst p in (r :+ i) - prod = prod @cst @(a,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) + lift (r :+ i) = P.undefined -- 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 + = let r = P.undefined -- Exp $ SuccTupIdx ZeroTupIdx `Prj` e + i = P.undefined -- Exp $ ZeroTupIdx `Prj` e in r :+ i diff --git a/src/Data/Array/Accelerate/Data/Monoid.hs b/src/Data/Array/Accelerate/Data/Monoid.hs index 1948c942a..a41cb8217 100644 --- a/src/Data/Array/Accelerate/Data/Monoid.hs +++ b/src/Data/Array/Accelerate/Data/Monoid.hs @@ -40,7 +40,6 @@ 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 @@ -61,26 +60,20 @@ import qualified Prelude as P -- -------------------------- instance Elt a => Elt (Sum a) where - type EltRepr (Sum a) = ((), EltRepr a) + type EltRepr (Sum a) = EltRepr a {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRpair TypeRunit (eltType @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 + eltType = eltType @a + toElt x = Sum (toElt x) + fromElt (Sum x) = fromElt x 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 + lift (Sum a) = let Exp e = lift a in Exp e instance Elt a => Unlift Exp (Sum (Exp a)) where - unlift t = Sum . Exp $ ZeroTupIdx `Prj` t + unlift (Exp t) = Sum $ Exp t instance Bounded a => P.Bounded (Exp (Sum a)) where minBound = lift $ Sum (minBound :: Exp a) @@ -129,26 +122,20 @@ instance Num a => Semigroup (Exp (Sum a)) where -- ------------------------------------ instance Elt a => Elt (Product a) where - type EltRepr (Product a) = ((), EltRepr a) + type EltRepr (Product a) = EltRepr a {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRpair TypeRunit (eltType @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 + eltType = eltType @a + toElt x = Product (toElt x) + fromElt (Product x) = fromElt x 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 + lift (Product a) = let Exp e = lift a in Exp e instance Elt a => Unlift Exp (Product (Exp a)) where - unlift t = Product . Exp $ ZeroTupIdx `Prj` t + unlift (Exp t) = Product $ Exp t instance Bounded a => P.Bounded (Exp (Product a)) where minBound = lift $ Product (minBound :: Exp a) diff --git a/src/Data/Array/Accelerate/Data/Semigroup.hs b/src/Data/Array/Accelerate/Data/Semigroup.hs index 369bdcac5..d10ce5dbf 100644 --- a/src/Data/Array/Accelerate/Data/Semigroup.hs +++ b/src/Data/Array/Accelerate/Data/Semigroup.hs @@ -41,9 +41,7 @@ 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(..) ) @@ -52,26 +50,20 @@ import qualified Prelude as P instance Elt a => Elt (Min a) where - type EltRepr (Min a) = ((), EltRepr a) + type EltRepr (Min a) = EltRepr a {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRpair TypeRunit (eltType @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 + eltType = eltType @a + toElt x = Min (toElt x) + fromElt (Min x) = fromElt x 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 + lift (Min a) = let Exp e = lift a in Exp e instance Elt a => Unlift Exp (Min (Exp a)) where - unlift t = Min . Exp $ ZeroTupIdx `Prj` t + unlift (Exp t) = Min $ Exp t instance Bounded a => P.Bounded (Exp (Min a)) where minBound = lift $ Min (minBound :: Exp a) @@ -108,26 +100,20 @@ instance (Ord a, Bounded a) => Monoid (Exp (Min a)) where instance Elt a => Elt (Max a) where - type EltRepr (Max a) = ((), EltRepr a) + type EltRepr (Max a) = EltRepr a {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TypeRpair TypeRunit (eltType @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 + eltType = eltType @a + toElt x = Max (toElt x) + fromElt (Max x) = fromElt x 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 + lift (Max a) = let Exp e = lift a in Exp e instance Elt a => Unlift Exp (Max (Exp a)) where - unlift t = Max . Exp $ ZeroTupIdx `Prj` t + unlift (Exp t) = Max $ Exp t instance Bounded a => P.Bounded (Exp (Max a)) where minBound = lift $ Max (minBound :: Exp a) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 14ece2974..12c4bc11f 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -112,6 +113,8 @@ import Data.Array.Accelerate.Array.Sugar hiding ( (!) import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Array.Sugar as Sugar +import qualified Data.Array.Accelerate.Array.Representation as Repr +import Data.Array.Accelerate.AST ( PrimFun(..) ) import Data.Array.Accelerate.Classes.Eq import Data.Array.Accelerate.Classes.Fractional @@ -169,11 +172,13 @@ use arrs = Acc acc HasTypeable acc = use' (arrays @arrays) $ fromArr arrs use' :: ArraysR a -> a -> HasTypeable a - use' ArraysRunit () = HasTypeable $ SmartAcc $ Anil - use' ArraysRarray a = HasTypeable $ SmartAcc $ Use a - use' (ArraysRpair r1 r2) (a1, a2) + use' TupRunit () = HasTypeable $ SmartAcc $ Anil + use' (TupRsingle repr@(ArrayR shr t)) a + | TypeableDict <- typeableDict $ Repr.shapeType shr + , TypeableDict <- typeableDict t = HasTypeable $ SmartAcc $ Use repr a + use' (TupRpair r1 r2) (a1, a2) | HasTypeable acc1 <- use' r1 a1 - , HasTypeable acc2 <- use' r2 a2 = HasTypeable $ SmartAcc $ acc1 `Apair` acc2 + , HasTypeable acc2 <- use' r2 a2 = HasTypeable $ SmartAcc $ acc1 `Apair` acc2 -- Internal data type for 'use' to capture the 'Typeable' type class data HasTypeable a where @@ -183,8 +188,8 @@ data HasTypeable a where -- | 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 . SmartAcc . Unit +unit :: forall e. Elt e => Exp e -> Acc (Scalar e) +unit (Exp e) = Acc $ SmartAcc $ Unit (eltType @e) e -- | Replicate an array across one or more dimensions as specified by the -- /generalised/ array index provided as the first argument. @@ -268,11 +273,12 @@ unit = Acc . SmartAcc . Unit -- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9] -- replicate - :: (Slice slix, Elt e) + :: forall slix e. + (Slice slix, Elt e) => Exp slix -> Acc (Array (SliceShape slix) e) -> Acc (Array (FullShape slix) e) -replicate = Acc $$ applyAcc Replicate +replicate = Acc $$ applyAcc (Replicate $ sliceIndex @slix) -- | Construct a new array by applying a function to each index. -- @@ -304,11 +310,12 @@ replicate = Acc $$ applyAcc Replicate -- @.\/Data\/Array\/Accelerate\/Trafo\/Sharing.hs:447 (convertSharingExp): inconsistent valuation \@ shared \'Exp\' tree ...@. -- generate - :: (Shape sh, Elt a) + :: forall sh a. + (Shape sh, Elt a) => Exp sh -> (Exp sh -> Exp a) -> Acc (Array sh a) -generate = Acc $$ applyAcc Generate +generate = Acc $$ applyAcc (Generate $ arrayR @sh @a) -- Shape manipulation -- ------------------ @@ -323,11 +330,12 @@ generate = Acc $$ applyAcc Generate -- an index transformation in the fused code. -- reshape - :: (Shape sh, Shape sh', Elt e) + :: forall sh sh' e. + (Shape sh, Shape sh', Elt e) => Exp sh -> Acc (Array sh' e) -> Acc (Array sh e) -reshape = Acc $$ applyAcc Reshape +reshape = Acc $$ applyAcc (Reshape $ shapeR @sh) -- Extraction of sub-arrays -- ------------------------ @@ -397,11 +405,12 @@ reshape = Acc $$ applyAcc Reshape -- 30, 31, 32, 33, 34, -- 50, 51, 52, 53, 54] -- -slice :: (Slice slix, Elt e) +slice :: forall slix e. + (Slice slix, Elt e) => Acc (Array (FullShape slix) e) -> Exp slix -> Acc (Array (SliceShape slix) e) -slice = Acc $$ applyAcc Slice +slice = Acc $$ applyAcc (Slice $ sliceIndex @slix) -- Map-like functions -- ------------------ @@ -417,11 +426,12 @@ slice = Acc $$ applyAcc Slice -- >>> 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) +map :: forall sh a b. + (Shape sh, Elt a, Elt b) => (Exp a -> Exp b) -> Acc (Array sh a) -> Acc (Array sh b) -map = Acc $$ applyAcc Map +map = Acc $$ applyAcc (Map (eltType @a) (eltType @b)) -- | 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 @@ -449,12 +459,13 @@ map = Acc $$ applyAcc Map -- 16, 18, 20, 22, 24, -- 31, 33, 35, 37, 39] -- -zipWith :: (Shape sh, Elt a, Elt b, Elt c) +zipWith :: forall sh a b c. + (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 $$$ applyAcc ZipWith +zipWith = Acc $$$ applyAcc (ZipWith (eltType @a) (eltType @b) (eltType @c)) -- Reductions -- ---------- @@ -520,12 +531,13 @@ zipWith = Acc $$$ applyAcc ZipWith -- 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) +fold :: forall sh a. + (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array sh a) -fold = Acc $$$ applyAcc Fold +fold = Acc $$$ applyAcc (Fold $ eltType @a) -- | Variant of 'fold' that requires the innermost dimension of the array to be -- non-empty and doesn't need an default value. @@ -537,11 +549,12 @@ fold = Acc $$$ applyAcc Fold -- 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) +fold1 :: forall sh a. + (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array sh a) -fold1 = Acc $$ applyAcc Fold1 +fold1 = Acc $$ applyAcc (Fold1 $ eltType @a) -- | Segmented reduction along the innermost dimension of an array. The -- segment descriptor specifies the starting index (offset) along the @@ -557,13 +570,14 @@ fold1 = Acc $$ applyAcc Fold1 -- @since 1.3.0.0 -- foldSeg' - :: (Shape sh, Elt a, Elt i, IsIntegral i) + :: forall sh a i. + (Shape sh, Elt a, Elt i, IsIntegral i, i ~ EltRepr i) => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Segments i) -> Acc (Array (sh:.Int) a) -foldSeg' = Acc $$$$ applyAcc FoldSeg +foldSeg' = Acc $$$$ applyAcc (FoldSeg (integralType @i) (eltType @a)) -- | Variant of 'foldSeg'' that requires /all/ segments of the reduced -- array to be non-empty, and doesn't need a default value. The segment @@ -573,12 +587,13 @@ foldSeg' = Acc $$$$ applyAcc FoldSeg -- @since 1.3.0.0 -- fold1Seg' - :: (Shape sh, Elt a, Elt i, IsIntegral i) + :: forall sh a i. + (Shape sh, Elt a, Elt i, IsIntegral i, i ~ EltRepr i) => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Segments i) -> Acc (Array (sh:.Int) a) -fold1Seg' = Acc $$$ applyAcc Fold1Seg +fold1Seg' = Acc $$$ applyAcc (Fold1Seg (integralType @i) (eltType @a)) -- Scan functions -- -------------- @@ -600,12 +615,13 @@ fold1Seg' = Acc $$$ applyAcc Fold1Seg -- 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) +scanl :: forall sh a. + (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanl = Acc $$$ applyAcc Scanl +scanl = Acc $$$ applyAcc (Scanl $ eltType @a) -- | Variant of 'scanl', where the last element (final reduction result) along -- each dimension is returned separately. Denotationally we have: @@ -633,12 +649,13 @@ scanl = Acc $$$ applyAcc Scanl -- >>> sums -- Vector (Z :. 4) [45,145,245,345] -- -scanl' :: (Shape sh, Elt a) +scanl' :: forall sh a. + (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 $$$ applyAcc Scanl' +scanl' = Acc $$$ applyAcc (Scanl' $ eltType @a) -- | 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 @@ -652,37 +669,41 @@ scanl' = Acc $$$ applyAcc Scanl' -- 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) +scanl1 :: forall sh a. + (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanl1 = Acc $$ applyAcc Scanl1 +scanl1 = Acc $$ applyAcc (Scanl1 $ eltType @a) -- | Right-to-left variant of 'scanl'. -- -scanr :: (Shape sh, Elt a) +scanr :: forall sh a. + (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanr = Acc $$$ applyAcc Scanr +scanr = Acc $$$ applyAcc (Scanr $ eltType @a) -- | Right-to-left variant of 'scanl''. -- -scanr' :: (Shape sh, Elt a) +scanr' :: forall sh a. + (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 $$$ applyAcc Scanr' +scanr' = Acc $$$ applyAcc (Scanr' $ eltType @a) -- | Right-to-left variant of 'scanl1'. -- -scanr1 :: (Shape sh, Elt a) +scanr1 :: forall sh a. + (Shape sh, Elt a) => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanr1 = Acc $$ applyAcc Scanr1 +scanr1 = Acc $$ applyAcc (Scanr1 $ eltType @a) -- Permutations -- ------------ @@ -780,13 +801,13 @@ scanr1 = Acc $$ applyAcc Scanr1 -- @-fno-fast-permute-const@. -- permute - :: (Shape sh, Shape sh', Elt a) + :: forall sh sh' a. (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 $$$$ applyAcc Permute +permute = Acc $$$$ applyAcc (Permute $ arrayR @sh @a) -- | Generalised backward permutation operation (array gather). -- @@ -832,13 +853,12 @@ permute = Acc $$$$ applyAcc Permute -- 9, 19, 29, 39, 49] -- backpermute - :: (Shape sh, Shape sh', Elt a) + :: forall sh sh' a. (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 $$$ applyAcc Backpermute - +backpermute = Acc $$$ applyAcc (Backpermute $ shapeR @sh') -- Stencil operations -- ------------------ @@ -945,20 +965,27 @@ type Stencil5x5x5 a = (Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, S -- which approach is best for your application. -- stencil - :: (Stencil sh a stencil, Elt b) + :: forall sh stencil a b. + (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) (Acc a) - = Acc $ SmartAcc $ Stencil f b a + = Acc $ SmartAcc $ Stencil + (stencilR @sh @a @stencil) + (eltType @b) + (unExp . f . stencilPrj @sh @a @stencil) + 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) + :: forall sh stencil1 stencil2 a b c. + (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 @@ -966,7 +993,15 @@ stencil2 -> Acc (Array sh b) -- ^ source array #2 -> Acc (Array sh c) -- ^ destination array stencil2 f (Boundary b1) (Acc a1) (Boundary b2) (Acc a2) - = Acc $ SmartAcc $ Stencil2 f b1 a1 b2 a2 + = Acc $ SmartAcc $ Stencil2 + (stencilR @sh @a @stencil1) + (stencilR @sh @b @stencil2) + (eltType @c) + (\x y -> unExp $ f (stencilPrj @sh @a @stencil1 x) (stencilPrj @sh @b @stencil2 y)) + 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. @@ -1040,10 +1075,13 @@ wrap = Boundary Wrap -- > Z :. height :. width = unlift (shape xs) -- function - :: (Shape sh, Elt e) + :: forall sh e. (Shape sh, Elt e) => (Exp sh -> Exp e) -> Boundary (Array sh e) -function = Boundary . Function +function f = Boundary $ Function (f') + where + f' :: SmartExp (EltRepr sh) -> SmartExp (EltRepr e) + f' = unExp . f . Exp {-- @@ -1192,7 +1230,7 @@ foreignExp -> (Exp x -> Exp y) -> Exp x -> Exp y -foreignExp = Exp $$$ Foreign +foreignExp a f (Exp x) = exp $ Foreign a f x -- Composition of array computations @@ -1212,7 +1250,7 @@ foreignExp = Exp $$$ Foreign -- infixl 1 >-> (>->) :: forall a b c. (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b) -> (Acc b -> Acc c) -> (Acc a -> Acc c) -(>->) = Acc $$$ applyAcc $ Pipe (arrays @a) (arrays @b) +(>->) = Acc $$$ applyAcc $ Pipe (arrays @a) (arrays @b) (arrays @c) -- Flow control constructs @@ -1249,26 +1287,41 @@ awhile = Acc $$$ applyAcc $ Awhile $ arrays @a -- array. -- toIndex - :: Shape sh + :: forall sh. Shape sh => Exp sh -- ^ extent of the array -> Exp sh -- ^ index to remap -> Exp Int -toIndex = Exp $$ ToIndex +toIndex (Exp sh) (Exp ix) = exp $ ToIndex (shapeR @sh) sh ix -- | Inverse of 'toIndex' -- -fromIndex :: Shape sh => Exp sh -> Exp Int -> Exp sh -fromIndex = Exp $$ FromIndex +fromIndex :: forall sh. Shape sh => Exp sh -> Exp Int -> Exp sh +fromIndex (Exp sh) (Exp e) = exp $ FromIndex (shapeR @sh) sh e -- | Intersection of two shapes -- -intersect :: Shape sh => Exp sh -> Exp sh -> Exp sh -intersect = Exp $$ Intersect +intersect :: forall sh. Shape sh => Exp sh -> Exp sh -> Exp sh +intersect (Exp x) (Exp y) = Exp $ intersect' (shapeR @sh) x y + +intersect' :: Repr.ShapeR sh -> SmartExp sh -> SmartExp sh -> SmartExp sh +intersect' Repr.ShapeRz _ _ = SmartExp Nil +intersect' (Repr.ShapeRcons shr) (unPair -> (xs, x)) (unPair -> (ys, y)) + = SmartExp + $ intersect' shr xs ys `Pair` + SmartExp (PrimApp (PrimMax singleType) $ SmartExp $ Pair x y) + -- | Union of two shapes -- -union :: Shape sh => Exp sh -> Exp sh -> Exp sh -union = Exp $$ Union +union :: forall sh. Shape sh => Exp sh -> Exp sh -> Exp sh +union (Exp x) (Exp y) = Exp $ union' (shapeR @sh) x y + +union' :: Repr.ShapeR sh -> SmartExp sh -> SmartExp sh -> SmartExp sh +union' Repr.ShapeRz _ _ = SmartExp Nil +union' (Repr.ShapeRcons shr) (unPair -> (xs, x)) (unPair -> (ys, y)) + = SmartExp + $ union' shr xs ys `Pair` + SmartExp (PrimApp (PrimMin singleType) $ SmartExp $ Pair x y) -- Flow-control @@ -1284,17 +1337,17 @@ cond :: Elt t -> Exp t -- ^ then-expression -> Exp t -- ^ else-expression -> Exp t -cond = Exp $$$ Cond +cond (Exp c) (Exp x) (Exp y) = exp $ Cond c x y -- | While construct. Continue to apply the given function, starting with the -- initial value, until the test function evaluates to 'False'. -- -while :: Elt e +while :: forall e. 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 +while c f (Exp e) = exp $ While @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e -- Array operations with a scalar result @@ -1316,8 +1369,8 @@ while = Exp $$$ While -- 12 -- infixl 9 ! -(!) :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -> Exp e -Acc a ! ix = Exp $ Index a ix +(!) :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -> Exp e +Acc a ! Exp ix = exp $ Index (eltType @e) a ix -- | Extract the value from an array at the specified linear index. -- Multidimensional arrays in Accelerate are stored in row-major order with @@ -1336,13 +1389,13 @@ Acc a ! ix = Exp $ Index a ix -- 12 -- infixl 9 !! -(!!) :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp Int -> Exp e -Acc a !! ix = Exp $ LinearIndex a ix +(!!) :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Exp Int -> Exp e +Acc a !! Exp ix = exp $ LinearIndex (eltType @e) a ix -- | Extract the shape (extent) of an array. -- -shape :: (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -shape = Exp . Shape . unAcc +shape :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh +shape = exp . Shape (shapeR @sh) . unAcc -- | The number of elements in the array -- @@ -1351,8 +1404,8 @@ 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 +shapeSize :: forall sh. Shape sh => Exp sh -> Exp Int +shapeSize (Exp sh) = exp $ ShapeSize (shapeR @sh) sh -- Numeric functions diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 22cb2796a..d05b8e07c 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -2,6 +2,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ <= 708 @@ -138,153 +141,157 @@ instance Unlift Acc (Acc a) where instance Lift Exp () where type Plain () = () - lift _ = Exp $ Tuple NilTup + lift _ = Exp $ SmartExp Nil instance Unlift Exp () where unlift _ = () instance Lift Exp Z where type Plain Z = Z - lift _ = Exp $ IndexNil + lift _ = Exp $ SmartExp Nil instance Unlift Exp Z where unlift _ = Z instance (Elt (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) + lift (ix:.i) = Exp $ SmartExp $ Pair (unExp $ lift ix) (unExp $ expConst i) instance (Elt (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) + lift (ix:.i) = Exp $ SmartExp $ Pair (unExp $ lift ix) (unExp $ constant i) instance (Elt e, Elt (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 + lift (ix :. Exp i) = Exp $ SmartExp $ Pair (unExp $ lift ix) i instance {-# OVERLAPPABLE #-} (Elt e, Elt (Plain ix), Unlift Exp ix) => Unlift Exp (ix :. Exp e) where - unlift e = unlift (Exp $ IndexTail e) :. Exp (IndexHead e) + unlift (Exp e) = unlift (Exp $ SmartExp $ Prj PairIdxLeft e) :. Exp (SmartExp $ Prj PairIdxRight e) instance {-# OVERLAPPABLE #-} (Elt e, Elt ix) => Unlift Exp (Exp ix :. Exp e) where - unlift e = (Exp $ IndexTail e) :. Exp (IndexHead e) + unlift (Exp e) = (Exp $ SmartExp $ Prj PairIdxLeft e) :. Exp (SmartExp $ Prj PairIdxRight e) -instance Shape sh => Lift Exp (Any sh) where - type Plain (Any sh) = Any sh - lift Any = Exp $ IndexAny +instance (Shape sh, Elt (Any sh)) => Lift Exp (Any sh) where + type Plain (Any sh) = Any sh + lift Any = constant Any -- instances for numeric types +{-# INLINE expConst #-} +expConst :: forall e. Elt e => IsScalar (EltRepr e) => e -> Exp e +expConst = Exp . SmartExp . Const (scalarType @(EltRepr e)) . fromElt + instance Lift Exp Int where type Plain Int = Int - lift = Exp . Const + lift = expConst instance Lift Exp Int8 where type Plain Int8 = Int8 - lift = Exp . Const + lift = expConst instance Lift Exp Int16 where type Plain Int16 = Int16 - lift = Exp . Const + lift = expConst instance Lift Exp Int32 where type Plain Int32 = Int32 - lift = Exp . Const + lift = expConst instance Lift Exp Int64 where type Plain Int64 = Int64 - lift = Exp . Const + lift = expConst instance Lift Exp Word where type Plain Word = Word - lift = Exp . Const + lift = expConst instance Lift Exp Word8 where type Plain Word8 = Word8 - lift = Exp . Const + lift = expConst instance Lift Exp Word16 where type Plain Word16 = Word16 - lift = Exp . Const + lift = expConst instance Lift Exp Word32 where type Plain Word32 = Word32 - lift = Exp . Const + lift = expConst instance Lift Exp Word64 where type Plain Word64 = Word64 - lift = Exp . Const + lift = expConst instance Lift Exp CShort where type Plain CShort = CShort - lift = Exp . Const + lift = expConst instance Lift Exp CUShort where type Plain CUShort = CUShort - lift = Exp . Const + lift = expConst instance Lift Exp CInt where type Plain CInt = CInt - lift = Exp . Const + lift = expConst instance Lift Exp CUInt where type Plain CUInt = CUInt - lift = Exp . Const + lift = expConst instance Lift Exp CLong where type Plain CLong = CLong - lift = Exp . Const + lift = expConst instance Lift Exp CULong where type Plain CULong = CULong - lift = Exp . Const + lift = expConst instance Lift Exp CLLong where type Plain CLLong = CLLong - lift = Exp . Const + lift = expConst instance Lift Exp CULLong where type Plain CULLong = CULLong - lift = Exp . Const + lift = expConst instance Lift Exp Half where type Plain Half = Half - lift = Exp . Const + lift = expConst instance Lift Exp Float where type Plain Float = Float - lift = Exp . Const + lift = expConst instance Lift Exp Double where type Plain Double = Double - lift = Exp . Const + lift = expConst instance Lift Exp CFloat where type Plain CFloat = CFloat - lift = Exp . Const + lift = expConst instance Lift Exp CDouble where type Plain CDouble = CDouble - lift = Exp . Const + lift = expConst instance Lift Exp Bool where type Plain Bool = Bool - lift = Exp . Const + lift = expConst instance Lift Exp Char where type Plain Char = Char - lift = Exp . Const + lift = expConst instance Lift Exp CChar where type Plain CChar = CChar - lift = Exp . Const + lift = expConst instance Lift Exp CSChar where type Plain CSChar = CSChar - lift = Exp . Const + lift = expConst instance Lift Exp CUChar where type Plain CUChar = CUChar - lift = Exp . Const + lift = expConst -- Instances for tuples @@ -479,7 +486,7 @@ instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j, instance (Shape sh, Elt e) => Lift Acc (Array sh e) where type Plain (Array sh e) = Array sh e - lift = Acc . SmartAcc . Use + lift (Array arr) = Acc $ SmartAcc $ Use (arrayR @sh @e) arr 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) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 4645ca36e..ac40ac27d 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -37,7 +37,6 @@ module Data.Array.Accelerate.Pattern ( ) where import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Smart import Language.Haskell.TH hiding ( Exp ) @@ -265,12 +264,12 @@ pattern T16 a b c d e f g h i j k l m n o p = Pattern (a, b, c, d, e, f, g, h, i -- IsPattern instances for Shape nil and cons -- instance IsPattern Exp Z Z where - construct _ = Exp IndexNil + construct _ = Exp $ SmartExp Nil destruct _ = Z instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where - construct (a :. b) = Exp (a `IndexCons` b) - destruct t = Exp (IndexTail t) :. Exp (IndexHead t) + construct (Exp a :. Exp b) = Exp $ SmartExp $ a `Pair` b + destruct (Exp t) = Exp (SmartExp $ Prj PairIdxLeft t) :. Exp (SmartExp $ Prj PairIdxRight t) -- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of the -- (unremarkable) boilerplate for us, but since the implementation is a little @@ -278,53 +277,42 @@ instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where -- $(runQ $ do let - mkIsPattern' :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] - mkIsPattern' con cst tup prj nil snoc n = + -- Generate instance declarations for IsPattern of the form: + -- instance (Elt x, EltRepr x ~ (((), EltRepr a), EltRepr b), Elt a, Elt b,) => IsPattern Exp x (Exp a, Exp b) + mkIsPattern :: Name -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] + mkIsPattern _ _ _ _ _ _ _ 1 = return [] + mkIsPattern con cst repr smart prj nil pair n = do + a <- newName "a" let - xs = [ mkName ('x' : show i) | i <- [0 .. n-1]] - b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs - repr = foldl (\ts t -> [t| ($ts, $(varT t)) |]) [t| () |] xs - context = foldl (\ts t -> appT ts (appT cst (varT t))) (tupleT n) xs - -- - tix 0 = [| ZeroTupIdx |] - tix i = [| SuccTupIdx $(tix (i-1)) |] - get x i = [| $(conE con) ($prj $(tix i) $x) |] - in - [d| instance - ( IsProduct $cst a - , ProdRepr a ~ $repr - , $cst a - , $context - ) => IsPattern $(conT con) a $b where - construct $(tupP (map varP xs)) = $(conE con) ($tup $(foldl (\vs v -> appE (appE snoc vs) (varE v)) nil xs)) - destruct _x = $(tupE (map (get [|_x|]) [(n-1), (n-2) .. 0])) - |] - - mkIsPattern :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] - mkIsPattern _ _ _ _ _ _ 1 = return [] - mkIsPattern con cst smart prj nil pair n = do - let - xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - a = foldl (\ts t -> appT ts (varT t)) (tupleT n) xs - b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs - context = foldl (\ts t -> appT ts (appT cst (varT t))) (tupleT n) xs + -- Type variables for the elements + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + -- Last argument to `IsPattern`, eg (Exp, a, Exp b) in the example + b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs + -- Representation as snoc-list of pairs, eg (((), EltRepr a), EltRepr b) + snoc = foldl (\sn t -> [t| ($sn, $(appT repr $ varT t)) |]) [t| () |] xs + -- Constraints for the type class, consisting of Elt constraints on all type variables, + -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`. + contexts = appT cst [t| $(varT a) |] + : [t| $repr $(varT a) ~ $snoc |] + : map (\t -> appT cst (varT t)) xs + -- Store all constraints in a tuple + context = foldl (\ts t -> appT ts t) (tupleT $ length contexts) contexts -- get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) -- _x <- newName "_x" - [d| instance $context => IsPattern $(conT con) $a $b where + [d| instance $context => IsPattern $(conT con) $(varT a) $b where construct $(tupP (map (conP con . return . varP) xs)) = $(conE con) $(foldl (\vs v -> appE smart (appE (appE pair vs) (varE v))) (appE smart nil) xs) destruct $(conP con [varP _x]) = $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0])) |] - mkExpPattern = mkIsPattern' (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] - mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] + mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [t| EltRepr |] [| SmartExp |] [| Prj |] [| Nil |] [| Pair |] + mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [t| ArrRepr |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] -- es <- mapM mkExpPattern [0..16] as <- mapM mkAccPattern [0..16] return $ concat (es ++ as) ) - diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 92ee22af2..88559589d 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -698,7 +698,7 @@ fold1All f arr = fold1 f (flatten arr) -- 40, 170, 0, 138] -- foldSeg - :: forall sh e i. (Shape sh, Elt e, Elt i, IsIntegral i) + :: forall sh e i. (Shape sh, Elt e, Elt i, i ~ EltRepr i, IsIntegral i) => (Exp e -> Exp e -> Exp e) -> Exp e -> Acc (Array (sh:.Int) e) @@ -725,15 +725,17 @@ foldSeg f z arr seg = foldSeg' f z arr (scanl plus zero seg) -- descriptor species the length of each of the logical sub-arrays. -- fold1Seg - :: forall sh e i. (Shape sh, Elt e, Elt i, IsIntegral i) + :: forall sh e i. (Shape sh, Elt e, Elt i, i ~ EltRepr i, IsIntegral i) => (Exp e -> Exp e -> Exp e) -> Acc (Array (sh:.Int) e) -> Acc (Segments i) -> Acc (Array (sh:.Int) e) fold1Seg f arr seg = fold1Seg' f arr (scanl plus zero seg) where + plus :: Exp i -> Exp i -> Exp i + zero :: Exp i (plus, zero) = - case integralType @i of + case integralType @(EltRepr i) of TypeInt{} -> ((+), 0) TypeInt8{} -> ((+), 0) TypeInt16{} -> ((+), 0) diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 8a1123651..565b4b33a 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -44,8 +44,9 @@ import qualified Data.HashSet as Set import qualified Data.Sequence as Seq -- friends -import Data.Array.Accelerate.AST ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), PreBoundary(..), LeftHandSide(..), ArrayVar(..), Idx(..) ) -import Data.Array.Accelerate.Array.Sugar ( Array, Elt, Tuple(..), ArraysR(..), toElt, strForeign ) +import Data.Array.Accelerate.AST hiding ( Val(..), prj ) +import Data.Array.Accelerate.Array.Representation +import Data.Array.Accelerate.Array.Sugar ( strForeign, TupR(..) ) import Data.Array.Accelerate.Error import Data.Array.Accelerate.Pretty.Graphviz.Monad import Data.Array.Accelerate.Pretty.Graphviz.Type @@ -195,7 +196,7 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = Avar ix -> pnode (avar ix) Alet lhs bnd body -> do bnd'@(PNode ident _ _) <- prettyDelayedOpenAcc detail context0 aenv bnd - (aenv1, a) <- prettyLetLeftHandSide ident aenv lhs + (aenv1, a) <- prettyLetALeftHandSide ident aenv lhs _ <- mkNode bnd' (Just a) body' <- prettyDelayedOpenAcc detail context0 aenv1 body return body' @@ -227,19 +228,19 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = Anil -> "()" .$ [] - Use arr -> "use" .$ [ return $ PDoc (prettyArray arr) [] ] + Use repr arr -> "use" .$ [ return $ PDoc (prettyArray repr arr) [] ] Unit e -> "unit" .$ [ ppE e ] - Generate sh f -> "generate" .$ [ ppE sh, ppF f ] - Transform sh ix f xs -> "transform" .$ [ ppE sh, ppF ix, ppF f, ppA xs ] - Reshape sh xs -> "reshape" .$ [ ppE sh, ppA xs ] + Generate _ sh f -> "generate" .$ [ ppE sh, ppF f ] + Transform _ sh ix f xs -> "transform" .$ [ ppE sh, ppF ix, ppF f, ppA xs ] + Reshape _ sh xs -> "reshape" .$ [ ppE sh, ppA xs ] Replicate _ty ix xs -> "replicate" .$ [ ppE ix, ppA xs ] Slice _ty xs ix -> "slice" .$ [ ppA xs, ppE ix ] - Map f xs -> "map" .$ [ ppF f, ppA xs ] - ZipWith f xs ys -> "zipWith" .$ [ ppF f, ppA xs, ppA ys ] + 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 ] + 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 ] @@ -247,10 +248,11 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = 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" .$ [ ppE 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 ] + Backpermute _ sh p xs -> "backpermute" .$ [ ppE sh, ppF p, ppA xs ] + Stencil s _ sten bndy xs + -> "stencil" .$ [ ppF sten, ppB (stencilElt s) bndy, ppA xs ] + Stencil2 s1 s2 _ sten bndy1 acc1 bndy2 acc2 + -> "stencil2" .$ [ ppF sten, ppB (stencilElt s1) bndy1, ppA acc1, ppB (stencilElt s2) bndy2, ppA acc2 ] Aforeign ff _afun xs -> "aforeign" .$ [ return (PDoc (pretty (strForeign ff)) []), {- ppAf afun, -} ppA xs ] -- Collect{} -> error "Collect" @@ -279,8 +281,8 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = -- Free variables -- fvA :: FVAcc DelayedOpenAcc - fvA env (Manifest (Avar (ArrayVar ix))) = [ Vertex (fst $ aprj ix env) Nothing ] - fvA _ _ = $internalError "graphviz" "expected array variable" + fvA env (Manifest (Avar (Var _ ix))) = [ Vertex (fst $ aprj ix env) Nothing ] + fvA _ _ = $internalError "graphviz" "expected array variable" fvF :: DelayedFun aenv t -> [Vertex] fvF = fvPreOpenFun fvA Empty aenv @@ -291,7 +293,7 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = -- Pretty-printing -- avar :: ArrayVar aenv t -> PDoc - avar (ArrayVar ix) = let (ident, v) = aprj ix aenv + avar (Var _ ix) = let (ident, v) = aprj ix aenv in PDoc (pretty v) [Vertex ident Nothing] aenv' :: Val aenv @@ -306,22 +308,24 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = v <- mkLabel ident <- mkNode acc' (Just v) return $ PDoc (pretty 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 (Delayed _ sh f _) + | Shape a <- sh -- identical shape + , Just b <- isIdentityIndexing f -- function is `\ix -> b ! ix` + , Just Refl <- match a b -- function thus is `\ix -> a ! ix` = ppA a - ppA (Delayed sh f _) = do + ppA (Delayed _ sh f _) = do PDoc d v <- "Delayed" `fmt` [ ppE sh, ppF f ] return $ PDoc (parens d) v - ppB :: forall sh e. Elt e - => PreBoundary DelayedOpenAcc aenv (Array sh e) + ppB :: forall sh e. + TupleType 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 (prettyConst (toElt e :: e)) []) - ppB (Function f) = ppF f + ppB _ Clamp = return (PDoc "clamp" []) + ppB _ Mirror = return (PDoc "mirror" []) + ppB _ Wrap = return (PDoc "wrap" []) + ppB tp (Constant e) = return (PDoc (prettyConst tp e) []) + ppB _ (Function f) = ppF f ppF :: DelayedFun aenv t -> Dot PDoc ppF = return . uncurry PDoc . (parens . prettyDelayedFun aenv' &&& fvF) @@ -330,9 +334,9 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = ppE = return . uncurry PDoc . (prettyDelayedExp aenv' &&& fvE) lift :: DelayedOpenAcc aenv a -> Dot Vertex - lift Delayed{} = $internalError "prettyDelayedOpenAcc" "expected manifest array" - lift (Manifest (Avar (ArrayVar ix))) = return $ Vertex (fst (aprj ix aenv)) Nothing - lift acc = do + lift Delayed{} = $internalError "prettyDelayedOpenAcc" "expected manifest array" + lift (Manifest (Avar (Var _ ix))) = return $ Vertex (fst (aprj ix aenv)) Nothing + lift acc = do acc' <- prettyDelayedOpenAcc detail context0 aenv acc ident <- mkNode acc' Nothing return $ Vertex ident Nothing @@ -381,46 +385,46 @@ prettyDelayedAfun detail aenv afun = do go :: Aval aenv' -> DelayedOpenAfun aenv' a' -> Dot Graph go aenv' (Abody b) = graphDelayedOpenAcc detail aenv' b go aenv' (Alam lhs f) = do - aenv'' <- prettyLambdaLeftHandSide aenv' lhs + aenv'' <- prettyLambdaALeftHandSide aenv' lhs go aenv'' f collect :: Aval aenv' -> HashSet NodeId collect Aempty = Set.empty collect (Apush a i _) = Set.insert i (collect a) -prettyLetLeftHandSide +prettyLetALeftHandSide :: forall repr aenv aenv'. NodeId -> Aval aenv - -> LeftHandSide repr aenv aenv' + -> ALeftHandSide repr aenv aenv' -> Dot (Aval aenv', Label) -prettyLetLeftHandSide _ aenv (LeftHandSideWildcard repr) = return (aenv, doc) +prettyLetALeftHandSide _ aenv (LeftHandSideWildcard repr) = return (aenv, doc) where doc = case repr of - ArraysRunit -> "()" - _ -> "_" -prettyLetLeftHandSide ident aenv LeftHandSideArray = do + TupRunit -> "()" + _ -> "_" +prettyLetALeftHandSide ident aenv (LeftHandSideSingle _) = do a <- mkLabel return (Apush aenv ident a, a) -prettyLetLeftHandSide ident aenv (LeftHandSidePair lhs1 lhs2) = do - (aenv1, d1) <- prettyLetLeftHandSide ident aenv lhs1 - (aenv2, d2) <- prettyLetLeftHandSide ident aenv1 lhs2 +prettyLetALeftHandSide ident aenv (LeftHandSidePair lhs1 lhs2) = do + (aenv1, d1) <- prettyLetALeftHandSide ident aenv lhs1 + (aenv2, d2) <- prettyLetALeftHandSide ident aenv1 lhs2 return (aenv2, "(" <> d1 <> ", " <> d2 <> ")") -prettyLambdaLeftHandSide +prettyLambdaALeftHandSide :: forall repr aenv aenv'. Aval aenv - -> LeftHandSide repr aenv aenv' + -> ALeftHandSide repr aenv aenv' -> Dot (Aval aenv') -prettyLambdaLeftHandSide aenv (LeftHandSideWildcard _) = return aenv -prettyLambdaLeftHandSide aenv lhs@LeftHandSideArray = do +prettyLambdaALeftHandSide aenv (LeftHandSideWildcard _) = return aenv +prettyLambdaALeftHandSide aenv lhs@(LeftHandSideSingle _) = do a <- mkLabel ident <- mkNodeId lhs _ <- mkNode (PNode ident (Leaf (Nothing, pretty a)) []) Nothing return $ Apush aenv ident a -prettyLambdaLeftHandSide aenv (LeftHandSidePair lhs1 lhs2) = do - aenv1 <- prettyLambdaLeftHandSide aenv lhs1 - prettyLambdaLeftHandSide aenv1 lhs2 +prettyLambdaALeftHandSide aenv (LeftHandSidePair lhs1 lhs2) = do + aenv1 <- prettyLambdaALeftHandSide aenv lhs1 + prettyLambdaALeftHandSide aenv1 lhs2 -- Display array tuples. This is a little tricky... -- @@ -501,9 +505,9 @@ prettyDelayedOpenFun env0 aenv = next "\\\\" env0 next vs env (Body body) = nest shiftwidth (sep [ vs <> "→" , prettyDelayedOpenExp context0 env aenv body ]) - next vs env (Lam lam) = - let x = pretty 'x' <> pretty (sizeEnv env) - in next (vs <> x <> space) (env `Push` x) lam + next vs env (Lam lhs lam) = + let (env', arg) = prettyLHS env lhs + in next (vs <> arg <> space) env' lam prettyDelayedOpenExp :: Context @@ -514,8 +518,8 @@ prettyDelayedOpenExp prettyDelayedOpenExp context = prettyPreOpenExp context pp ex where pp :: PrettyAcc DelayedOpenAcc - pp _ aenv (Manifest (Avar (ArrayVar ix))) = prj ix aenv - pp _ _ _ = $internalError "prettyDelayedOpenExp" "expected array variable" + pp _ aenv (Manifest (Avar (Var _ ix))) = prj ix aenv + pp _ _ _ = $internalError "prettyDelayedOpenExp" "expected array variable" ex :: ExtractAcc DelayedOpenAcc ex (Manifest pacc) = pacc @@ -539,8 +543,10 @@ fvPreOpenFun -> 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` (pretty 'x' <> pretty (sizeEnv env))) aenv f +fvPreOpenFun fvA env aenv (Body b) = fvPreOpenExp fvA env aenv b +fvPreOpenFun fvA env aenv (Lam lhs f) = fvPreOpenFun fvA env' aenv f + where + (env', _) = prettyLHS env lhs fvPreOpenExp :: forall acc env aenv exp. @@ -551,10 +557,6 @@ fvPreOpenExp -> [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 @@ -563,28 +565,23 @@ fvPreOpenExp fvA env aenv = fv 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` (pretty 'x' <> pretty (sizeEnv env))) aenv e2 ] - fv Var{} = [] - fv Undef = [] + fv (Let lhs e1 e2) = concat [ fv e1, fvPreOpenExp fvA env' aenv e2 ] + where + (env', _) = prettyLHS env lhs + fv Evar{} = [] + 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 (Pair e1 e2) = concat [ fv e1, fv e2] + fv Nil = [] 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 (ToIndex _ sh ix) = concat [ fv sh, fv ix ] + fv (FromIndex _ sh ix) = concat [ fv sh, fv ix ] + 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 + fv (Coerce _ _ e) = fv e diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 0aff9340d..3390e94cb 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -29,6 +29,7 @@ module Data.Array.Accelerate.Pretty.Print ( prettyPreOpenFun, prettyArray, prettyConst, + prettyLHS, -- ** Internals Adoc, @@ -53,11 +54,11 @@ import Data.Char import Data.String import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal -import Data.Typeable ( Typeable, typeOf, showsTypeRep ) import Prelude hiding ( exp ) import Data.Array.Accelerate.AST hiding ( Val(..), prj ) -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Sugar ( strForeign ) +import Data.Array.Accelerate.Array.Representation import Data.Array.Accelerate.Type @@ -113,7 +114,7 @@ prettyPreOpenAfun prettyAcc aenv0 = next (pretty '\\') aenv0 next vs aenv (Abody body) = hang shiftwidth (sep [vs <> "->", prettyAcc context0 aenv body]) next vs aenv (Alam lhs lam) = let (aenv', lhs') = prettyLHS aenv lhs - in next (vs <> lhs' <> space) aenv' lam + in next (vs <> lhs' <> space) aenv' lam prettyPreOpenAcc :: forall acc aenv arrs. @@ -125,7 +126,7 @@ prettyPreOpenAcc -> Adoc prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = case pacc of - Avar (ArrayVar idx) -> prj idx aenv + Avar (Var _ idx) -> prj idx aenv Alet{} -> prettyAlet ctx prettyAcc extractAcc aenv pacc Apair{} -> prettyAtuple prettyAcc extractAcc aenv pacc Anil -> "()" @@ -149,19 +150,19 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = Aforeign ff _f a -> "aforeign" .$ [ pretty (strForeign ff), ppA a ] Awhile p f a -> "awhile" .$ [ ppAF p, ppAF f, ppA a ] - Use arr -> "use" .$ [ prettyArray arr ] + Use repr arr -> "use" .$ [ prettyArray repr arr ] Unit e -> "unit" .$ [ ppE e ] - Reshape sh a -> "reshape" .$ [ ppE sh, ppA a ] - Generate sh f -> "generate" .$ [ ppE sh, ppF f ] - Transform sh p f a -> "transform" .$ [ ppE sh, ppF p, ppF f, ppA a ] + Reshape _ sh a -> "reshape" .$ [ ppE sh, ppA a ] + Generate _ sh f -> "generate" .$ [ ppE sh, ppF f ] + Transform _ sh p f a -> "transform" .$ [ ppE sh, ppF p, ppF f, ppA a ] Replicate _ ix a -> "replicate" .$ [ ppE ix, ppA a ] Slice _ a ix -> "slice" .$ [ ppE ix, ppA a ] - Map f a -> "map" .$ [ ppF f, ppA a ] - ZipWith f a b -> "zipWith" .$ [ ppF f, ppA a, ppA b ] + Map _ f a -> "map" .$ [ ppF f, ppA a ] + ZipWith _ f a b -> "zipWith" .$ [ ppF f, ppA a, ppA b ] Fold f z a -> "fold" .$ [ ppF f, ppE z, ppA a ] Fold1 f a -> "fold1" .$ [ ppF f, ppA a ] - FoldSeg f z a s -> "foldSeg" .$ [ ppF f, ppE z, ppA a, ppA s ] - Fold1Seg f a s -> "fold1Seg" .$ [ ppF f, ppA a, ppA s ] + FoldSeg _ f z a s -> "foldSeg" .$ [ ppF f, ppE z, ppA a, ppA s ] + Fold1Seg _ f a s -> "fold1Seg" .$ [ ppF f, ppA a, ppA s ] Scanl f z a -> "scanl" .$ [ ppF f, ppE z, ppA a ] Scanl' f z a -> "scanl'" .$ [ ppF f, ppE z, ppA a ] Scanl1 f a -> "scanl1" .$ [ ppF f, ppA a ] @@ -169,9 +170,10 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = Scanr' f z a -> "scanr'" .$ [ ppF f, ppE z, ppA a ] Scanr1 f a -> "scanr1" .$ [ ppF f, ppA a ] Permute f d p s -> "permute" .$ [ ppF f, ppA d, ppF p, ppA s ] - Backpermute sh f a -> "backpermute" .$ [ ppE sh, ppF f, ppA a ] - Stencil f b a -> "stencil" .$ [ ppF f, ppB b, ppA a ] - Stencil2 f b1 a1 b2 a2 -> "stencil2" .$ [ ppF f, ppB b1, ppA a1, ppB b2, ppA a2 ] + Backpermute _ sh f a -> "backpermute" .$ [ ppE sh, ppF f, ppA a ] + Stencil s _ f b a -> "stencil" .$ [ ppF f, ppB (stencilElt s) b, ppA a ] + Stencil2 s1 s2 _ f b1 a1 b2 a2 + -> "stencil2" .$ [ ppF f, ppB (stencilElt s1) b1, ppA a1, ppB (stencilElt s2) b2, ppA a2 ] where infixr 0 .$ f .$ xs @@ -190,14 +192,15 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = ppF :: PreFun acc aenv t -> Adoc ppF = parens . prettyPreOpenFun prettyAcc extractAcc Empty aenv - ppB :: forall sh e. Elt e - => PreBoundary acc aenv (Array sh e) + ppB :: forall sh e. + TupleType e + -> PreBoundary acc aenv (Array sh e) -> Adoc - ppB Clamp = "clamp" - ppB Mirror = "mirror" - ppB Wrap = "wrap" - ppB (Constant e) = prettyConst (toElt e :: e) - ppB (Function f) = ppF f + ppB _ Clamp = "clamp" + ppB _ Mirror = "mirror" + ppB _ Wrap = "wrap" + ppB tp (Constant e) = prettyConst tp e + ppB _ (Function f) = ppF f prettyAlet @@ -263,25 +266,26 @@ prettyAtuple prettyAcc extractAcc aenv0 Apair a1 a2 -> collect aenv (extractAcc a1) ++ [prettyAcc context0 aenv a2] next -> [prettyPreOpenAcc context0 prettyAcc extractAcc aenv next] -prettyLHS :: Val aenv -> LeftHandSide arrs aenv aenv' -> (Val aenv', Adoc) -prettyLHS aenv0 = fmap wrap . go aenv0 +-- TODO: Should we also print the types of the declared variables? And the types of wildcards? +prettyLHS :: Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) +prettyLHS env0 = fmap wrap . go env0 where wrap [x] = x wrap xs = tupled xs - go :: Val aenv -> LeftHandSide arrs aenv aenv' -> (Val aenv', [Adoc]) - go aenv (LeftHandSideWildcard ArraysRunit) = (aenv, []) - go aenv (LeftHandSideWildcard _) = (aenv, ["_"]) - go aenv LeftHandSideArray = (aenv `Push` v, [v]) + go :: Val env -> LeftHandSide s arrs env env' -> (Val env', [Adoc]) + go env (LeftHandSideWildcard TupRunit) = (env, ["()"]) + go env (LeftHandSideWildcard _) = (env, ["_"]) + go env (LeftHandSideSingle _) = (env `Push` v, [v]) where - v = pretty 'a' <> pretty (sizeEnv aenv) - go aenv (LeftHandSidePair a b) = (aenv2, doc1 ++ [doc2]) + v = pretty 'a' <> pretty (sizeEnv env) + go env (LeftHandSidePair a b) = (env2, doc1 ++ [doc2]) where - (aenv1, doc1) = go aenv a - (aenv2, doc2) = prettyLHS aenv1 b + (env1, doc1) = go env a + (env2, doc2) = prettyLHS env1 b -prettyArray :: (Shape sh, Elt e) => Array sh e -> Adoc -prettyArray = parens . viaShow +prettyArray :: ArrayR (Array sh e) -> Array sh e -> Adoc +prettyArray repr = parens . fromString . showArray repr -- Scalar expressions @@ -309,9 +313,9 @@ prettyPreOpenFun prettyAcc extractAcc env0 aenv = next (pretty '\\') env0 -- = hang shiftwidth (sep [ vs <> "->" , prettyPreOpenExp context0 prettyAcc extractAcc env aenv body]) - next vs env (Lam lam) = - let x = pretty 'x' <> pretty (sizeEnv env) - in next (vs <> x <> space) (env `Push` x) lam + next vs env (Lam lhs lam) = + let (env', lhs') = prettyLHS env lhs + in next (vs <> lhs' <> space) env' lam prettyPreOpenExp :: forall acc env aenv t. @@ -324,19 +328,19 @@ prettyPreOpenExp -> Adoc prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = case exp of - Var idx -> prj idx env + Evar (Var _ idx) -> prj idx env Let{} -> prettyLet ctx prettyAcc extractAcc env aenv exp PrimApp f x - | Tuple (NilTup `SnocTup` a `SnocTup` b) <- x -> ppF2 op (ppE a) (ppE b) - | otherwise -> ppF1 op' (ppE x) + | Nil `Pair` a `Pair` b <- x -> ppF2 op (ppE a) (ppE b) + | otherwise -> ppF1 op' (ppE x) where op = primOperator f op' = isInfix op ? (Operator (parens (opName op)) App L 10, op) -- PrimConst c -> prettyPrimConst c - Const c -> prettyConst (toElt c :: t) - Tuple t -> prettyTuple (eltType @t) prettyAcc extractAcc env aenv t - Prj tix e -> ppF2 (Operator "#" Infix L 8) (ppE e) (\_ -> pretty (tupleIdxToInt tix)) + Const tp c -> prettyConst (TupRsingle tp) c + Pair{} -> prettyTuple prettyAcc extractAcc env aenv exp + Nil -> "()" Cond p t e -> flatAlt multi single where p' = ppE p context0 @@ -350,25 +354,18 @@ prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = , hang shiftwidth (sep [ then_, t' ]) , hang shiftwidth (sep [ else_, e' ]) ] -- - IndexAny -> "Any" - IndexNil -> pretty 'Z' - IndexCons sh sz -> ppF2 (Operator ":." Infix L 3) (ppE sh) (ppE sz) - IndexHead sh -> ppF1 "indexHead" (ppE sh) - IndexTail sh -> ppF1 "indexTail" (ppE sh) IndexSlice _ slix sh -> ppF2 "indexSlice" (ppE slix) (ppE sh) IndexFull _ slix sl -> ppF2 "indexFull" (ppE slix) (ppE sl) - ToIndex sh ix -> ppF2 "toIndex" (ppE sh) (ppE ix) - FromIndex sh ix -> ppF2 "fromIndex" (ppE sh) (ppE ix) + ToIndex _ sh ix -> ppF2 "toIndex" (ppE sh) (ppE ix) + FromIndex _ sh ix -> ppF2 "fromIndex" (ppE sh) (ppE ix) While p f x -> ppF3 "while" (ppF p) (ppF f) (ppE x) Foreign ff _f e -> ppF2 "foreign" (\_ -> pretty (strForeign ff)) (ppE e) Shape arr -> ppF1 "shape" (ppA arr) - ShapeSize sh -> ppF1 "shapeSize" (ppE sh) - Intersect sh1 sh2 -> ppF2 "intersect" (ppE sh1) (ppE sh2) - Union sh1 sh2 -> ppF2 "union" (ppE sh1) (ppE sh2) + ShapeSize _ sh -> ppF1 "shapeSize" (ppE sh) Index arr ix -> ppF2 (Operator (pretty '!') Infix L 9) (ppA arr) (ppE ix) LinearIndex arr ix -> ppF2 (Operator "!!" Infix L 9) (ppA arr) (ppE ix) - Coerce x -> ppF1 (Operator (withTypeRep "coerce") App L 10) (ppE x) - Undef -> withTypeRep "undef" + Coerce _ tp x -> ppF1 (Operator (withTypeRep tp "coerce") App L 10) (ppE x) + Undef tp -> withTypeRep tp "undef" where ppE :: PreOpenExp acc env aenv e -> Context -> Adoc @@ -401,8 +398,8 @@ prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = $ hang 2 $ sep [ opName op, x app, y app, z app ] - withTypeRep :: Typeable t => Adoc -> Adoc - withTypeRep op = op <> enclose langle rangle (pretty (showsTypeRep (typeOf (undefined::t)) "")) + withTypeRep :: ScalarType t -> Adoc -> Adoc + withTypeRep tp op = op <> enclose langle rangle (pretty (showScalarType tp)) prettyLet @@ -421,9 +418,8 @@ prettyLet ctx prettyAcc extractAcc env0 aenv collect :: Val env' -> PreOpenExp acc env' aenv e -> ([Adoc], Adoc) collect env = \case - Let e1 e2 -> - let env' = env `Push` v - v = pretty 'x' <> pretty (sizeEnv env) + Let lhs e1 e2 -> + let (env', v) = prettyLHS env lhs e1' = ppE env e1 bnd | isLet e1 = nest shiftwidth (vsep [v <+> equals, e1']) | otherwise = v <+> align (equals <+> e1') @@ -451,30 +447,29 @@ prettyLet ctx prettyAcc extractAcc env0 aenv ] prettyTuple - :: forall acc env aenv t p. - TupleType t - -> PrettyAcc acc + :: forall acc env aenv t. + PrettyAcc acc -> ExtractAcc acc -> Val env -> Val aenv - -> Tuple (PreOpenExp acc env aenv) p + -> PreOpenExp acc env aenv t -> Adoc -prettyTuple tt prettyAcc extractAcc env aenv = wrap . collect [] +prettyTuple prettyAcc extractAcc env aenv = wrap . collect [] where - collect :: [Adoc] -> Tuple (PreOpenExp acc env aenv) s -> [Adoc] + wrap [x] = x + wrap xs = tupled xs + + collect :: [Adoc] -> PreOpenExp acc env aenv s -> [Adoc] collect acc = \case - NilTup -> acc - SnocTup tup e -> collect (align (prettyPreOpenExp context0 prettyAcc extractAcc env aenv e) : acc) tup - -- - wrap - | TypeRscalar VectorScalarType{} <- tt = group . encloseSep (flatAlt "< " "<") (flatAlt " >" ">") ", " - | otherwise = tupled -- as above, with parenthesis + Nil -> acc + Pair tup e -> collect (align (prettyPreOpenExp context0 prettyAcc extractAcc env aenv e) : acc) tup + next -> [prettyPreOpenExp context0 prettyAcc extractAcc env aenv next] -prettyConst :: Elt e => e -> Adoc -prettyConst x = - let y = show x +prettyConst :: TupleType e -> e -> Adoc +prettyConst tp x = + let y = showElement tp x in parensIf (any isSpace y) (pretty y) prettyPrimConst :: PrimConst a -> Adoc diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 942373136..c01c5c1c8 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -27,8 +27,8 @@ module Data.Array.Accelerate.Smart ( -- * HOAS AST - Acc(..), SmartAcc(..), PreSmartAcc(..), PairIdx(..), Exp(..), PreExp(..), - Boundary(..), PreBoundary(..), Stencil(..), Level, + Acc(..), SmartAcc(..), PreSmartAcc(..), PairIdx(..), Exp(..), SmartExp(..), PreSmartExp(..), + Boundary(..), PreBoundary(..), Stencil(..), Level, unExp, -- * Smart constructors for literals constant, undef, @@ -43,6 +43,8 @@ module Data.Array.Accelerate.Smart ( 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, + prj0, prj1, + -- * Smart constructors for constants mkMinBound, mkMaxBound, mkPi, mkSin, mkCos, mkTan, @@ -61,10 +63,10 @@ module Data.Array.Accelerate.Smart ( mkLAnd, mkLOr, mkLNot, mkIsNaN, mkIsInfinite, -- * Smart constructors for type coercion functions - mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkUnsafeCoerce, + mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkCoerce, Coerce, -- * Auxiliary functions - ($$), ($$$), ($$$$), ($$$$$), unAcc, unAccFunction, ApplyAcc(..), + ($$), ($$$), ($$$$), ($$$$$), unAcc, unAccFunction, ApplyAcc(..), exp, unPair, HasExpType(..), HasArraysRepr(..), -- Debugging showPreAccOp, showPreExpOp, @@ -72,20 +74,19 @@ module Data.Array.Accelerate.Smart ( ) where -- standard library -import Prelude hiding ( exp ) +import Prelude hiding ( exp ) import Data.Kind 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 - +import Data.Array.Accelerate.Array.Sugar (Elt, Arrays, EltRepr, ArrRepr, (:.), Foreign, eltType, fromElt, DIM1) +import qualified Data.Array.Accelerate.Array.Sugar as Sugar +import Data.Array.Accelerate.Array.Representation hiding (DIM1) +import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc + , PreOpenExp(..), OpenExp, PreExp, Exp + , PreBoundary(..), Boundary, HasArraysRepr(..), expType + , showPreAccOp, showPreExpOp ) -- Array computations -- ------------------ @@ -274,7 +275,7 @@ import qualified Data.Array.Accelerate.AST as AST -- newtype Acc a = Acc (SmartAcc (ArrRepr a)) -newtype SmartAcc a = SmartAcc (PreSmartAcc SmartAcc Exp a) +newtype SmartAcc a = SmartAcc (PreSmartAcc SmartAcc SmartExp a) deriving instance Typeable Acc @@ -287,32 +288,30 @@ type Level = Int -- data PreSmartAcc acc exp as where -- Needed for conversion to de Bruijn form - Atag :: Typeable as - => Level -- environment size at defining occurrence + Atag :: ArraysR as + -> Level -- environment size at defining occurrence -> PreSmartAcc acc exp as - Pipe :: (Typeable as, Typeable bs, Typeable cs) - => ArraysR as + Pipe :: ArraysR as -> ArraysR bs + -> ArraysR cs -> (SmartAcc as -> acc bs) -> (SmartAcc bs -> acc cs) -> acc as -> PreSmartAcc acc exp cs - Aforeign :: (Typeable (ArrRepr as), Typeable (ArrRepr bs), Arrays as, Arrays bs, Foreign asm) + Aforeign :: (Arrays as, Arrays bs, Foreign asm) => asm (as -> bs) -> (Acc as -> Acc bs) -> acc (ArrRepr as) -> PreSmartAcc acc exp (ArrRepr bs) - Acond :: Typeable as - => exp Bool + Acond :: exp Bool -> acc as -> acc as -> PreSmartAcc acc exp as - Awhile :: Typeable arrs - => ArraysR arrs + Awhile :: ArraysR arrs -> (SmartAcc arrs -> acc (Scalar Bool)) -> (SmartAcc arrs -> acc arrs) -> acc arrs @@ -320,134 +319,140 @@ data PreSmartAcc acc exp as where Anil :: PreSmartAcc acc exp () - Apair :: (Typeable arrs1, Typeable arrs2) - => acc arrs1 + Apair :: acc arrs1 -> acc arrs2 -> PreSmartAcc acc exp (arrs1, arrs2) - Aprj :: (Typeable arrs1, Typeable arrs2) - => PairIdx (arrs1, arrs2) arrs + Aprj :: PairIdx (arrs1, arrs2) arrs -> acc (arrs1, arrs2) -> PreSmartAcc acc exp arrs - Use :: (Shape sh, Elt e) - => Array sh e + Use :: ArrayR (Array sh e) + -> Array sh e -> PreSmartAcc acc exp (Array sh e) - Unit :: Elt e - => exp e + Unit :: TupleType e + -> exp e -> PreSmartAcc acc exp (Scalar e) - Generate :: (Shape sh, Elt e) - => exp sh - -> (Exp sh -> exp e) + Generate :: ArrayR (Array sh e) + -> exp sh + -> (SmartExp sh -> exp e) -> PreSmartAcc acc exp (Array sh e) - Reshape :: (Shape sh, Shape sh', Elt e) - => exp sh + Reshape :: ShapeR sh + -> exp sh -> acc (Array sh' e) -> PreSmartAcc acc exp (Array sh e) - Replicate :: (Slice slix, Elt e) - => exp slix - -> acc (Array (SliceShape slix) e) - -> PreSmartAcc acc exp (Array (FullShape slix) e) + Replicate :: SliceIndex slix sl co sh + -> exp slix + -> acc (Array sl e) + -> PreSmartAcc acc exp (Array sh e) - Slice :: (Slice slix, Elt e) - => acc (Array (FullShape slix) e) + Slice :: SliceIndex slix sl co sh + -> acc (Array sh e) -> exp slix - -> PreSmartAcc acc exp (Array (SliceShape slix) e) + -> PreSmartAcc acc exp (Array sl e) - Map :: (Shape sh, Elt e, Elt e') - => (Exp e -> exp e') + Map :: TupleType e + -> TupleType e' + -> (SmartExp e -> exp e') -> acc (Array sh e) -> PreSmartAcc acc exp (Array sh e') - ZipWith :: (Shape sh, Elt e1, Elt e2, Elt e3) - => (Exp e1 -> Exp e2 -> exp e3) + ZipWith :: TupleType e1 + -> TupleType e2 + -> TupleType e3 + -> (SmartExp e1 -> SmartExp e2 -> exp e3) -> acc (Array sh e1) -> acc (Array sh e2) -> PreSmartAcc acc exp (Array sh e3) - Fold :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) + Fold :: TupleType e + -> (SmartExp e -> SmartExp e -> exp e) -> exp e - -> acc (Array (sh:.Int) e) + -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array sh e) - Fold1 :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) - -> acc (Array (sh:.Int) e) + Fold1 :: TupleType e + -> (SmartExp e -> SmartExp e -> exp e) + -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array sh e) - FoldSeg :: (Shape sh, Elt e, Elt i, IsIntegral i) - => (Exp e -> Exp e -> exp e) + FoldSeg :: IntegralType i + -> TupleType e + -> (SmartExp e -> SmartExp e -> exp e) -> exp e - -> acc (Array (sh:.Int) e) + -> acc (Array (sh, Int) e) -> acc (Segments i) - -> PreSmartAcc acc exp (Array (sh:.Int) e) + -> PreSmartAcc 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) + Fold1Seg :: IntegralType i + -> TupleType e + -> (SmartExp e -> SmartExp e -> exp e) + -> acc (Array (sh, Int) e) -> acc (Segments i) - -> PreSmartAcc acc exp (Array (sh:.Int) e) + -> PreSmartAcc acc exp (Array (sh, Int) e) - Scanl :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) + Scanl :: TupleType e + -> (SmartExp e -> SmartExp e -> exp e) -> exp e - -> acc (Array (sh :. Int) e) - -> PreSmartAcc acc exp (Array (sh :. Int) e) + -> acc (Array (sh, Int) e) + -> PreSmartAcc acc exp (Array (sh, Int) e) - Scanl' :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) + Scanl' :: TupleType e + -> (SmartExp e -> SmartExp e -> exp e) -> exp e - -> acc (Array (sh :. Int) e) - -> PreSmartAcc acc exp (ArrRepr (Array (sh :. Int) e, Array sh e)) + -> acc (Array (sh, Int) e) + -> PreSmartAcc 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) - -> PreSmartAcc acc exp (Array (sh :. Int) e) + Scanl1 :: TupleType e + -> (SmartExp e -> SmartExp e -> exp e) + -> acc (Array (sh, Int) e) + -> PreSmartAcc acc exp (Array (sh, Int) e) - Scanr :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) + Scanr :: TupleType e + -> (SmartExp e -> SmartExp e -> exp e) -> exp e - -> acc (Array (sh :. Int) e) - -> PreSmartAcc acc exp (Array (sh :. Int) e) + -> acc (Array (sh, Int) e) + -> PreSmartAcc acc exp (Array (sh, Int) e) - Scanr' :: (Shape sh, Elt e) - => (Exp e -> Exp e -> exp e) + Scanr' :: TupleType e + -> (SmartExp e -> SmartExp e -> exp e) -> exp e - -> acc (Array (sh :. Int) e) - -> PreSmartAcc acc exp (ArrRepr (Array (sh :. Int) e, Array sh e)) + -> acc (Array (sh, Int) e) + -> PreSmartAcc 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) - -> PreSmartAcc acc exp (Array (sh :. Int) e) + Scanr1 :: TupleType e + -> (SmartExp e -> SmartExp e -> exp e) + -> acc (Array (sh, Int) e) + -> PreSmartAcc acc exp (Array (sh, Int) e) - Permute :: (Shape sh, Shape sh', Elt e) - => (Exp e -> Exp e -> exp e) + Permute :: ArrayR (Array sh e) + -> (SmartExp e -> SmartExp e -> exp e) -> acc (Array sh' e) - -> (Exp sh -> exp sh') + -> (SmartExp sh -> exp sh') -> acc (Array sh e) -> PreSmartAcc acc exp (Array sh' e) - Backpermute :: (Shape sh, Shape sh', Elt e) - => exp sh' - -> (Exp sh' -> exp sh) + Backpermute :: ShapeR sh' + -> exp sh' + -> (SmartExp sh' -> exp sh) -> acc (Array sh e) -> PreSmartAcc acc exp (Array sh' e) - Stencil :: (Shape sh, Elt a, Elt b, Stencil sh a stencil) - => (stencil -> exp b) + Stencil :: StencilR sh a stencil + -> TupleType b + -> (SmartExp stencil -> exp b) -> PreBoundary acc exp (Array sh a) -> acc (Array sh a) -> PreSmartAcc 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) + Stencil2 :: StencilR sh a stencil1 + -> StencilR sh b stencil2 + -> TupleType c + -> (SmartExp stencil1 -> SmartExp stencil2 -> exp c) -> PreBoundary acc exp (Array sh a) -> acc (Array sh a) -> PreBoundary acc exp (Array sh b) @@ -462,6 +467,62 @@ data PairIdx p a where PairIdxLeft :: PairIdx (a, b) a PairIdxRight :: PairIdx (a, b) b + +class HasArraysRepr f where + arraysRepr :: f a -> ArraysR a + +instance HasArraysRepr acc => HasArraysRepr (PreSmartAcc acc exp) where + arraysRepr acc = case acc of + Atag repr _ -> repr + Pipe _ _ repr _ _ _ -> repr + Aforeign (_ :: asm (as -> bs)) _ _ + -> Sugar.arrays @bs + Acond _ a _ -> arraysRepr a + Awhile _ _ _ a -> arraysRepr a + Anil -> TupRunit + Apair a1 a2 -> arraysRepr a1 `TupRpair` arraysRepr a2 + Aprj idx a -> let TupRpair t1 t2 = arraysRepr a in case idx of + PairIdxLeft -> t1 + PairIdxRight -> t2 + Use repr _ -> TupRsingle repr + Unit tp _ -> TupRsingle $ ArrayR ShapeRz $ tp + Generate repr _ _ -> TupRsingle repr + Reshape shr _ a -> let TupRsingle (ArrayR _ tp) = arraysRepr a + in TupRsingle $ ArrayR shr tp + Replicate si _ a -> let TupRsingle (ArrayR _ tp) = arraysRepr a + in TupRsingle $ ArrayR (sliceDomainR si) tp + Slice si a _ -> let TupRsingle (ArrayR _ tp) = arraysRepr a + in TupRsingle $ ArrayR (sliceShapeR si) tp + Map _ tp _ a -> let TupRsingle (ArrayR shr _) = arraysRepr a + in TupRsingle $ ArrayR shr tp + ZipWith _ _ tp _ a _ -> let TupRsingle (ArrayR shr _) = arraysRepr a + in TupRsingle $ ArrayR shr tp + Fold _ _ _ a -> let TupRsingle (ArrayR (ShapeRcons shr) tp) = arraysRepr a + in TupRsingle (ArrayR shr tp) + Fold1 _ _ a -> let TupRsingle (ArrayR (ShapeRcons shr) tp) = arraysRepr a + in TupRsingle (ArrayR shr tp) + FoldSeg _ _ _ _ a _ -> arraysRepr a + Fold1Seg _ _ _ a _ -> arraysRepr a + Scanl _ _ _ a -> arraysRepr a + Scanl' _ _ _ a -> let r@(TupRsingle (ArrayR (ShapeRcons shr) tp)) = arraysRepr a + in r `pair` TupRsingle (ArrayR shr tp) + Scanl1 _ _ a -> arraysRepr a + Scanr _ _ _ a -> arraysRepr a + Scanr' _ _ _ a -> let r@(TupRsingle (ArrayR (ShapeRcons shr) tp)) = arraysRepr a + in r `pair` TupRsingle (ArrayR shr tp) + Scanr1 _ _ a -> arraysRepr a + Permute _ _ a _ _ -> arraysRepr a + Backpermute shr _ _ a -> let TupRsingle (ArrayR _ tp) = arraysRepr a + in TupRsingle (ArrayR shr tp) + Stencil s tp _ _ _ -> TupRsingle $ ArrayR (stencilShape s) tp + Stencil2 s _ tp _ _ _ _ _ -> TupRsingle $ ArrayR (stencilShape s) tp + where + pair a b = TupRpair TupRunit a `TupRpair` b + +instance HasArraysRepr SmartAcc where + arraysRepr (SmartAcc e) = arraysRepr e + + {-- data PreSeq acc seq exp arrs where -- Convert the given Haskell-list of arrays to a sequence. @@ -577,9 +638,7 @@ deriving instance Typeable Seq -- -------------------------------------------- -- 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'. +-- constructor instead of variables in the form of de Bruijn indices. -- -- | The type 'Exp' represents embedded scalar expressions. The collective @@ -591,124 +650,129 @@ deriving instance Typeable Seq -- efficiently on constrained hardware such as GPUs, and is thus currently -- unsupported. -- -newtype Exp t = Exp (PreExp SmartAcc Exp t) - +newtype Exp t = Exp (SmartExp (EltRepr t)) +newtype SmartExp t = SmartExp (PreSmartExp SmartAcc SmartExp 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 +data PreSmartExp acc exp t where -- Needed for conversion to de Bruijn form - Tag :: Elt t - => Level -- environment size at defining occurrence - -> PreExp acc exp t + Tag :: TupleType t + -> Level -- environment size at defining occurrence + -> PreSmartExp acc exp t - -- All the same constructors as 'AST.Exp' - Const :: Elt t - => t - -> PreExp acc exp t + -- All the same constructors as 'AST.Exp', plus projection + Const :: ScalarType t + -> t + -> PreSmartExp acc exp t - Tuple :: (Elt t, IsTuple t) - => Tuple exp (TupleRepr t) - -> PreExp acc exp t + Nil :: PreSmartExp acc exp () - Prj :: (Elt t, IsTuple t, Elt e) - => TupleIdx (TupleRepr t) e - -> exp t - -> PreExp acc exp e + Pair :: exp t1 + -> exp t2 + -> PreSmartExp acc exp (t1, t2) - IndexNil :: PreExp acc exp Z + Prj :: PairIdx (t1, t2) t + -> exp (t1, t2) + -> PreSmartExp acc exp t - IndexCons :: (Elt sl, Elt a) - => exp sl - -> exp a - -> PreExp acc exp (sl:.a) - - IndexHead :: (Elt sl, Elt a) - => exp (sl:.a) - -> PreExp acc exp a - - IndexTail :: (Elt sl, Elt a) - => exp (sl:.a) - -> PreExp acc exp sl + {- Vec :: - IndexAny :: Shape sh - => PreExp acc exp (Any sh) + VecPrj :: (KnownNat n, KnownNat k, k <= y) + => exp (Vec n e) + -> PreSmartExp acc exp e -} - ToIndex :: Shape sh - => exp sh + ToIndex :: ShapeR sh -> exp sh - -> PreExp acc exp Int + -> exp sh + -> PreSmartExp acc exp Int - FromIndex :: Shape sh - => exp sh + FromIndex :: ShapeR sh + -> exp sh -> exp Int - -> PreExp acc exp sh + -> PreSmartExp acc exp sh - Cond :: Elt t - => exp Bool + Cond :: exp Bool -> exp t -> exp t - -> PreExp acc exp t + -> PreSmartExp acc exp t - While :: Elt t - => (Exp t -> exp Bool) - -> (Exp t -> exp t) + While :: TupleType t + -> (SmartExp t -> exp Bool) + -> (SmartExp t -> exp t) -> exp t - -> PreExp acc exp t + -> PreSmartExp acc exp t - PrimConst :: Elt t - => PrimConst t - -> PreExp acc exp t + PrimConst :: PrimConst t + -> PreSmartExp acc exp t - PrimApp :: (Elt a, Elt r) - => PrimFun (a -> r) + PrimApp :: PrimFun (a -> r) -> exp a - -> PreExp acc exp r + -> PreSmartExp acc exp r - Index :: (Shape sh, Elt t) - => acc (Array sh t) + Index :: TupleType t + -> acc (Array sh t) -> exp sh - -> PreExp acc exp t + -> PreSmartExp acc exp t - LinearIndex :: (Shape sh, Elt t) - => acc (Array sh t) + LinearIndex :: TupleType t + -> acc (Array sh t) -> exp Int - -> PreExp acc exp t - - Shape :: (Shape sh, Elt e) - => acc (Array sh e) - -> PreExp acc exp sh + -> PreSmartExp acc exp t - ShapeSize :: Shape sh - => exp sh - -> PreExp acc exp Int - - Intersect :: Shape sh - => exp sh - -> exp sh - -> PreExp acc exp sh + Shape :: ShapeR sh + -> acc (Array sh e) + -> PreSmartExp acc exp sh - Union :: Shape sh - => exp sh + ShapeSize :: ShapeR sh -> exp sh - -> PreExp acc exp sh + -> PreSmartExp acc exp Int 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 + -> exp (EltRepr x) + -> PreSmartExp acc exp (EltRepr y) + Undef :: ScalarType t + -> PreSmartExp acc exp t + Coerce :: (Typeable a, Typeable b, BitSizeEq a b) + => ScalarType a + -> ScalarType b + -> exp a + -> PreSmartExp acc exp b + +class HasExpType f where + expType :: f t -> TupleType t + +instance HasExpType exp => HasExpType (PreSmartExp acc exp) where + expType expr = case expr of + Tag tp _ -> tp + Const tp _ -> TupRsingle tp + Nil -> TupRunit + Pair e1 e2 -> expType e1 `TupRpair` expType e2 + Prj idx e -> let TupRpair t1 t2 = expType e in case idx of + PairIdxLeft -> t1 + PairIdxRight -> t2 + ToIndex _ _ _ -> TupRsingle $ scalarTypeInt + FromIndex shr _ _ -> shapeType shr + Cond _ e _ -> expType e + While t _ _ _ -> t + PrimConst c -> primConstType c + PrimApp f _ -> snd $ primFunType f + Index tp _ _ -> tp + LinearIndex tp _ _ -> tp + Shape shr _ -> shapeType shr + ShapeSize _ _ -> TupRsingle $ scalarTypeInt + Foreign (_ :: asm (x -> y)) _ _ -> eltType @y + Undef tp -> TupRsingle tp + Coerce _ tp _ -> TupRsingle tp + +instance HasExpType SmartExp where + expType (SmartExp e) = expType e -- Smart constructors and destructors for array tuples -- --------------------------------------------------- @@ -1173,19 +1237,19 @@ unatup16 (Acc e) = -- | Boundary condition specification for stencil operations -- -newtype Boundary t = Boundary (PreBoundary SmartAcc Exp t) +data Boundary t where + Boundary :: !(PreBoundary SmartAcc SmartExp (Array (EltRepr sh) (EltRepr e))) + -> Boundary (Sugar.Array sh e) 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 + Constant :: e -> PreBoundary acc exp (Array sh e) - Function :: (Shape sh, Elt e) - => (Exp sh -> exp e) + Function :: (SmartExp sh -> exp e) -> PreBoundary acc exp (Array sh e) @@ -1196,170 +1260,260 @@ data PreBoundary acc exp t where -- 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 +class Stencil sh e stencil where type StencilRepr sh stencil :: Type - stencilPrj :: Exp (StencilRepr sh stencil) + + stencilR :: StencilR (EltRepr sh) (EltRepr e) (StencilRepr sh stencil) + stencilPrj :: SmartExp (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) + = EltRepr (e, e, e) + stencilR = StencilRunit3 @(EltRepr e) $ eltType @e + stencilPrj s = (Exp $ prj2 s, + Exp $ prj1 s, + Exp $ prj0 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) + = EltRepr (e, e, e, e, e) + stencilR = StencilRunit5 $ eltType @e + stencilPrj s = (Exp $ prj4 s, + Exp $ prj3 s, + Exp $ prj2 s, + Exp $ prj1 s, + Exp $ prj0 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) + = EltRepr (e, e, e, e, e, e, e) + stencilR = StencilRunit7 $ eltType @e + stencilPrj s = (Exp $ prj6 s, + Exp $ prj5 s, + Exp $ prj4 s, + Exp $ prj3 s, + Exp $ prj2 s, + Exp $ prj1 s, + Exp $ prj0 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) + = EltRepr (e, e, e, e, e, e, e, e, e) + stencilR = StencilRunit9 $ eltType @e + stencilPrj s = (Exp $ prj8 s, + Exp $ prj7 s, + Exp $ prj6 s, + Exp $ prj5 s, + Exp $ prj4 s, + Exp $ prj3 s, + Exp $ prj2 s, + Exp $ prj1 s, + Exp $ prj0 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 s = (stencilPrj @(sh:.Int) @a (Exp $ Prj tix2 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix1 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix0 s)) + = Tup3 (StencilRepr (sh:.Int) row2) (StencilRepr (sh:.Int) row1) (StencilRepr (sh:.Int) row0) + stencilR = StencilRtup3 (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) + stencilPrj s = (stencilPrj @(sh:.Int) @a $ prj2 s, + stencilPrj @(sh:.Int) @a $ prj1 s, + stencilPrj @(sh:.Int) @a $ prj0 s) -instance (Stencil (sh:.Int) a row1, - Stencil (sh:.Int) a row2, +instance (Stencil (sh:.Int) a row4, 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 s = (stencilPrj @(sh:.Int) @a (Exp $ Prj tix4 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix3 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix2 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix1 s), - stencilPrj @(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 row1, + Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row4, row3, row2, row1, row0) where + type StencilRepr (sh:.Int:.Int) (row4, row3, row2, row1, row0) + = Tup5 (StencilRepr (sh:.Int) row4) (StencilRepr (sh:.Int) row3) (StencilRepr (sh:.Int) row2) + (StencilRepr (sh:.Int) row1) (StencilRepr (sh:.Int) row0) + stencilR = StencilRtup5 (stencilR @(sh:.Int) @a @row4) (stencilR @(sh:.Int) @a @row3) + (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) + stencilPrj s = (stencilPrj @(sh:.Int) @a $ prj4 s, + stencilPrj @(sh:.Int) @a $ prj3 s, + stencilPrj @(sh:.Int) @a $ prj2 s, + stencilPrj @(sh:.Int) @a $ prj1 s, + stencilPrj @(sh:.Int) @a $ prj0 s) + +instance (Stencil (sh:.Int) a row6, 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 s = (stencilPrj @(sh:.Int) @a (Exp $ Prj tix6 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix5 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix4 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix3 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix2 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix1 s), - stencilPrj @(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 row3, + Stencil (sh:.Int) a row2, + Stencil (sh:.Int) a row1, + Stencil (sh:.Int) a row0) + => Stencil (sh:.Int:.Int) a (row6, row5, row4, row3, row2, row1, row0) where + type StencilRepr (sh:.Int:.Int) (row6, row5, row4, row3, row2, row1, row0) + = Tup7 (StencilRepr (sh:.Int) row6) (StencilRepr (sh:.Int) row5) (StencilRepr (sh:.Int) row4) + (StencilRepr (sh:.Int) row3) (StencilRepr (sh:.Int) row2) (StencilRepr (sh:.Int) row1) + (StencilRepr (sh:.Int) row0) + stencilR = StencilRtup7 (stencilR @(sh:.Int) @a @row6) + (stencilR @(sh:.Int) @a @row5) (stencilR @(sh:.Int) @a @row4) (stencilR @(sh:.Int) @a @row3) + (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) + stencilPrj s = (stencilPrj @(sh:.Int) @a $ prj6 s, + stencilPrj @(sh:.Int) @a $ prj5 s, + stencilPrj @(sh:.Int) @a $ prj4 s, + stencilPrj @(sh:.Int) @a $ prj3 s, + stencilPrj @(sh:.Int) @a $ prj2 s, + stencilPrj @(sh:.Int) @a $ prj1 s, + stencilPrj @(sh:.Int) @a $ prj0 s) + +instance (Stencil (sh:.Int) a row8, 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 s = (stencilPrj @(sh:.Int) @a (Exp $ Prj tix8 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix7 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix6 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix5 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix4 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix3 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix2 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix1 s), - stencilPrj @(sh:.Int) @a (Exp $ Prj tix0 s)) + Stencil (sh:.Int) a row6, + Stencil (sh:.Int) a row5, + Stencil (sh:.Int) a row4, + Stencil (sh:.Int) a row3, + Stencil (sh:.Int) a row2, + Stencil (sh:.Int) a row1, + Stencil (sh:.Int) a row0) + => Stencil (sh:.Int:.Int) a (row8, row7, row6, row5, row4, row3, row2, row1, row0) where + type StencilRepr (sh:.Int:.Int) (row8, row7, row6, row5, row4, row3, row2, row1, row0) + = Tup9 (StencilRepr (sh:.Int) row8) (StencilRepr (sh:.Int) row7) (StencilRepr (sh:.Int) row6) + (StencilRepr (sh:.Int) row5) (StencilRepr (sh:.Int) row4) (StencilRepr (sh:.Int) row3) + (StencilRepr (sh:.Int) row2) (StencilRepr (sh:.Int) row1) (StencilRepr (sh:.Int) row0) + stencilR = StencilRtup9 + (stencilR @(sh:.Int) @a @row8) (stencilR @(sh:.Int) @a @row7) (stencilR @(sh:.Int) @a @row6) + (stencilR @(sh:.Int) @a @row5) (stencilR @(sh:.Int) @a @row4) (stencilR @(sh:.Int) @a @row3) + (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) + stencilPrj s = (stencilPrj @(sh:.Int) @a $ prj8 s, + stencilPrj @(sh:.Int) @a $ prj7 s, + stencilPrj @(sh:.Int) @a $ prj6 s, + stencilPrj @(sh:.Int) @a $ prj5 s, + stencilPrj @(sh:.Int) @a $ prj4 s, + stencilPrj @(sh:.Int) @a $ prj3 s, + stencilPrj @(sh:.Int) @a $ prj2 s, + stencilPrj @(sh:.Int) @a $ prj1 s, + stencilPrj @(sh:.Int) @a $ prj0 s) -- Auxiliary tuple index constants -- -tix0 :: TupleIdx (t, s0) s0 -tix0 = ZeroTupIdx -tix1 :: TupleIdx ((t, s1), s0) s1 -tix1 = SuccTupIdx tix0 +{- +prjTail :: SmartExp (t, a) -> SmartExp t +prjTail = SmartExp . Prj PairIdxLeft + +prj0 :: ( Elt a) + => SmartExp (t, EltRepr a) -> Exp a +prj0 = exp . Prj PairIdxRight -tix2 :: TupleIdx (((t, s2), s1), s0) s2 -tix2 = SuccTupIdx tix1 +prj1 :: ( Elt a) + => SmartExp ((t, EltRepr a), s0) -> Exp a +prj1 = prj0 . prjTail -tix3 :: TupleIdx ((((t, s3), s2), s1), s0) s3 -tix3 = SuccTupIdx tix2 +prj2 :: ( Elt a) + => SmartExp (((t, EltRepr a), s1), s0) -> Exp a +prj2 = prj1 . prjTail -tix4 :: TupleIdx (((((t, s4), s3), s2), s1), s0) s4 -tix4 = SuccTupIdx tix3 +prj3 :: ( Elt a) + => SmartExp ((((t, EltRepr a), s2), s1), s0) -> Exp a +prj3 = prj2 . prjTail -tix5 :: TupleIdx ((((((t, s5), s4), s3), s2), s1), s0) s5 -tix5 = SuccTupIdx tix4 +prj4 :: ( Elt a) + => SmartExp (((((t, EltRepr a), s3), s2), s1), s0) -> Exp a +prj4 = prj3 . prjTail -tix6 :: TupleIdx (((((((t, s6), s5), s4), s3), s2), s1), s0) s6 -tix6 = SuccTupIdx tix5 +prj5 :: ( Elt a) + => SmartExp ((((((t, EltRepr a), s4), s3), s2), s1), s0) -> Exp a +prj5 = prj4 . prjTail -tix7 :: TupleIdx ((((((((t, s7), s6), s5), s4), s3), s2), s1), s0) s7 -tix7 = SuccTupIdx tix6 +prj6 :: ( Elt a) + => SmartExp (((((((t, EltRepr a), s5), s4), s3), s2), s1), s0) -> Exp a +prj6 = prj5 . prjTail -tix8 :: TupleIdx (((((((((t, s8), s7), s6), s5), s4), s3), s2), s1), s0) s8 -tix8 = SuccTupIdx tix7 +prj7 :: ( Elt a) + => SmartExp ((((((((t, EltRepr a), s6), s5), s4), s3), s2), s1), s0) -> Exp a +prj7 = prj6 . prjTail -tix9 :: TupleIdx ((((((((((t, s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s9 -tix9 = SuccTupIdx tix8 +prj8 :: ( Elt a) + => SmartExp (((((((((t, EltRepr a), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a +prj8 = prj7 . prjTail -tix10 :: TupleIdx (((((((((((t, s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s10 -tix10 = SuccTupIdx tix9 +prj9 :: ( Elt a) + => SmartExp ((((((((((t, EltRepr a), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a +prj9 = prj8 . prjTail -tix11 :: TupleIdx ((((((((((((t, s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s11 -tix11 = SuccTupIdx tix10 +prj10 :: ( Elt a) + => SmartExp (((((((((((t, EltRepr a), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a +prj10 = prj9 . prjTail -tix12 :: TupleIdx (((((((((((((t, s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s12 -tix12 = SuccTupIdx tix11 +prj11 :: ( Elt a) + => SmartExp ((((((((((((t, EltRepr a), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a +prj11 = prj10 . prjTail -tix13 :: TupleIdx ((((((((((((((t, s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s13 -tix13 = SuccTupIdx tix12 +prj12 :: ( Elt a) + => SmartExp (((((((((((((t, EltRepr a), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a +prj12 = prj11 . prjTail -tix14 :: TupleIdx (((((((((((((((t, s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s14 -tix14 = SuccTupIdx tix13 +prj13 :: ( Elt a) + => SmartExp ((((((((((((((t, EltRepr a), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a +prj13 = prj12 . prjTail + +prj14 :: ( Elt a) + => SmartExp (((((((((((((((t, EltRepr a), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a +prj14 = prj13 . prjTail + +prj15 :: ( Elt a) + => SmartExp ((((((((((((((((t, EltRepr a), s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a +prj15 = prj14 . prjTail +-} + +prjTail :: SmartExp (t, a) -> SmartExp t +prjTail = SmartExp . Prj PairIdxLeft + +prj0 :: SmartExp (t, a) -> SmartExp a +prj0 = SmartExp . Prj PairIdxRight + +prj1 :: SmartExp ((t, a), s0) -> SmartExp a +prj1 = prj0 . prjTail + +prj2 :: SmartExp (((t, a), s1), s0) -> SmartExp a +prj2 = prj1 . prjTail + +prj3 :: SmartExp ((((t, a), s2), s1), s0) -> SmartExp a +prj3 = prj2 . prjTail + +prj4 :: SmartExp (((((t, a), s3), s2), s1), s0) -> SmartExp a +prj4 = prj3 . prjTail + +prj5 :: SmartExp ((((((t, a), s4), s3), s2), s1), s0) -> SmartExp a +prj5 = prj4 . prjTail + +prj6 :: SmartExp (((((((t, a), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj6 = prj5 . prjTail + +prj7 :: SmartExp ((((((((t, a), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj7 = prj6 . prjTail + +prj8 :: SmartExp (((((((((t, a), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj8 = prj7 . prjTail + +prj9 :: SmartExp ((((((((((t, a), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj9 = prj8 . prjTail + +prj10 :: SmartExp (((((((((((t, a), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj10 = prj9 . prjTail + +prj11 :: SmartExp ((((((((((((t, a), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj11 = prj10 . prjTail + +prj12 :: SmartExp (((((((((((((t, a), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj12 = prj11 . prjTail + +prj13 :: SmartExp ((((((((((((((t, a), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj13 = prj12 . prjTail + +prj14 :: SmartExp (((((((((((((((t, a), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj14 = prj13 . prjTail + +prj15 :: SmartExp ((((((((((((((((t, a), s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a +prj15 = prj14 . prjTail -tix15 :: TupleIdx ((((((((((((((((t, s15), s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) s15 -tix15 = SuccTupIdx tix14 aprjTail :: (Typeable a, Typeable t) => SmartAcc (t, a) -> SmartAcc t aprjTail = SmartAcc . Aprj PairIdxLeft @@ -1550,8 +1704,15 @@ stup15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -- 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 +constant :: forall e. Elt e => e -> Exp e +constant = Exp . snd . go (eltType @e) . fromElt + where + go :: TupleType t -> t -> (TypeableDict t, SmartExp t) + go TupRunit () = (TypeableDict, SmartExp $ Nil) + go (TupRsingle tp) c = (scalarTypeableDict tp, SmartExp $ Const tp c) + go (TupRpair t1 t2) (c1, c2) + | (TypeableDict, e1) <- go t1 c1 + , (TypeableDict, e2) <- go t2 c2 = (TypeableDict, SmartExp $ e1 `Pair` e2) -- | 'undef' can be used anywhere a constant is expected, and indicates that the -- consumer of the value can receive an unspecified bit pattern. @@ -1576,8 +1737,15 @@ constant = Exp . Const -- -- @since 1.2.0.0 -- -undef :: Elt t => Exp t -undef = Exp Undef +undef :: forall e. Elt e => Exp e +undef = Exp $ snd $ go $ eltType @e + where + go :: TupleType t -> (TypeableDict t, SmartExp t) + go TupRunit = (TypeableDict, SmartExp $ Nil) + go (TupRsingle t) = (scalarTypeableDict t, SmartExp $ Undef t) + go (TupRpair t1 t2) + | (TypeableDict, e1) <- go t1 + , (TypeableDict, e2) <- go t2 = (TypeableDict, SmartExp $ Pair e1 e2) -- | Get the innermost dimension of a shape. -- @@ -1590,471 +1758,462 @@ undef = Exp Undef -- innermost nested loop. -- indexHead :: (Elt sh, Elt a) => Exp (sh :. a) -> Exp a -indexHead = Exp . IndexHead +indexHead (Exp x) = exp $ Prj PairIdxRight x -- | Get all but the innermost element of a shape -- indexTail :: (Elt sh, Elt a) => Exp (sh :. a) -> Exp sh -indexTail = Exp . IndexTail +indexTail (Exp x) = exp $ Prj PairIdxLeft x -- Smart constructor and destructors for scalar tuples -- +nilTup :: SmartExp () +nilTup = SmartExp Nil + +snocTup :: (Typeable a, Elt b) => SmartExp a -> Exp b -> SmartExp (a, EltRepr b) +snocTup a (Exp b) = SmartExp $ Pair a b + tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b) tup2 (a, b) = Exp - $ Tuple - $ NilTup `SnocTup` a - `SnocTup` b + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 + $ 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 ) +untup2 (Exp e) = + ( Exp $ prj1 e + , Exp $ prj0 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 ) +untup3 (Exp e) = + ( Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup4 (Exp e) = + ( Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup5 (Exp e) = + ( Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup6 (Exp e) = + ( Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup7 (Exp e) = + ( Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup8 (Exp e) = + ( Exp $ prj7 e + , Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup9 (Exp e) = + ( Exp $ prj8 e + , Exp $ prj7 e + , Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup10 (Exp e) = + ( Exp $ prj9 e + , Exp $ prj8 e + , Exp $ prj7 e + , Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup11 (Exp e) = + ( Exp $ prj10 e + , Exp $ prj9 e + , Exp $ prj8 e + , Exp $ prj7 e + , Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup12 (Exp e) = + ( Exp $ prj11 e + , Exp $ prj10 e + , Exp $ prj9 e + , Exp $ prj8 e + , Exp $ prj7 e + , Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup13 (Exp e) = + ( Exp $ prj12 e + , Exp $ prj11 e + , Exp $ prj10 e + , Exp $ prj9 e + , Exp $ prj8 e + , Exp $ prj7 e + , Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup14 (Exp e) = + ( Exp $ prj13 e + , Exp $ prj12 e + , Exp $ prj11 e + , Exp $ prj10 e + , Exp $ prj9 e + , Exp $ prj8 e + , Exp $ prj7 e + , Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup15 (Exp e) = + ( Exp $ prj14 e + , Exp $ prj13 e + , Exp $ prj12 e + , Exp $ prj11 e + , Exp $ prj10 e + , Exp $ prj9 e + , Exp $ prj8 e + , Exp $ prj7 e + , Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 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 ) +untup16 (Exp e) = + ( Exp $ prj15 e + , Exp $ prj14 e + , Exp $ prj13 e + , Exp $ prj12 e + , Exp $ prj11 e + , Exp $ prj10 e + , Exp $ prj9 e + , Exp $ prj8 e + , Exp $ prj7 e + , Exp $ prj6 e + , Exp $ prj5 e + , Exp $ prj4 e + , Exp $ prj3 e + , Exp $ prj2 e + , Exp $ prj1 e + , Exp $ prj0 e ) -- Smart constructor for constants -- -mkMinBound :: (Elt t, IsBounded t) => Exp t -mkMinBound = Exp $ PrimConst (PrimMinBound boundedType) +mkMinBound :: (Elt t, IsBounded (EltRepr t)) => Exp t +mkMinBound = exp $ PrimConst (PrimMinBound boundedType) -mkMaxBound :: (Elt t, IsBounded t) => Exp t -mkMaxBound = Exp $ PrimConst (PrimMaxBound boundedType) +mkMaxBound :: (Elt t, IsBounded (EltRepr t)) => Exp t +mkMaxBound = exp $ PrimConst (PrimMaxBound boundedType) -mkPi :: (Elt r, IsFloating r) => Exp r -mkPi = Exp $ PrimConst (PrimPi floatingType) +mkPi :: (Elt r, IsFloating (EltRepr r)) => Exp r +mkPi = exp $ PrimConst (PrimPi floatingType) -- Smart constructors for primitive applications @@ -2062,239 +2221,264 @@ mkPi = Exp $ PrimConst (PrimPi floatingType) -- Operators from Floating -mkSin :: (Elt t, IsFloating t) => Exp t -> Exp t -mkSin x = Exp $ PrimSin floatingType `PrimApp` x +mkSin :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkSin = mkPrimUnary $ PrimSin floatingType -mkCos :: (Elt t, IsFloating t) => Exp t -> Exp t -mkCos x = Exp $ PrimCos floatingType `PrimApp` x +mkCos :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkCos = mkPrimUnary $ PrimCos floatingType -mkTan :: (Elt t, IsFloating t) => Exp t -> Exp t -mkTan x = Exp $ PrimTan floatingType `PrimApp` x +mkTan :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkTan = mkPrimUnary $ PrimTan floatingType -mkAsin :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAsin x = Exp $ PrimAsin floatingType `PrimApp` x +mkAsin :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAsin = mkPrimUnary $ PrimAsin floatingType -mkAcos :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAcos x = Exp $ PrimAcos floatingType `PrimApp` x +mkAcos :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAcos = mkPrimUnary $ PrimAcos floatingType -mkAtan :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAtan x = Exp $ PrimAtan floatingType `PrimApp` x +mkAtan :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAtan = mkPrimUnary $ PrimAtan floatingType -mkSinh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkSinh x = Exp $ PrimSinh floatingType `PrimApp` x +mkSinh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkSinh = mkPrimUnary $ PrimSinh floatingType -mkCosh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkCosh x = Exp $ PrimCosh floatingType `PrimApp` x +mkCosh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkCosh = mkPrimUnary $ PrimCosh floatingType -mkTanh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkTanh x = Exp $ PrimTanh floatingType `PrimApp` x +mkTanh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkTanh = mkPrimUnary $ PrimTanh floatingType -mkAsinh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAsinh x = Exp $ PrimAsinh floatingType `PrimApp` x +mkAsinh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAsinh = mkPrimUnary $ PrimAsinh floatingType -mkAcosh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAcosh x = Exp $ PrimAcosh floatingType `PrimApp` x +mkAcosh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAcosh = mkPrimUnary $ PrimAcosh floatingType -mkAtanh :: (Elt t, IsFloating t) => Exp t -> Exp t -mkAtanh x = Exp $ PrimAtanh floatingType `PrimApp` x +mkAtanh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAtanh = mkPrimUnary $ PrimAtanh floatingType -mkExpFloating :: (Elt t, IsFloating t) => Exp t -> Exp t -mkExpFloating x = Exp $ PrimExpFloating floatingType `PrimApp` x +mkExpFloating :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkExpFloating = mkPrimUnary $ PrimExpFloating floatingType -mkSqrt :: (Elt t, IsFloating t) => Exp t -> Exp t -mkSqrt x = Exp $ PrimSqrt floatingType `PrimApp` x +mkSqrt :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkSqrt = mkPrimUnary $ PrimSqrt floatingType -mkLog :: (Elt t, IsFloating t) => Exp t -> Exp t -mkLog x = Exp $ PrimLog floatingType `PrimApp` x +mkLog :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkLog = mkPrimUnary $ PrimLog floatingType -mkFPow :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t -mkFPow x y = Exp $ PrimFPow floatingType `PrimApp` tup2 (x, y) +mkFPow :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t -> Exp t +mkFPow = mkPrimBinary $ PrimFPow floatingType -mkLogBase :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t -mkLogBase x y = Exp $ PrimLogBase floatingType `PrimApp` tup2 (x, y) +mkLogBase :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t -> Exp t +mkLogBase = mkPrimBinary $ PrimLogBase floatingType -- Operators from Num -mkAdd :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t -mkAdd x y = Exp $ PrimAdd numType `PrimApp` tup2 (x, y) +mkAdd :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t -> Exp t +mkAdd = mkPrimBinary $ PrimAdd numType -mkSub :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t -mkSub x y = Exp $ PrimSub numType `PrimApp` tup2 (x, y) +mkSub :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t -> Exp t +mkSub = mkPrimBinary $ PrimSub numType -mkMul :: (Elt t, IsNum t) => Exp t -> Exp t -> Exp t -mkMul x y = Exp $ PrimMul numType `PrimApp` tup2 (x, y) +mkMul :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t -> Exp t +mkMul = mkPrimBinary $ PrimMul numType -mkNeg :: (Elt t, IsNum t) => Exp t -> Exp t -mkNeg x = Exp $ PrimNeg numType `PrimApp` x +mkNeg :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t +mkNeg = mkPrimUnary $ PrimNeg numType -mkAbs :: (Elt t, IsNum t) => Exp t -> Exp t -mkAbs x = Exp $ PrimAbs numType `PrimApp` x +mkAbs :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t +mkAbs = mkPrimUnary $ PrimAbs numType -mkSig :: (Elt t, IsNum t) => Exp t -> Exp t -mkSig x = Exp $ PrimSig numType `PrimApp` x +mkSig :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t +mkSig = mkPrimUnary $ PrimSig numType -- 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) +mkQuot :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkQuot = mkPrimBinary $ PrimQuot integralType -mkQuotRem :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t) -mkQuotRem x y = untup2 $ Exp $ PrimQuotRem integralType `PrimApp` tup2 (x ,y) +mkRem :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkRem = mkPrimBinary $ PrimRem integralType -mkIDiv :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkIDiv x y = Exp $ PrimIDiv integralType `PrimApp` tup2 (x, y) +mkQuotRem :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> (Exp t, Exp t) +mkQuotRem (Exp x) (Exp y) = + let pair = SmartExp $ PrimQuotRem integralType `PrimApp` (SmartExp $ Pair x y) + in (exp $ Prj PairIdxLeft pair, exp $ Prj PairIdxRight pair) -mkMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkMod x y = Exp $ PrimMod integralType `PrimApp` tup2 (x, y) +mkIDiv :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkIDiv = mkPrimBinary $ PrimIDiv integralType -mkDivMod :: (Elt t, IsIntegral t) => Exp t -> Exp t -> (Exp t, Exp t) -mkDivMod x y = untup2 $ Exp $ PrimDivMod integralType `PrimApp` tup2 (x ,y) +mkMod :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkMod = mkPrimBinary $ PrimMod integralType +mkDivMod :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> (Exp t, Exp t) +mkDivMod (Exp x) (Exp y) = + let pair = SmartExp $ PrimDivMod integralType `PrimApp` (SmartExp $ Pair x y) + in (exp $ Prj PairIdxLeft pair, exp $ Prj PairIdxRight pair) -- 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) +mkBAnd :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkBAnd = mkPrimBinary $ PrimBAnd integralType -mkBOr :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkBOr x y = Exp $ PrimBOr integralType `PrimApp` tup2 (x, y) +mkBOr :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkBOr = mkPrimBinary $ PrimBOr integralType -mkBXor :: (Elt t, IsIntegral t) => Exp t -> Exp t -> Exp t -mkBXor x y = Exp $ PrimBXor integralType `PrimApp` tup2 (x, y) +mkBXor :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkBXor = mkPrimBinary $ PrimBXor integralType -mkBNot :: (Elt t, IsIntegral t) => Exp t -> Exp t -mkBNot x = Exp $ PrimBNot integralType `PrimApp` x +mkBNot :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t +mkBNot = mkPrimUnary $ PrimBNot integralType -mkBShiftL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -mkBShiftL x i = Exp $ PrimBShiftL integralType `PrimApp` tup2 (x, i) +mkBShiftL :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +mkBShiftL = mkPrimBinary $ PrimBShiftL integralType -mkBShiftR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -mkBShiftR x i = Exp $ PrimBShiftR integralType `PrimApp` tup2 (x, i) +mkBShiftR :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +mkBShiftR = mkPrimBinary $ PrimBShiftR integralType -mkBRotateL :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -mkBRotateL x i = Exp $ PrimBRotateL integralType `PrimApp` tup2 (x, i) +mkBRotateL :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +mkBRotateL = mkPrimBinary $ PrimBRotateL integralType -mkBRotateR :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t -mkBRotateR x i = Exp $ PrimBRotateR integralType `PrimApp` tup2 (x, i) +mkBRotateR :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +mkBRotateR = mkPrimBinary $ PrimBRotateR integralType -mkPopCount :: (Elt t, IsIntegral t) => Exp t -> Exp Int -mkPopCount x = Exp $ PrimPopCount integralType `PrimApp` x +mkPopCount :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int +mkPopCount = mkPrimUnary $ PrimPopCount integralType -mkCountLeadingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int -mkCountLeadingZeros x = Exp $ PrimCountLeadingZeros integralType `PrimApp` x +mkCountLeadingZeros :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int +mkCountLeadingZeros = mkPrimUnary $ PrimCountLeadingZeros integralType -mkCountTrailingZeros :: (Elt t, IsIntegral t) => Exp t -> Exp Int -mkCountTrailingZeros x = Exp $ PrimCountTrailingZeros integralType `PrimApp` x +mkCountTrailingZeros :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int +mkCountTrailingZeros = mkPrimUnary $ PrimCountTrailingZeros integralType -- Operators from Fractional -mkFDiv :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t -mkFDiv x y = Exp $ PrimFDiv floatingType `PrimApp` tup2 (x, y) +mkFDiv :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t -> Exp t +mkFDiv = mkPrimBinary $ PrimFDiv floatingType -mkRecip :: (Elt t, IsFloating t) => Exp t -> Exp t -mkRecip x = Exp $ PrimRecip floatingType `PrimApp` x +mkRecip :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkRecip = mkPrimUnary $ PrimRecip floatingType -- Operators from RealFrac -mkTruncate :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b -mkTruncate x = Exp $ PrimTruncate floatingType integralType `PrimApp` x +mkTruncate :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b +mkTruncate = mkPrimUnary $ PrimTruncate floatingType integralType -mkRound :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b -mkRound x = Exp $ PrimRound floatingType integralType `PrimApp` x +mkRound :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b +mkRound = mkPrimUnary $ PrimRound floatingType integralType -mkFloor :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b -mkFloor x = Exp $ PrimFloor floatingType integralType `PrimApp` x +mkFloor :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b +mkFloor = mkPrimUnary $ PrimFloor floatingType integralType -mkCeiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b -mkCeiling x = Exp $ PrimCeiling floatingType integralType `PrimApp` x +mkCeiling :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b +mkCeiling = mkPrimUnary $ PrimCeiling floatingType integralType -- Operators from RealFloat -mkAtan2 :: (Elt t, IsFloating t) => Exp t -> Exp t -> Exp t -mkAtan2 x y = Exp $ PrimAtan2 floatingType `PrimApp` tup2 (x, y) +mkAtan2 :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t -> Exp t +mkAtan2 = mkPrimBinary $ PrimAtan2 floatingType -mkIsNaN :: (Elt t, IsFloating t) => Exp t -> Exp Bool -mkIsNaN x = Exp $ PrimIsNaN floatingType `PrimApp` x +mkIsNaN :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp Bool +mkIsNaN = mkPrimUnary $ PrimIsNaN floatingType -mkIsInfinite :: (Elt t, IsFloating t) => Exp t -> Exp Bool -mkIsInfinite x = Exp $ PrimIsInfinite floatingType `PrimApp` x +mkIsInfinite :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp Bool +mkIsInfinite = mkPrimUnary $ PrimIsInfinite floatingType -- 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) +mkLt :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkLt = mkPrimBinary $ PrimLt singleType -mkGt :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool -mkGt x y = Exp $ PrimGt singleType `PrimApp` tup2 (x, y) +mkGt :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkGt = mkPrimBinary $ PrimGt singleType -mkLtEq :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool -mkLtEq x y = Exp $ PrimLtEq singleType `PrimApp` tup2 (x, y) +mkLtEq :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkLtEq = mkPrimBinary $ PrimLtEq singleType -mkGtEq :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool -mkGtEq x y = Exp $ PrimGtEq singleType `PrimApp` tup2 (x, y) +mkGtEq :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkGtEq = mkPrimBinary $ PrimGtEq singleType -mkEq :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool -mkEq x y = Exp $ PrimEq singleType `PrimApp` tup2 (x, y) +mkEq :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkEq = mkPrimBinary $ PrimEq singleType -mkNEq :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp Bool -mkNEq x y = Exp $ PrimNEq singleType `PrimApp` tup2 (x, y) +mkNEq :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkNEq = mkPrimBinary $ PrimNEq singleType -mkMax :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp t -mkMax x y = Exp $ PrimMax singleType `PrimApp` tup2 (x, y) +mkMax :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp t +mkMax = mkPrimBinary $ PrimMax singleType -mkMin :: (Elt t, IsSingle t) => Exp t -> Exp t -> Exp t -mkMin x y = Exp $ PrimMin singleType `PrimApp` tup2 (x, y) +mkMin :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp t +mkMin = mkPrimBinary $ PrimMin singleType -- Logical operators mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool -mkLAnd x y = Exp $ PrimLAnd `PrimApp` tup2 (x, y) +mkLAnd = mkPrimBinary PrimLAnd mkLOr :: Exp Bool -> Exp Bool -> Exp Bool -mkLOr x y = Exp $ PrimLOr `PrimApp` tup2 (x, y) +mkLOr = mkPrimBinary PrimLOr mkLNot :: Exp Bool -> Exp Bool -mkLNot x = Exp $ PrimLNot `PrimApp` x +mkLNot = mkPrimUnary PrimLNot -- Character conversions mkOrd :: Exp Char -> Exp Int -mkOrd x = Exp $ PrimOrd `PrimApp` x +mkOrd = mkPrimUnary PrimOrd mkChr :: Exp Int -> Exp Char -mkChr x = Exp $ PrimChr `PrimApp` x +mkChr = mkPrimUnary PrimChr -- Numeric conversions -mkFromIntegral :: (Elt a, Elt b, IsIntegral a, IsNum b) => Exp a -> Exp b -mkFromIntegral x = Exp $ PrimFromIntegral integralType numType `PrimApp` x +mkFromIntegral :: (Elt a, Elt b, IsIntegral (EltRepr a), IsNum (EltRepr b)) => Exp a -> Exp b +mkFromIntegral = mkPrimUnary $ PrimFromIntegral integralType numType -mkToFloating :: (Elt a, Elt b, IsNum a, IsFloating b) => Exp a -> Exp b -mkToFloating x = Exp $ PrimToFloating numType floatingType `PrimApp` x +mkToFloating :: (Elt a, Elt b, IsNum (EltRepr a), IsFloating (EltRepr b)) => Exp a -> Exp b +mkToFloating = mkPrimUnary $ PrimToFloating numType floatingType -- Other conversions mkBoolToInt :: Exp Bool -> Exp Int -mkBoolToInt b = Exp $ PrimBoolToInt `PrimApp` b +mkBoolToInt (Exp b) = exp $ PrimBoolToInt `PrimApp` b -- NOTE: Restricted to scalar types with a type-level BitSizeEq constraint to -- make this version "safe" mkBitcast :: forall b a. (Elt a, Elt b, IsScalar (EltRepr a), IsScalar (EltRepr b), BitSizeEq (EltRepr a) (EltRepr b)) => Exp a -> Exp b -mkBitcast = mkUnsafeCoerce +mkBitcast (Exp a) = exp $ Coerce (scalarType @(EltRepr a)) (scalarType @(EltRepr b)) a + +mkCoerce :: Coerce (EltRepr a) (EltRepr b) => Exp a -> Exp b +mkCoerce (Exp a) = Exp $ mkCoerce' a + +class Coerce a b where + mkCoerce' :: SmartExp a -> SmartExp b + +instance (IsScalar a, IsScalar b, BitSizeEq a b) => Coerce a b where + mkCoerce' = SmartExp . Coerce (scalarType @a) (scalarType @b) + +instance (Coerce a1 b1, Coerce a2 b2) => Coerce (a1, a2) (b1, b2) where + mkCoerce' a = SmartExp $ Pair (mkCoerce' $ SmartExp $ Prj PairIdxLeft a) (mkCoerce' $ SmartExp $ Prj PairIdxRight a) + +instance Coerce () () where + mkCoerce' _ = SmartExp $ Nil + +instance Coerce ((), a) a where + mkCoerce' a = SmartExp $ Prj PairIdxRight a + +instance Coerce a ((), a) where + mkCoerce' = SmartExp . Pair (SmartExp $ Nil) -mkUnsafeCoerce :: forall b a. (Elt a, Elt b) => Exp a -> Exp b -mkUnsafeCoerce = Exp . Coerce -- Auxiliary functions -- -------------------- +exp :: PreSmartExp SmartAcc SmartExp (EltRepr t) -> Exp t +exp = Exp . SmartExp + infixr 0 $$ ($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a (f $$ g) x y = f (g x y) @@ -2317,13 +2501,31 @@ unAcc (Acc a) = a unAccFunction :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> SmartAcc (ArrRepr a) -> SmartAcc (ArrRepr b) unAccFunction f = unAcc . f . Acc +unExp :: Elt e => Exp e -> SmartExp (EltRepr e) +unExp (Exp e) = e + +unExpFunction :: (Elt a, Elt b) => (Exp a -> Exp b) -> SmartExp (EltRepr a) -> SmartExp (EltRepr b) +unExpFunction f = unExp . f . Exp + +unExpBinaryFunction :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> Exp c) -> SmartExp (EltRepr a) -> SmartExp (EltRepr b) -> SmartExp (EltRepr c) +unExpBinaryFunction f a b = unExp $ f (Exp a) (Exp b) + +mkPrimUnary :: (Elt a, Elt b) => PrimFun (EltRepr a -> EltRepr b) -> Exp a -> Exp b +mkPrimUnary prim (Exp a) = exp $ PrimApp prim a + +mkPrimBinary :: (Elt a, Elt b, Elt c) => PrimFun ((EltRepr a, EltRepr b) -> EltRepr c) -> Exp a -> Exp b -> Exp c +mkPrimBinary prim (Exp a) (Exp b) = exp $ PrimApp prim (SmartExp $ Pair a b) + +unPair :: SmartExp (a, b) -> (SmartExp a, SmartExp b) +unPair e = (SmartExp $ Prj PairIdxLeft e, SmartExp $ Prj PairIdxRight e) + class ApplyAcc a where type FromApplyAcc a applyAcc :: FromApplyAcc a -> a instance ApplyAcc (SmartAcc a) where - type FromApplyAcc (SmartAcc a) = PreSmartAcc SmartAcc Exp a + type FromApplyAcc (SmartAcc a) = PreSmartAcc SmartAcc SmartExp a applyAcc = SmartAcc @@ -2332,26 +2534,32 @@ instance (Arrays a, ApplyAcc t) => ApplyAcc (Acc a -> t) where applyAcc f a = applyAcc $ f (unAcc a) -instance ApplyAcc t => ApplyAcc (Exp a -> t) where - type FromApplyAcc (Exp a -> t) = Exp a -> FromApplyAcc t +instance (Elt a, ApplyAcc t) => ApplyAcc (Exp a -> t) where + type FromApplyAcc (Exp a -> t) = SmartExp (EltRepr a) -> FromApplyAcc t + + applyAcc f a = applyAcc $ f (unExp a) - applyAcc f a = applyAcc $ f a +instance (Elt a, Elt b, ApplyAcc t) => ApplyAcc ((Exp a -> Exp b) -> t) where + type FromApplyAcc ((Exp a -> Exp b) -> t) = (SmartExp (EltRepr a) -> SmartExp (EltRepr b)) -> FromApplyAcc t -instance ApplyAcc t => ApplyAcc ((Exp a -> b) -> t) where - type FromApplyAcc ((Exp a -> b) -> t) = (Exp a -> b) -> FromApplyAcc t + applyAcc f a = applyAcc $ f (unExpFunction a) - applyAcc f a = applyAcc $ f a +instance (Elt a, Elt b, Elt c, ApplyAcc t) => ApplyAcc ((Exp a -> Exp b -> Exp c) -> t) where + type FromApplyAcc ((Exp a -> Exp b -> Exp c) -> t) = (SmartExp (EltRepr a) -> SmartExp (EltRepr b) -> SmartExp (EltRepr c)) -> FromApplyAcc t + + applyAcc f a = applyAcc $ f (unExpBinaryFunction a) instance (Arrays a, Arrays b, ApplyAcc t) => ApplyAcc ((Acc a -> Acc b) -> t) where type FromApplyAcc ((Acc a -> Acc b) -> t) = (SmartAcc (ArrRepr a) -> SmartAcc (ArrRepr b)) -> FromApplyAcc t applyAcc f a = applyAcc $ f (unAccFunction a) + -- Debugging -- --------- showPreAccOp :: forall acc exp arrs. PreSmartAcc acc exp arrs -> String -showPreAccOp (Atag i) = "Atag " ++ show i -showPreAccOp (Use a) = "Use " ++ showShortendArr a +showPreAccOp (Atag _ i) = "Atag " ++ show i +showPreAccOp (Use repr a) = "Use " ++ showShortendArr repr a showPreAccOp Pipe{} = "Pipe" showPreAccOp Acond{} = "Acond" showPreAccOp Awhile{} = "Awhile" @@ -2395,25 +2603,14 @@ showPreSeqOp (Stuple{}) = "Stuple" --} -showShortendArr :: (Shape sh, 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 :: PreSmartExp acc exp t -> String +showPreExpOp (Tag _ i) = "Tag" ++ show i +showPreExpOp (Const tp c) = "Const " ++ showElement (TupRsingle tp) c +showPreExpOp (Undef _) = "Undef" +showPreExpOp Nil{} = "Nil" +showPreExpOp Pair{} = "Pair" showPreExpOp Prj{} = "Prj" -showPreExpOp IndexNil = "IndexNil" -showPreExpOp IndexCons{} = "IndexCons" -showPreExpOp IndexHead{} = "IndexHead" -showPreExpOp IndexTail{} = "IndexTail" -showPreExpOp IndexAny = "IndexAny" +-- showPreExpOp VecPrj{} = "VecPrj" showPreExpOp ToIndex{} = "ToIndex" showPreExpOp FromIndex{} = "FromIndex" showPreExpOp Cond{} = "Cond" @@ -2424,8 +2621,6 @@ showPreExpOp Index{} = "Index" showPreExpOp LinearIndex{} = "LinearIndex" showPreExpOp Shape{} = "Shape" showPreExpOp ShapeSize{} = "ShapeSize" -showPreExpOp Intersect{} = "Intersect" -showPreExpOp Union{} = "Union" showPreExpOp Foreign{} = "Foreign" showPreExpOp Coerce{} = "Coerce" diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index 9ffd57c2e..429a861fa 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -41,9 +41,7 @@ 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 ( primOperator, isInfix, opName ) -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Trafo.Base import Data.Array.Accelerate.Type @@ -62,34 +60,20 @@ propagate env = cvtE where cvtE :: PreOpenExp acc env aenv e -> Maybe e cvtE exp = case exp of - Const c -> Just (toElt c) + Const _ c -> Just 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 + Evar (Var _ ix) | e <- prjExp ix env , Nothing <- match exp e -> cvtE e - -- - IndexHead (cvtE -> Just (_ :. z)) -> Just z - IndexTail (cvtE -> Just (sh :. _)) -> Just sh + Nil -> Just () + Pair e1 e2 -> (,) <$> cvtE e1 <*> cvtE e2 _ -> 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) + :: forall acc env aenv a r. (Kit acc) => Gamma acc env env aenv -> PrimFun (a -> r) -> PreOpenExp acc env aenv a @@ -193,11 +177,11 @@ commutes f x env = case f of _ -> Nothing where swizzle :: PreOpenExp acc env aenv (b,b) -> Maybe (PreOpenExp acc env aenv (b,b)) - swizzle (Tuple (NilTup `SnocTup` a `SnocTup` b)) + swizzle (Pair a b) | Nothing <- propagate env a , Just _ <- propagate env b = Stats.ruleFired (pprFun "commutes" f) - $ Just $ Tuple (NilTup `SnocTup` b `SnocTup` a) + $ Just $ Pair b 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 @@ -271,28 +255,28 @@ associates fun exp = case fun of 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)) +eval1 :: SingleType b -> (a -> b) -> a :-> b +eval1 tp f x env + | Just a <- propagate env x = Stats.substitution "constant fold" . Just $ Const (SingleScalarType tp) (f a) | otherwise = Nothing -eval2 :: Elt c => (a -> b -> c) -> (a,b) :-> c -eval2 f (untup2 -> Just (x,y)) env +eval2 :: SingleType c -> (a -> b -> c) -> (a,b) :-> c +eval2 tp 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)) + $ Just $ Const (SingleScalarType tp) (f a b) -eval2 _ _ _ +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) +tup2 :: (PreOpenExp acc env aenv a, PreOpenExp acc env aenv b) -> PreOpenExp acc env aenv (a, b) +tup2 (a,b) = Pair a 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 + | Pair a b <- exp = Just (a, b) + | otherwise = Nothing pprFun :: Text -> PrimFun f -> Text @@ -310,25 +294,25 @@ pprFun rule 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 :: NumType a -> (a,a) :-> a +evalAdd ty@(IntegralNumType ty') | IntegralDict <- integralDict ty' = evalAdd' ty +evalAdd ty@(FloatingNumType ty') | FloatingDict <- floatingDict ty' = evalAdd' ty -evalAdd' :: (Elt a, Eq a, Num a) => (a,a) :-> a -evalAdd' (untup2 -> Just (x,y)) env +evalAdd' :: (Eq a, Num a) => NumType 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 +evalAdd' ty arg env + = eval2 (NumSingleType ty) (+) arg env -evalSub :: Elt a => NumType a -> (a,a) :-> a +evalSub :: 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' :: forall a. (Eq a, Num a) => NumType a -> (a,a) :-> a evalSub' ty (untup2 -> Just (x,y)) env | Just b <- propagate env y , b == 0 @@ -337,22 +321,25 @@ evalSub' ty (untup2 -> Just (x,y)) env | 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 . snd $ evalPrimApp env (PrimAdd ty) (Const tp (-b) `Pair` x) + -- (Tuple $ NilTup `SnocTup` Const (fromElt (-b)) `SnocTup` x) | Just Refl <- match x y = Stats.ruleFired "x-x" - $ Just $ Const (fromElt (0::a)) + $ Just $ Const tp 0 + where + tp = SingleScalarType $ NumSingleType ty -evalSub' _ arg env - = eval2 (-) arg env +evalSub' ty arg env + = eval2 (NumSingleType ty) (-) 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 :: NumType a -> (a,a) :-> a +evalMul ty@(IntegralNumType ty') | IntegralDict <- integralDict ty' = evalMul' ty +evalMul ty@(FloatingNumType ty') | FloatingDict <- floatingDict ty' = evalMul' ty -evalMul' :: (Elt a, Eq a, Num a) => (a,a) :-> a -evalMul' (untup2 -> Just (x,y)) env +evalMul' :: (Eq a, Num a) => NumType a -> (a,a) :-> a +evalMul' _ (untup2 -> Just (x,y)) env | Just a <- propagate env x , Nothing <- propagate env y = case a of @@ -360,21 +347,21 @@ evalMul' (untup2 -> Just (x,y)) env 1 -> Stats.ruleFired "x*1" $ Just y _ -> Nothing -evalMul' arg env - = eval2 (*) arg env +evalMul' ty arg env + = eval2 (NumSingleType ty) (*) arg env -evalNeg :: Elt a => NumType a -> a :-> a +evalNeg :: 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 +evalNeg (IntegralNumType ty) x env | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType ty) negate x env +evalNeg (FloatingNumType ty) x env | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) 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 +evalAbs :: NumType a -> a :-> a +evalAbs (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType ty) abs +evalAbs (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) abs -evalSig :: Elt a => NumType a -> a :-> a -evalSig (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 signum -evalSig (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 signum +evalSig :: NumType a -> a :-> a +evalSig (IntegralNumType ty) | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType ty) signum +evalSig (FloatingNumType ty) | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) signum -- Methods of Integral & Bits @@ -398,17 +385,19 @@ evalRem _ _ _ 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 + | IntegralDict <- integralDict ty + , Just (x, y) <- untup2 exp + , Just b <- propagate env y = case b of 0 -> Nothing - 1 -> Stats.ruleFired "quotRem x 1" $ Just (tup2 (x, Const (fromElt (0::a)))) + 1 -> Stats.ruleFired "quotRem x 1" $ Just (tup2 (x, Const tp 0)) _ -> 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)) + in tup2 (Const tp u, Const tp v) + where + tp = SingleScalarType $ NumSingleType $ IntegralNumType ty evalQuotRem _ _ _ = Nothing @@ -431,78 +420,80 @@ evalMod _ _ _ 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 + | IntegralDict <- integralDict ty + , Just (x, y) <- untup2 exp + , Just b <- propagate env y = case b of 0 -> Nothing - 1 -> Stats.ruleFired "divMod x 1" $ Just (tup2 (x, Const (fromElt (0::a)))) + 1 -> Stats.ruleFired "divMod x 1" $ Just (tup2 (x, Const tp 0)) _ -> 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)) + in tup2 (Const tp u, Const tp v) + where + tp = SingleScalarType $ NumSingleType $ IntegralNumType ty evalDivMod _ _ _ = Nothing -evalBAnd :: Elt a => IntegralType a -> (a,a) :-> a -evalBAnd ty | IntegralDict <- integralDict ty = eval2 (.&.) +evalBAnd :: IntegralType a -> (a,a) :-> a +evalBAnd ty | IntegralDict <- integralDict ty = eval2 (NumSingleType $ IntegralNumType ty) (.&.) -evalBOr :: Elt a => IntegralType a -> (a,a) :-> a -evalBOr ty | IntegralDict <- integralDict ty = evalBOr' +evalBOr :: IntegralType a -> (a,a) :-> a +evalBOr ty | IntegralDict <- integralDict ty = evalBOr' ty -evalBOr' :: (Elt a, Eq a, Num a, Bits a) => (a,a) :-> a -evalBOr' (untup2 -> Just (x,y)) env +evalBOr' :: (Eq a, Num a, Bits a) => IntegralType a -> (a,a) :-> a +evalBOr' _ (untup2 -> Just (x,y)) env | Just 0 <- propagate env x = Stats.ruleFired "x .|. 0" $ Just y -evalBOr' arg env - = eval2 (.|.) arg env +evalBOr' ty arg env + = eval2 (NumSingleType $ IntegralNumType ty) (.|.) arg env -evalBXor :: Elt a => IntegralType a -> (a,a) :-> a -evalBXor ty | IntegralDict <- integralDict ty = eval2 xor +evalBXor :: IntegralType a -> (a,a) :-> a +evalBXor ty | IntegralDict <- integralDict ty = eval2 (NumSingleType $ IntegralNumType ty) xor -evalBNot :: Elt a => IntegralType a -> a :-> a -evalBNot ty | IntegralDict <- integralDict ty = eval1 complement +evalBNot :: IntegralType a -> a :-> a +evalBNot ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType ty) complement -evalBShiftL :: Elt a => IntegralType a -> (a,Int) :-> a +evalBShiftL :: 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 + | IntegralDict <- integralDict ty = eval2 (NumSingleType $ IntegralNumType ty) shiftL arg env -evalBShiftR :: Elt a => IntegralType a -> (a,Int) :-> a +evalBShiftR :: 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 + | IntegralDict <- integralDict ty = eval2 (NumSingleType $ IntegralNumType ty) shiftR arg env -evalBRotateL :: Elt a => IntegralType a -> (a,Int) :-> a +evalBRotateL :: 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 + | IntegralDict <- integralDict ty = eval2 (NumSingleType $ IntegralNumType ty) rotateL arg env -evalBRotateR :: Elt a => IntegralType a -> (a,Int) :-> a +evalBRotateR :: 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 + | IntegralDict <- integralDict ty = eval2 (NumSingleType $ IntegralNumType ty) rotateR arg env evalPopCount :: IntegralType a -> a :-> Int -evalPopCount ty | IntegralDict <- integralDict ty = eval1 popCount +evalPopCount ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType TypeInt) popCount evalCountLeadingZeros :: IntegralType a -> a :-> Int #if __GLASGOW_HASKELL__ >= 710 -evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 countLeadingZeros +evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType TypeInt) countLeadingZeros #else -evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 clz +evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType TypeInt) clz where clz x = (w-1) - go (w-1) where @@ -514,9 +505,9 @@ evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 clz evalCountTrailingZeros :: IntegralType a -> a :-> Int #if __GLASGOW_HASKELL__ >= 710 -evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 countTrailingZeros +evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType TypeInt) countTrailingZeros #else -evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 ctz +evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType TypeInt) ctz where ctz x = go 0 where @@ -530,109 +521,109 @@ evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 ctz -- Methods of Fractional & Floating -- -------------------------------- -evalFDiv :: Elt a => FloatingType a -> (a,a) :-> a -evalFDiv ty | FloatingDict <- floatingDict ty = evalFDiv' +evalFDiv :: FloatingType a -> (a,a) :-> a +evalFDiv ty | FloatingDict <- floatingDict ty = evalFDiv' ty -evalFDiv' :: (Elt a, Fractional a, Eq a) => (a,a) :-> a -evalFDiv' (untup2 -> Just (x,y)) env +evalFDiv' :: (Fractional a, Eq a) => FloatingType 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 +evalFDiv' ty arg env + = eval2 (NumSingleType $ FloatingNumType ty) (/) arg env -evalRecip :: Elt a => FloatingType a -> a :-> a -evalRecip ty | FloatingDict <- floatingDict ty = eval1 recip +evalRecip :: FloatingType a -> a :-> a +evalRecip ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) recip -evalSin :: Elt a => FloatingType a -> a :-> a -evalSin ty | FloatingDict <- floatingDict ty = eval1 sin +evalSin :: FloatingType a -> a :-> a +evalSin ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) sin -evalCos :: Elt a => FloatingType a -> a :-> a -evalCos ty | FloatingDict <- floatingDict ty = eval1 cos +evalCos :: FloatingType a -> a :-> a +evalCos ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) cos -evalTan :: Elt a => FloatingType a -> a :-> a -evalTan ty | FloatingDict <- floatingDict ty = eval1 tan +evalTan :: FloatingType a -> a :-> a +evalTan ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) tan -evalAsin :: Elt a => FloatingType a -> a :-> a -evalAsin ty | FloatingDict <- floatingDict ty = eval1 asin +evalAsin :: FloatingType a -> a :-> a +evalAsin ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) asin -evalAcos :: Elt a => FloatingType a -> a :-> a -evalAcos ty | FloatingDict <- floatingDict ty = eval1 acos +evalAcos :: FloatingType a -> a :-> a +evalAcos ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) acos -evalAtan :: Elt a => FloatingType a -> a :-> a -evalAtan ty | FloatingDict <- floatingDict ty = eval1 atan +evalAtan :: FloatingType a -> a :-> a +evalAtan ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) atan -evalSinh :: Elt a => FloatingType a -> a :-> a -evalSinh ty | FloatingDict <- floatingDict ty = eval1 sinh +evalSinh :: FloatingType a -> a :-> a +evalSinh ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) sinh -evalCosh :: Elt a => FloatingType a -> a :-> a -evalCosh ty | FloatingDict <- floatingDict ty = eval1 cosh +evalCosh :: FloatingType a -> a :-> a +evalCosh ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) cosh -evalTanh :: Elt a => FloatingType a -> a :-> a -evalTanh ty | FloatingDict <- floatingDict ty = eval1 tanh +evalTanh :: FloatingType a -> a :-> a +evalTanh ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) tanh -evalAsinh :: Elt a => FloatingType a -> a :-> a -evalAsinh ty | FloatingDict <- floatingDict ty = eval1 asinh +evalAsinh :: FloatingType a -> a :-> a +evalAsinh ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) asinh -evalAcosh :: Elt a => FloatingType a -> a :-> a -evalAcosh ty | FloatingDict <- floatingDict ty = eval1 acosh +evalAcosh :: FloatingType a -> a :-> a +evalAcosh ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) acosh -evalAtanh :: Elt a => FloatingType a -> a :-> a -evalAtanh ty | FloatingDict <- floatingDict ty = eval1 atanh +evalAtanh :: FloatingType a -> a :-> a +evalAtanh ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) atanh -evalExpFloating :: Elt a => FloatingType a -> a :-> a -evalExpFloating ty | FloatingDict <- floatingDict ty = eval1 P.exp +evalExpFloating :: FloatingType a -> a :-> a +evalExpFloating ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) P.exp -evalSqrt :: Elt a => FloatingType a -> a :-> a -evalSqrt ty | FloatingDict <- floatingDict ty = eval1 sqrt +evalSqrt :: FloatingType a -> a :-> a +evalSqrt ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) sqrt -evalLog :: Elt a => FloatingType a -> a :-> a -evalLog ty | FloatingDict <- floatingDict ty = eval1 log +evalLog :: FloatingType a -> a :-> a +evalLog ty | FloatingDict <- floatingDict ty = eval1 (NumSingleType $ FloatingNumType ty) log -evalFPow :: Elt a => FloatingType a -> (a,a) :-> a -evalFPow ty | FloatingDict <- floatingDict ty = eval2 (**) +evalFPow :: FloatingType a -> (a,a) :-> a +evalFPow ty | FloatingDict <- floatingDict ty = eval2 (NumSingleType $ FloatingNumType ty) (**) -evalLogBase :: Elt a => FloatingType a -> (a,a) :-> a -evalLogBase ty | FloatingDict <- floatingDict ty = eval2 logBase +evalLogBase :: FloatingType a -> (a,a) :-> a +evalLogBase ty | FloatingDict <- floatingDict ty = eval2 (NumSingleType $ FloatingNumType ty) logBase -evalAtan2 :: Elt a => FloatingType a -> (a,a) :-> a -evalAtan2 ty | FloatingDict <- floatingDict ty = eval2 atan2 +evalAtan2 :: FloatingType a -> (a,a) :-> a +evalAtan2 ty | FloatingDict <- floatingDict ty = eval2 (NumSingleType $ FloatingNumType ty) atan2 -evalTruncate :: Elt b => FloatingType a -> IntegralType b -> a :-> b +evalTruncate :: FloatingType a -> IntegralType b -> a :-> b evalTruncate ta tb | FloatingDict <- floatingDict ta - , IntegralDict <- integralDict tb = eval1 truncate + , IntegralDict <- integralDict tb = eval1 (NumSingleType $ IntegralNumType tb) truncate -evalRound :: Elt b => FloatingType a -> IntegralType b -> a :-> b +evalRound :: FloatingType a -> IntegralType b -> a :-> b evalRound ta tb | FloatingDict <- floatingDict ta - , IntegralDict <- integralDict tb = eval1 round + , IntegralDict <- integralDict tb = eval1 (NumSingleType $ IntegralNumType tb) round -evalFloor :: Elt b => FloatingType a -> IntegralType b -> a :-> b +evalFloor :: FloatingType a -> IntegralType b -> a :-> b evalFloor ta tb | FloatingDict <- floatingDict ta - , IntegralDict <- integralDict tb = eval1 floor + , IntegralDict <- integralDict tb = eval1 (NumSingleType $ IntegralNumType tb) floor -evalCeiling :: Elt b => FloatingType a -> IntegralType b -> a :-> b +evalCeiling :: FloatingType a -> IntegralType b -> a :-> b evalCeiling ta tb | FloatingDict <- floatingDict ta - , IntegralDict <- integralDict tb = eval1 ceiling + , IntegralDict <- integralDict tb = eval1 (NumSingleType $ IntegralNumType tb) ceiling evalIsNaN :: FloatingType a -> a :-> Bool -evalIsNaN ty | FloatingDict <- floatingDict ty = eval1 isNaN +evalIsNaN ty | FloatingDict <- floatingDict ty = eval1 (NonNumSingleType TypeBool) isNaN evalIsInfinite :: FloatingType a -> a :-> Bool -evalIsInfinite ty | FloatingDict <- floatingDict ty = eval1 isInfinite +evalIsInfinite ty | FloatingDict <- floatingDict ty = eval1 (NonNumSingleType TypeBool) 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 (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (<) +evalLt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (<) +evalLt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (<) -- evalLt (SingleScalarType s) = -- case s of @@ -646,9 +637,9 @@ evalLt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = -- 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 (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (>) +evalGt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (>) +evalGt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (>) -- evalGt (SingleScalarType s) = -- case s of @@ -657,9 +648,9 @@ evalGt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = -- 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 (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (<=) +evalLtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (<=) +evalLtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (<=) -- evalLtEq (SingleScalarType s) = -- case s of @@ -668,9 +659,9 @@ evalLtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty -- 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 (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (>=) +evalGtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (>=) +evalGtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (>=) -- evalGtEq (SingleScalarType s) = -- case s of @@ -679,9 +670,9 @@ evalGtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty -- 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 (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (==) +evalEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (==) +evalEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (==) -- evalEq (SingleScalarType s) = -- case s of @@ -690,9 +681,9 @@ evalEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = -- 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 (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (/=) +evalNEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (/=) +evalNEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (/=) -- evalNEq (SingleScalarType s) = -- case s of @@ -700,10 +691,10 @@ evalNEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = -- 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 :: SingleType a -> (a,a) :-> a +evalMax ty@(NumSingleType (IntegralNumType ty')) | IntegralDict <- integralDict ty' = eval2 ty max +evalMax ty@(NumSingleType (FloatingNumType ty')) | FloatingDict <- floatingDict ty' = eval2 ty max +evalMax ty@(NonNumSingleType ty') | NonNumDict <- nonNumDict ty' = eval2 ty max -- evalMax (SingleScalarType s) = -- case s of @@ -711,10 +702,10 @@ evalMax (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = -- 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 :: SingleType a -> (a,a) :-> a +evalMin ty@(NumSingleType (IntegralNumType ty')) | IntegralDict <- integralDict ty' = eval2 ty min +evalMin ty@(NumSingleType (FloatingNumType ty')) | FloatingDict <- floatingDict ty' = eval2 ty min +evalMin ty@(NonNumSingleType ty') | NonNumDict <- nonNumDict ty' = eval2 ty min -- evalMin (SingleScalarType s) = -- case s of @@ -730,11 +721,11 @@ 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) + else Stats.ruleFired "False &&" $ Const scalarTypeBool False | Just b <- propagate env y = Just $ if b then Stats.ruleFired "True &&" x - else Stats.ruleFired "False &&" $ Const (fromElt False) + else Stats.ruleFired "False &&" $ Const scalarTypeBool False evalLAnd _ _ = Nothing @@ -742,11 +733,11 @@ evalLAnd _ _ 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) + = Just $ if a then Stats.ruleFired "True ||" $ Const scalarTypeBool True else Stats.ruleFired "False ||" y | Just b <- propagate env y - = Just $ if b then Stats.ruleFired "True ||" $ Const (fromElt True) + = Just $ if b then Stats.ruleFired "True ||" $ Const scalarTypeBool True else Stats.ruleFired "False ||" x evalLOr _ _ @@ -754,49 +745,49 @@ evalLOr _ _ evalLNot :: Bool :-> Bool evalLNot x _ | PrimApp PrimLNot x' <- x = Stats.ruleFired "not/not" $ Just x' -evalLNot x env = eval1 not x env +evalLNot x env = eval1 (NonNumSingleType TypeBool) not x env evalOrd :: Char :-> Int -evalOrd = eval1 ord +evalOrd = eval1 (NumSingleType $ IntegralNumType $ TypeInt) ord evalChr :: Int :-> Char -evalChr = eval1 chr +evalChr = eval1 (NonNumSingleType $ TypeChar) chr evalBoolToInt :: Bool :-> Int -evalBoolToInt = eval1 fromEnum +evalBoolToInt = eval1 (NumSingleType $ IntegralNumType $ TypeInt) fromEnum -evalFromIntegral :: Elt b => IntegralType a -> NumType b -> a :-> b +evalFromIntegral :: IntegralType a -> NumType b -> a :-> b evalFromIntegral ta (IntegralNumType tb) | IntegralDict <- integralDict ta - , IntegralDict <- integralDict tb = eval1 fromIntegral + , IntegralDict <- integralDict tb = eval1 (NumSingleType $ IntegralNumType tb) fromIntegral evalFromIntegral ta (FloatingNumType tb) | IntegralDict <- integralDict ta - , FloatingDict <- floatingDict tb = eval1 fromIntegral + , FloatingDict <- floatingDict tb = eval1 (NumSingleType $ FloatingNumType tb) fromIntegral -evalToFloating :: Elt b => NumType a -> FloatingType b -> a :-> b +evalToFloating :: NumType a -> FloatingType b -> a :-> b evalToFloating (IntegralNumType ta) tb x env | IntegralDict <- integralDict ta - , FloatingDict <- floatingDict tb = eval1 realToFrac x env + , FloatingDict <- floatingDict tb = eval1 (NumSingleType $ FloatingNumType tb) realToFrac x env evalToFloating (FloatingNumType ta) tb x env - | TypeHalf FloatingDict <- ta - , TypeHalf FloatingDict <- tb = Just x + | TypeHalf <- ta + , TypeHalf <- tb = Just x - | TypeFloat FloatingDict <- ta - , TypeFloat FloatingDict <- tb = Just x + | TypeFloat <- ta + , TypeFloat <- tb = Just x - | TypeDouble FloatingDict <- ta - , TypeDouble FloatingDict <- tb = Just x + | TypeDouble <- ta + , TypeDouble <- tb = Just x - | TypeFloat FloatingDict <- ta - , TypeDouble FloatingDict <- tb = eval1 float2Double x env + | TypeFloat <- ta + , TypeDouble <- tb = eval1 (NumSingleType $ FloatingNumType tb) float2Double x env - | TypeDouble FloatingDict <- ta - , TypeFloat FloatingDict <- tb = eval1 double2Float x env + | TypeDouble <- ta + , TypeFloat <- tb = eval1 (NumSingleType $ FloatingNumType tb) double2Float x env | FloatingDict <- floatingDict ta - , FloatingDict <- floatingDict tb = eval1 realToFrac x env + , FloatingDict <- floatingDict tb = eval1 (NumSingleType $ FloatingNumType tb) realToFrac x env -- Scalar primitives diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index 036744f69..80d19fe6e 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -46,14 +46,13 @@ module Data.Array.Accelerate.Trafo.Base ( Gamma(..), incExp, prjExp, pushExp, Extend(..), pushArrayEnv, append, bind, Sink(..), sink, sink1, - Supplement(..), bindExps, - - leftHandSideChangeEnv, + PreOpenExp', bindExps, -- Adding new variables to the environment - declareArrays, DeclareArrays(..), + declareVars, DeclareVars(..), - aletBodyIsTrivial, + -- Checks + isIdentity, isIdentityIndexing, ) where -- standard library @@ -68,9 +67,10 @@ import Prelude hiding ( until ) -- friends import Data.Array.Accelerate.AST hiding ( Val(..) ) +import Data.Array.Accelerate.Type import Data.Array.Accelerate.Analysis.Hash import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Sugar ( Array, Arrays, ArraysR(..), Shape, Elt ) +import Data.Array.Accelerate.Array.Representation import Data.Array.Accelerate.Error import Data.Array.Accelerate.Trafo.Substitution @@ -105,12 +105,12 @@ matchOpenAcc :: MatchAcc OpenAcc matchOpenAcc (OpenAcc pacc1) (OpenAcc pacc2) = matchPreOpenAcc matchAcc encodeAcc pacc1 pacc2 avarIn :: forall acc aenv a. Kit acc => ArrayVar aenv a -> acc aenv a -avarIn v@ArrayVar{} = inject $ Avar v +avarIn v@(Var ArrayR{} _) = inject $ Avar v avarsIn :: forall acc aenv arrs. Kit acc => ArrayVars aenv arrs -> acc aenv arrs -avarsIn ArrayVarsNil = inject Anil -avarsIn (ArrayVarsArray v) = avarIn v -avarsIn (ArrayVarsPair a b) = inject $ avarsIn a `Apair` avarsIn b +avarsIn VarsNil = inject Anil +avarsIn (VarsSingle v) = avarIn v +avarsIn (VarsPair a b) = inject $ avarsIn a `Apair` avarsIn b kmap :: Kit acc => (PreOpenAcc acc aenv a -> PreOpenAcc acc aenv b) -> acc aenv a -> acc aenv b kmap f = inject . f . fromJust . extract @@ -118,31 +118,30 @@ kmap f = inject . f . fromJust . extract extractArrayVars :: Kit acc => acc aenv a -> Maybe (ArrayVars aenv a) extractArrayVars (extract -> Just acc) = case acc of Apair (extractArrayVars -> Just a) (extractArrayVars -> Just b) - -> Just $ ArrayVarsPair a b + -> Just $ VarsPair a b Anil - -> Just ArrayVarsNil + -> Just VarsNil Avar v - -> Just $ ArrayVarsArray v + -> Just $ VarsSingle v _ -> Nothing extractArrayVars _ = Nothing -data DeclareArrays arrs aenv where - DeclareArrays - :: LeftHandSide arrs aenv aenv' - -> (aenv :> aenv') - -> (forall aenv''. aenv' :> aenv'' -> ArrayVars aenv'' arrs) - -> DeclareArrays arrs aenv - -declareArrays :: ArraysR arrs -> DeclareArrays arrs aenv -declareArrays ArraysRarray - = DeclareArrays LeftHandSideArray SuccIdx $ \k -> ArrayVarsArray $ ArrayVar $ k ZeroIdx -declareArrays ArraysRunit - = DeclareArrays (LeftHandSideWildcard ArraysRunit) id $ const $ ArrayVarsNil -declareArrays (ArraysRpair r1 r2) = case declareArrays r1 of - DeclareArrays lhs1 subst1 a1 -> case declareArrays r2 of - DeclareArrays lhs2 subst2 a2 -> - DeclareArrays (LeftHandSidePair lhs1 lhs2) (subst2 . subst1) $ \k -> a1 (k . subst2) `ArrayVarsPair` a2 k +data DeclareVars s t aenv where + DeclareVars + :: LeftHandSide s t env env' + -> (env :> env') + -> (forall env''. env' :> env'' -> Vars s env'' t) + -> DeclareVars s t env +declareVars :: TupR s t -> DeclareVars s t env +declareVars (TupRsingle s) + = DeclareVars (LeftHandSideSingle s) (weakenSucc weakenId) $ \k -> VarsSingle $ Var s $ k >:> ZeroIdx +declareVars TupRunit + = DeclareVars (LeftHandSideWildcard TupRunit) weakenId $ const $ VarsNil +declareVars (TupRpair r1 r2) + | DeclareVars lhs1 subst1 a1 <- declareVars r1 + , DeclareVars lhs2 subst2 a2 <- declareVars r2 + = DeclareVars (LeftHandSidePair lhs1 lhs2) (subst2 .> subst1) $ \k -> a1 (k .> subst2) `VarsPair` a2 k -- fromOpenAfun :: Kit acc => OpenAfun aenv f -> PreOpenAfun acc aenv f @@ -159,12 +158,21 @@ instance Match (Idx env) where {-# INLINEABLE match #-} match = matchIdx -instance Match (ArrayVar env) where +instance Match (Var s env) where {-# INLINEABLE match #-} - match (ArrayVar a) (ArrayVar b) + match (Var _ a) (Var _ b) | Just Refl <- match a b = Just Refl | otherwise = Nothing +instance Match ScalarType where + match = matchScalarType + +instance Match ArrayR where + match = matchArrayR + +instance Match a => Match (TupR a) where + match = matchTupR match + instance Kit acc => Match (PreOpenExp acc env aenv) where {-# INLINEABLE match #-} match = matchPreOpenExp matchAcc encodeAcc @@ -208,22 +216,24 @@ type DelayedOpenFun = PreOpenFun DelayedOpenAcc data DelayedOpenAcc aenv a where Manifest :: PreOpenAcc DelayedOpenAcc aenv a -> DelayedOpenAcc aenv a - Delayed :: (Shape sh, Elt e) => - { extentD :: PreExp DelayedOpenAcc aenv sh + Delayed :: + { reprD :: ArrayR (Array sh e) + , extentD :: PreExp DelayedOpenAcc aenv sh , indexD :: PreFun DelayedOpenAcc aenv (sh -> e) , linearIndexD :: PreFun DelayedOpenAcc aenv (Int -> e) } -> DelayedOpenAcc aenv (Array sh e) instance HasArraysRepr DelayedOpenAcc where arraysRepr (Manifest a) = arraysRepr a - arraysRepr Delayed{} = ArraysRarray + arraysRepr Delayed{..} = TupRsingle reprD 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 + Delayed{..} -> Delayed reprD + <$> rebuildPartial v extentD <*> rebuildPartial v indexD <*> rebuildPartial v linearIndexD @@ -266,15 +276,15 @@ encodeDelayedOpenAcc options acc = | otherwise = encodeArraysType . arraysRepr in case acc of - Manifest pacc -> intHost $(hashQ ("Manifest" :: String)) <> deepA pacc - Delayed sh f g -> intHost $(hashQ ("Delayed" :: String)) <> travE sh <> travF f <> travF g + Manifest pacc -> intHost $(hashQ ("Manifest" :: String)) <> deepA pacc + Delayed _ sh f g -> intHost $(hashQ ("Delayed" :: String)) <> travE sh <> travF f <> travF g {-# INLINEABLE matchDelayedOpenAcc #-} matchDelayedOpenAcc :: MatchAcc DelayedOpenAcc matchDelayedOpenAcc (Manifest pacc1) (Manifest pacc2) = matchPreOpenAcc matchDelayedOpenAcc encodeDelayedOpenAcc pacc1 pacc2 -matchDelayedOpenAcc (Delayed sh1 ix1 lx1) (Delayed sh2 ix2 lx2) +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 @@ -284,10 +294,11 @@ 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 +rnfDelayedOpenAcc (Manifest pacc) = rnfPreOpenAcc rnfDelayedOpenAcc pacc +rnfDelayedOpenAcc (Delayed repr sh ix lx) = rnfArrayR repr + `seq` rnfPreOpenExp rnfDelayedOpenAcc sh + `seq` rnfPreOpenFun rnfDelayedOpenAcc ix + `seq` rnfPreOpenFun rnfDelayedOpenAcc lx {-- rnfDelayedSeq :: DelayedSeq t -> () @@ -310,8 +321,7 @@ rnfExtend rnfA (PushEnv env a) = rnfExtend rnfA env `seq` rnfA a data Gamma acc env env' aenv where EmptyExp :: Gamma acc env env' aenv - PushExp :: Elt t - => Gamma acc env env' aenv + PushExp :: Gamma acc env env' aenv -> WeakPreOpenExp acc env aenv t -> Gamma acc env (env', t) aenv @@ -340,18 +350,15 @@ 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 + subs (Subst k (e :: PreOpenExp acc env_ aenv t) _) = Subst (weakenSucc' k) e (weakenE (weakenSucc' k) e) 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 +pushExp :: Gamma acc env env' aenv -> PreOpenExp acc env aenv t -> Gamma acc env (env',t) aenv +pushExp env e = env `PushExp` Subst weakenId e e {-- lookupExp @@ -386,90 +393,57 @@ sinkGamma ext (PushExp env e) = PushExp (sinkGamma ext env) (sink ext e) -- 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 +data Extend s f env env' where + BaseEnv :: Extend s f env env - PushEnv :: Extend acc aenv aenv' - -> LeftHandSide arrs aenv' aenv'' - -> acc aenv' arrs - -> Extend acc aenv aenv'' + PushEnv :: Extend s f env env' + -> LeftHandSide s t env' env'' + -> f env' t + -> Extend s f env env'' + +pushArrayEnv :: HasArraysRepr acc => Extend ArrayR acc aenv aenv' -> acc aenv' (Array sh e) -> Extend ArrayR acc aenv (aenv', Array sh e) +pushArrayEnv env a = PushEnv env (LeftHandSideSingle $ arrayRepr a) a -pushArrayEnv :: (Shape sh, Elt e) => Extend acc aenv aenv' -> acc aenv' (Array sh e) -> Extend acc aenv (aenv', Array sh e) -pushArrayEnv env a = PushEnv env LeftHandSideArray a -- Append two environment witnesses -- -append :: Extend acc env env' -> Extend acc env' env'' -> Extend acc env env'' +append :: Extend s acc env env' -> Extend s acc env' env'' -> Extend s acc env env'' append x BaseEnv = x append x (PushEnv e lhs a) = PushEnv (append x e) lhs 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' +bind :: Kit acc + => Extend ArrayR acc aenv aenv' -> PreOpenAcc acc aenv' a -> PreOpenAcc acc aenv a -bind BaseEnv = id -bind (PushEnv env lhs a) = bind env . Alet lhs a . inject +bind BaseEnv = id +bind (PushEnv g lhs a) = bind g . Alet lhs 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 (LeftHandSideWildcard _) _) = k e - k (PushEnv e (LeftHandSideArray) _) = SuccIdx . k e - k (PushEnv e (LeftHandSidePair l1 l2) _) = k (PushEnv (PushEnv e l1 undefined) l2 undefined) - -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 (LeftHandSideWildcard _) _) = k e - k (PushEnv e (LeftHandSideArray) _) = split . k e - k (PushEnv e (LeftHandSidePair l1 l2) _) = k (PushEnv (PushEnv e l1 undefined) l2 undefined) +-- Rename to sinkA +sink :: Sink f => Extend s acc env env' -> f env t -> f env' t +sink env = weaken (sinkWeaken env) -- TODO: Fix Stats sink vs sink1 - split :: Idx (env,s) t -> Idx ((env,u),s) t - split ZeroIdx = ZeroIdx - split (SuccIdx ix) = SuccIdx (SuccIdx ix) +sinkWeaken :: Extend s acc env env' -> env :> env' +sinkWeaken BaseEnv = Stats.substitution "sink" weakenId +sinkWeaken (PushEnv e (LeftHandSideWildcard _) _) = sinkWeaken e +sinkWeaken (PushEnv e (LeftHandSideSingle _) _) = weakenSucc' $ sinkWeaken e +sinkWeaken (PushEnv e (LeftHandSidePair l1 l2) _) = sinkWeaken (PushEnv (PushEnv e l1 undefined) l2 undefined) +sink1 :: Sink f => Extend s acc env env' -> f (env,t') t -> f (env',t') t +sink1 env = weaken $ shift $ sinkWeaken env --- 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 +-- Wrapper around PreOpenExp, with the order of type arguments env and aenv flipped +newtype PreOpenExp' acc aenv env e = PreOpenExp' (PreOpenExp acc env aenv e) -bindExps :: (Kit acc, Elt e) - => Supplement acc env env' aenv +bindExps :: Kit acc + => Extend ScalarType (PreOpenExp' acc aenv) env env' -> PreOpenExp acc env' aenv e -> PreOpenExp acc env aenv e -bindExps BaseSup = id -bindExps (PushSup g b) = bindExps g . Let b - -leftHandSideChangeEnv :: LeftHandSide arrs env1 env2 -> Exists (LeftHandSide arrs env3) -leftHandSideChangeEnv (LeftHandSideWildcard repr) = Exists $ LeftHandSideWildcard repr -leftHandSideChangeEnv LeftHandSideArray = Exists $ LeftHandSideArray -leftHandSideChangeEnv (LeftHandSidePair l1 l2) = case leftHandSideChangeEnv l1 of - Exists l1' -> case leftHandSideChangeEnv l2 of - Exists l2' -> Exists $ LeftHandSidePair l1' l2' - -aletBodyIsTrivial :: forall acc aenv aenv' a b. Kit acc => LeftHandSide a aenv aenv' -> acc aenv' b -> Maybe (a :~: b) -aletBodyIsTrivial lhs rhs = case extractArrayVars rhs of - Just vars -> case declareArrays @a @aenv (lhsToArraysR lhs) of - DeclareArrays lhs' _ value - | Just Refl <- matchLeftHandSide lhs lhs' - , Just Refl <- matchArrayVars vars $ value id - -> Just Refl - _ -> Nothing - Nothing -> Nothing +bindExps BaseEnv = id +bindExps (PushEnv g lhs (PreOpenExp' b)) = bindExps g . Let lhs b diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index da4371271..d0819cb05 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -51,7 +50,6 @@ import Control.Monad.Fix import Data.Hashable import Data.List hiding ( (\\) ) import Data.Maybe -import Data.Typeable import System.IO.Unsafe ( unsafePerformIO ) import System.Mem.StableName import Text.Printf @@ -63,15 +61,18 @@ import Prelude -- friends import Data.BitSet ( (\\), member ) +import Data.Array.Accelerate.Type import Data.Array.Accelerate.Error import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Trafo.Base import Data.Array.Accelerate.Trafo.Config -import Data.Array.Accelerate.Array.Sugar as Sugar hiding ( (!!) ) +import Data.Array.Accelerate.Array.Representation hiding ((!!)) +import Data.Array.Accelerate.Array.Sugar ( Elt, EltRepr, Arrays, ArrRepr, eltType ) +import qualified 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 ) + , PreBoundary(..), Boundary + , showPreAccOp, showPreExpOp, expType, HasArraysRepr(..), arraysRepr ) import qualified Data.Array.Accelerate.AST as AST import Data.Array.Accelerate.Debug.Trace as Debug import Data.Array.Accelerate.Debug.Flags as Debug @@ -84,84 +85,54 @@ import Data.Array.Accelerate.Debug.Flags as Debug -- 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) +data Layout s env env' where + EmptyLayout :: Layout s env () + PushLayout :: Layout s env env1 + -> LeftHandSide s t env1 env2 + -> Vars s env t + -> Layout s env env2 + +type ELayout = Layout ScalarType +type ArrayLayout = Layout ArrayR -data ArrayLayout env env' where - ArrayEmptyLayout :: ArrayLayout env () - ArrayPushLayout - :: Typeable t - => ArrayLayout env env1 - -> LeftHandSide t env1 env2 - -> ArrayVars env t - -> ArrayLayout env env2 -- 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 +prjIdx :: forall s t env env1. Match s => String + -> (forall t'. TupR s t' -> ShowS) + -> TupR s t -> Int - -> Layout env env' - -> Idx env t -prjIdx context = go + -> Layout s env env1 + -> Vars s env t +prjIdx context showTp tp = go where - go :: forall env env' t. Typeable t => Int -> Layout env env' -> Idx env t + go :: forall env'. Int -> Layout s env env' -> Vars s env t go _ EmptyLayout = no "environment does not contain index" - go 0 (PushLayout _ (ix :: Idx env0 s)) - | Just ix' <- gcast ix = ix' + go 0 (PushLayout _ lhs vars) + | Just Refl <- match tp tp' = vars | 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 + (showTp tp "") + (showTp tp' "") + where + tp' = lhsToTupR lhs + go n (PushLayout l _ _) = go (n-1) l no :: String -> a no reason = $internalError "prjIdx" (printf "%s\nin the context: %s" reason context) -prjArrayIdx :: Typeable t - => String - -> Int - -> ArrayLayout env env' - -> AST.OpenAcc env t -prjArrayIdx context = go - where - go :: forall env env' t. Typeable t => Int -> ArrayLayout env env' -> AST.OpenAcc env t - go _ ArrayEmptyLayout = no "environment does not contain index" - go 0 (ArrayPushLayout _ _ (ix :: ArrayVars env0 s)) - | Just ix' <- gcast ix = avarsIn ix' - | otherwise = no $ printf "couldn't match expected type `%s' with actual type `%s'" - (show (typeOf (undefined::t))) - (show (typeOf (undefined::s))) - go n (ArrayPushLayout l _ _) = go (n-1) l - - no :: String -> a - no reason = $internalError "prjArrayIdx" (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) - -incArrayLayoutWith :: env1 :> env2 -> ArrayLayout env1 env' -> ArrayLayout env2 env' -incArrayLayoutWith _ ArrayEmptyLayout = ArrayEmptyLayout -incArrayLayoutWith k (ArrayPushLayout lyt lhs t) = ArrayPushLayout (incArrayLayoutWith k lyt) lhs (incVarsWith k t) - -sizeLayout :: Layout env env' -> Int -sizeLayout EmptyLayout = 0 -sizeLayout (PushLayout lyt _) = 1 + sizeLayout lyt +incLayout :: env1 :> env2 -> Layout s env1 env' -> Layout s env2 env' +incLayout _ EmptyLayout = EmptyLayout +incLayout k (PushLayout lyt lhs v) = PushLayout (incLayout k lyt) lhs (weaken k v) -sizeArrayLayout :: ArrayLayout env env' -> Int -sizeArrayLayout ArrayEmptyLayout = 0 -sizeArrayLayout (ArrayPushLayout lyt _ _) = 1 + sizeArrayLayout lyt - -incVarsWith :: env1 :> env2 -> ArrayVars env1 t -> ArrayVars env2 t -incVarsWith _ ArrayVarsNil = ArrayVarsNil -incVarsWith k (ArrayVarsArray (ArrayVar idx)) = ArrayVarsArray $ ArrayVar $ k idx -incVarsWith k (ArrayVarsPair v1 v2) = incVarsWith k v1 `ArrayVarsPair` incVarsWith k v2 +sizeLayout :: Layout s env env' -> Int +sizeLayout EmptyLayout = 0 +sizeLayout (PushLayout lyt _ _) = 1 + sizeLayout lyt -- Conversion from HOAS to de Bruijn computation AST -- ================================================= @@ -176,7 +147,7 @@ convertAcc :: Arrays arrs => Acc arrs -> AST.Acc (ArrRepr arrs) convertAcc = convertAccWith defaultOptions convertAccWith :: Arrays arrs => Config -> Acc arrs -> AST.Acc (ArrRepr arrs) -convertAccWith config (Acc acc) = convertOpenAcc config ArrayEmptyLayout acc +convertAccWith config (Acc acc) = convertOpenAcc config EmptyLayout acc -- | Convert a closed function over array computations, while incorporating @@ -186,7 +157,7 @@ convertAfun :: Afunction f => f -> AST.Afun (AreprFunctionR f) convertAfun = convertAfunWith defaultOptions convertAfunWith :: Afunction f => Config -> f -> AST.Afun (AreprFunctionR f) -convertAfunWith config = convertOpenAfun config ArrayEmptyLayout +convertAfunWith config = convertOpenAfun config EmptyLayout data AfunctionRepr f ar areprr where AfunctionReprBody @@ -215,12 +186,14 @@ instance (Arrays a, Afunction r) => Afunction (Acc a -> r) where type AreprFunctionR (Acc a -> r) = ArrRepr a -> AreprFunctionR r afunctionRepr = AfunctionReprLam $ afunctionRepr @r - convertOpenAfun config alyt f = case declareArrays $ arrays @a of - DeclareArrays lhs k value -> + convertOpenAfun config alyt f + | repr <- Sugar.arrays @a + , DeclareVars lhs k value <- declareVars repr = let - a = Acc $ SmartAcc $ Atag $ sizeArrayLayout alyt - alyt' = ArrayPushLayout (incArrayLayoutWith k alyt) lhs (value id) - in Alam lhs $ convertOpenAfun config alyt' $ f a + a = Acc $ SmartAcc $ Atag repr $ sizeLayout alyt + alyt' = PushLayout (incLayout k alyt) lhs (value weakenId) + in + Alam lhs $ convertOpenAfun config alyt' $ f a instance Arrays b => Afunction (Acc b) where type AfunctionR (Acc b) = b @@ -233,13 +206,12 @@ instance Arrays b => Afunction (Acc b) where -- information. -- convertOpenAcc - :: Typeable arrs - => Config + :: Config -> ArrayLayout aenv aenv -> SmartAcc arrs -> AST.OpenAcc aenv arrs convertOpenAcc config alyt acc = - let lvl = sizeArrayLayout alyt + let lvl = sizeLayout alyt fvs = [lvl-1, lvl-2 .. 0] (sharingAcc, initialEnv) = recoverSharingAcc config lvl fvs acc in @@ -254,15 +226,15 @@ convertOpenAcc config alyt acc = -- in reverse chronological order (outermost variable is at the end of the list). -- convertSharingAcc - :: forall aenv arrs. Typeable arrs - => Config + :: forall aenv arrs. + Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -> ScopedAcc arrs -> AST.OpenAcc aenv arrs -convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa)) +convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa repr)) | Just i <- findIndex (matchStableAcc sa) aenv' - = prjArrayIdx (ctxt ++ "; i = " ++ show i) i alyt + = avarsIn $ prjIdx (ctxt ++ "; i = " ++ show i) showArraysR repr i alyt | null aenv' = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++ show (hashStableNameHeight sa) ++ ")" @@ -274,10 +246,10 @@ convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa)) err = "inconsistent valuation @ " ++ ctxt ++ ";\n aenv = " ++ show aenv' convertSharingAcc config alyt aenv (ScopedAcc lams (AletSharing sa@(StableSharingAcc (_ :: StableAccName as) boundAcc) bodyAcc)) - = case declareArrays $ arraysRepr bound of - DeclareArrays lhs k value -> + = case declareVars $ AST.arraysRepr bound of + DeclareVars lhs k value -> let - alyt' = ArrayPushLayout (incArrayLayoutWith k alyt) lhs (value id) + alyt' = PushLayout (incLayout k alyt) lhs (value weakenId) in AST.OpenAcc $ AST.Alet lhs @@ -291,50 +263,47 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) = AST.OpenAcc $ let aenv' = lams ++ aenv - cvtA :: Typeable a => ScopedAcc a -> AST.OpenAcc aenv a + cvtA :: ScopedAcc a -> AST.OpenAcc aenv a cvtA = convertSharingAcc config alyt aenv' - cvtE :: Elt t => ScopedExp t -> AST.Exp aenv t + cvtE :: 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 :: TupleType a -> (SmartExp 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 :: TupleType a -> TupleType b -> (SmartExp a -> SmartExp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c) cvtF2 = convertSharingFun2 config alyt aenv' - cvtAfun1 :: (Typeable a, Typeable b) => ArraysR a -> (SmartAcc a -> ScopedAcc b) -> AST.OpenAfun aenv (a -> b) + cvtAfun1 :: ArraysR a -> (SmartAcc a -> ScopedAcc b) -> AST.OpenAfun aenv (a -> b) cvtAfun1 = convertSharingAfun1 config alyt aenv' - cvtAprj :: forall a b c. (Typeable a, Typeable b) => PairIdx (a, b) c -> ScopedAcc (a, b) -> AST.OpenAcc aenv c + cvtAprj :: forall a b c. PairIdx (a, b) c -> ScopedAcc (a, b) -> AST.OpenAcc aenv c cvtAprj ix a = cvtAprj' ix $ cvtA a - cvtAprj' :: forall a b c aenv1. (Typeable a, Typeable b) => PairIdx (a, b) c -> AST.OpenAcc aenv1 (a, b) -> AST.OpenAcc aenv1 c + cvtAprj' :: forall a b c aenv1. PairIdx (a, b) c -> AST.OpenAcc aenv1 (a, b) -> AST.OpenAcc aenv1 c cvtAprj' PairIdxLeft (AST.OpenAcc (AST.Apair a _)) = a cvtAprj' PairIdxRight (AST.OpenAcc (AST.Apair _ b)) = b - cvtAprj' ix a = case declareArrays $ arraysRepr a of - DeclareArrays lhs _ value -> - AST.OpenAcc $ AST.Alet lhs a $ cvtAprj' ix $ avarsIn $ value id + cvtAprj' ix a = case declareVars $ AST.arraysRepr a of + DeclareVars lhs _ value -> + AST.OpenAcc $ AST.Alet lhs a $ cvtAprj' ix $ avarsIn $ value weakenId in case preAcc of - Atag i - -> let AST.OpenAcc a = prjArrayIdx ("de Bruijn conversion tag " ++ show i) i alyt + Atag repr i + -> let AST.OpenAcc a = avarsIn $ prjIdx ("de Bruijn conversion tag " ++ show i) showArraysR repr i alyt in a - Pipe reprA reprB (afun1 :: SmartAcc as -> ScopedAcc bs) (afun2 :: SmartAcc bs -> ScopedAcc cs) acc - -> + Pipe reprA reprB _ (afun1 :: SmartAcc as -> ScopedAcc bs) (afun2 :: SmartAcc bs -> ScopedAcc cs) acc + | DeclareVars lhs k value <- declareVars reprB -> let noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ()) boundAcc = AST.Apply (cvtAfun1 reprA afun1) (cvtA acc) - in case declareArrays reprB of - DeclareArrays lhs k value -> - let - alyt' = ArrayPushLayout (incArrayLayoutWith k alyt) lhs (value id) - bodyAcc = AST.Apply - (convertSharingAfun1 config alyt' (noStableSharing : aenv') reprB afun2) - (avarsIn $ value id) - in AST.Alet lhs (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) + alyt' = PushLayout (incLayout k alyt) lhs (value weakenId) + bodyAcc = AST.Apply + (convertSharingAfun1 config alyt' (noStableSharing : aenv') reprB afun2) + (avarsIn $ value weakenId) + in AST.Alet lhs (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) Aforeign ff afun acc -> AST.Aforeign ff (convertAfunWith config afun) (cvtA acc) @@ -345,35 +314,45 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) Apair acc1 acc2 -> AST.Apair (cvtA acc1) (cvtA acc2) Aprj ix a -> let AST.OpenAcc a' = cvtAprj ix a in a' - Use array -> AST.Use 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) + Use repr array -> AST.Use repr array + Unit _ e -> AST.Unit (cvtE e) + Generate repr@(ArrayR shr _) sh f + -> AST.Generate repr (cvtE sh) (cvtF1 (shapeType shr) f) + Reshape shr e acc -> AST.Reshape shr (cvtE e) (cvtA acc) + Replicate si ix acc -> AST.Replicate si (cvtE ix) (cvtA acc) + Slice si acc ix -> AST.Slice si (cvtA acc) (cvtE ix) + Map t1 t2 f acc -> AST.Map t2 (cvtF1 t1 f) (cvtA acc) + ZipWith t1 t2 t3 f acc1 acc2 + -> AST.ZipWith t3 (cvtF2 t1 t2 f) (cvtA acc1) (cvtA acc2) + Fold tp f e acc -> AST.Fold (cvtF2 tp tp f) (cvtE e) (cvtA acc) + Fold1 tp f acc -> AST.Fold1 (cvtF2 tp tp f) (cvtA acc) + FoldSeg i tp f e acc1 acc2 -> AST.FoldSeg i (cvtF2 tp tp f) (cvtE e) (cvtA acc1) (cvtA acc2) + Fold1Seg i tp f acc1 acc2 -> AST.Fold1Seg i (cvtF2 tp tp f) (cvtA acc1) (cvtA acc2) + Scanl tp f e acc -> AST.Scanl (cvtF2 tp tp f) (cvtE e) (cvtA acc) + Scanl' tp f e acc -> AST.Scanl' (cvtF2 tp tp f) (cvtE e) (cvtA acc) + Scanl1 tp f acc -> AST.Scanl1 (cvtF2 tp tp f) (cvtA acc) + Scanr tp f e acc -> AST.Scanr (cvtF2 tp tp f) (cvtE e) (cvtA acc) + Scanr' tp f e acc -> AST.Scanr' (cvtF2 tp tp f) (cvtE e) (cvtA acc) + Scanr1 tp f acc -> AST.Scanr1 (cvtF2 tp tp f) (cvtA acc) + Permute (ArrayR shr tp) f dftAcc perm acc + -> AST.Permute (cvtF2 tp tp f) (cvtA dftAcc) (cvtF1 (shapeType shr) perm) (cvtA acc) + Backpermute shr newDim perm acc + -> AST.Backpermute shr (cvtE newDim) (cvtF1 (shapeType shr) perm) (cvtA acc) + Stencil stencil tp f boundary acc + -> AST.Stencil stencil + tp + (convertSharingStencilFun1 config alyt aenv' stencil f) + (convertSharingBoundary config alyt aenv' (stencilShape stencil) boundary) (cvtA acc) - Stencil2 stencil bndy1 acc1 bndy2 acc2 - -> AST.Stencil2 (convertSharingStencilFun2 config acc1 acc2 alyt aenv' stencil) - (convertSharingBoundary config alyt aenv' bndy1) + Stencil2 stencil1 stencil2 tp f bndy1 acc1 bndy2 acc2 + | shr <- stencilShape stencil1 + -> AST.Stencil2 stencil1 + stencil2 + tp + (convertSharingStencilFun2 config alyt aenv' stencil1 stencil2 f) + (convertSharingBoundary config alyt aenv' shr bndy1) (cvtA acc1) - (convertSharingBoundary config alyt aenv' bndy2) + (convertSharingBoundary config alyt aenv' shr bndy2) (cvtA acc2) -- Collect seq -> AST.Collect (convertSharingSeq config alyt EmptyLayout aenv' [] seq) @@ -526,84 +505,43 @@ convertSharingSeq config alyt slyt aenv senv s --} convertSharingAfun1 - :: forall aenv a b. (Typeable a, Typeable b) - => Config + :: forall aenv a b. + Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -> ArraysR a -> (SmartAcc a -> ScopedAcc b) -> OpenAfun aenv (a -> b) -convertSharingAfun1 config alyt aenv reprA f = case declareArrays reprA of - DeclareArrays lhs k value -> +convertSharingAfun1 config alyt aenv reprA f + | DeclareVars lhs k value <- declareVars reprA = let - alyt' = ArrayPushLayout (incArrayLayoutWith k alyt) lhs (value id) + alyt' = PushLayout (incLayout k alyt) lhs (value weakenId) body = f undefined in Alam lhs (Abody (convertSharingAcc config alyt' aenv body)) -{-- -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 ---} - -- | Convert a boundary condition -- convertSharingBoundary - :: forall aenv t. + :: forall aenv sh e. Config -> ArrayLayout aenv aenv -> [StableSharingAcc] - -> PreBoundary ScopedAcc ScopedExp t - -> AST.PreBoundary AST.OpenAcc aenv t -convertSharingBoundary config alyt aenv = cvt + -> ShapeR sh + -> PreBoundary ScopedAcc ScopedExp (Array sh e) + -> AST.PreBoundary AST.OpenAcc aenv (Array sh e) +convertSharingBoundary config alyt aenv shr = cvt where - cvt :: PreBoundary ScopedAcc ScopedExp t -> AST.Boundary aenv t + cvt :: PreBoundary ScopedAcc ScopedExp (Array sh e) -> AST.Boundary aenv (Array sh e) 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 + Constant v -> AST.Constant v + Function f -> AST.Function $ convertSharingFun1 config alyt aenv (shapeType shr) 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) - -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) - -- 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) @@ -624,29 +562,50 @@ mkReplicate = AST.Replicate (sliceIndex @slix) -- In higher-order abstract syntax, this represents an n-ary, polyvariadic -- function. -- -convertFun :: Function f => f -> AST.Fun () (FunctionR f) +convertFun :: Function f => f -> AST.Fun () (EltReprFunctionR f) convertFun = convertFunWith $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing, float_out_acc] } -convertFunWith :: Function f => Config -> f -> AST.Fun () (FunctionR f) +convertFunWith :: Function f => Config -> f -> AST.Fun () (EltReprFunctionR f) convertFunWith config = convertOpenFun config EmptyLayout +data FunctionRepr f r reprr where + FunctionReprBody + :: Elt b => FunctionRepr (Exp b) b (EltRepr b) + + FunctionReprLam + :: Elt a + => FunctionRepr b br breprr + -> FunctionRepr (Exp a -> b) (a -> br) (EltRepr a -> breprr) + class Function f where type FunctionR f - convertOpenFun :: Config -> Layout env env -> f -> AST.OpenFun env () (FunctionR f) + type EltReprFunctionR f + + functionRepr :: FunctionRepr f (FunctionR f) (EltReprFunctionR f) + convertOpenFun :: Config -> ELayout env env -> f -> AST.OpenFun env () (EltReprFunctionR f) instance (Elt a, Function r) => Function (Exp a -> r) where type FunctionR (Exp a -> r) = a -> FunctionR r - convertOpenFun config lyt f = - let x = Exp $ Tag (sizeLayout lyt) - lyt' = incLayout lyt `PushLayout` ZeroIdx - in Lam $ convertOpenFun config lyt' (f x) + type EltReprFunctionR (Exp a -> r) = EltRepr a -> EltReprFunctionR r + + functionRepr = FunctionReprLam $ functionRepr @r + convertOpenFun config lyt f + | tp <- eltType @a + , DeclareVars lhs k value <- declareVars tp = + let + e = Exp $ SmartExp $ Tag tp $ sizeLayout lyt + lyt' = PushLayout (incLayout k lyt) lhs (value weakenId) + in + Lam lhs $ convertOpenFun config lyt' $ f e instance Elt b => Function (Exp b) where type FunctionR (Exp b) = b - convertOpenFun config lyt body = Body $ convertOpenExp config lyt body + type EltReprFunctionR (Exp b) = EltRepr b + functionRepr = FunctionReprBody + convertOpenFun config lyt (Exp body) = Body $ convertOpenExp config lyt body -- Scalar expressions -- ------------------ @@ -654,26 +613,25 @@ instance Elt b => Function (Exp b) where -- | Convert a closed scalar expression to de Bruijn form while incorporating -- sharing information. -- -convertExp :: Elt e => Exp e -> AST.Exp () e +convertExp :: SmartExp e -> AST.Exp () e convertExp = convertExpWith $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing, float_out_acc] } -convertExpWith :: Elt e => Config -> Exp e -> AST.Exp () e +convertExpWith :: Config -> SmartExp e -> AST.Exp () e convertExpWith config = convertOpenExp config EmptyLayout convertOpenExp - :: Elt e - => Config - -> Layout env env - -> Exp e + :: Config + -> ELayout env env + -> SmartExp e -> AST.OpenExp env () e convertOpenExp config lyt exp = let lvl = sizeLayout lyt fvs = [lvl-1, lvl-2 .. 0] (sharingExp, initialEnv) = recoverSharingExp config lvl fvs exp in - convertSharingExp config lyt ArrayEmptyLayout initialEnv [] sharingExp + convertSharingExp config lyt EmptyLayout initialEnv [] sharingExp -- | Convert an open expression with given environment layouts and sharing information into @@ -684,9 +642,9 @@ convertOpenExp config lyt exp = -- 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 + :: forall t env aenv. + Config + -> ELayout env env -- scalar environment -> ArrayLayout aenv aenv -- array environment -> [StableSharingExp] -- currently bound sharing variables of expressions -> [StableSharingAcc] -- currently bound sharing variables of array computations @@ -697,9 +655,9 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp -- 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) + cvt :: ScopedExp t' -> AST.OpenExp env aenv t' + cvt (ScopedExp _ (VarSharing se tp)) + | Just i <- findIndex (matchStableExp se) env' = evars (prjIdx (ctx i) showType tp i lyt) | otherwise = $internalError "convertSharingExp" msg where ctx i = printf "shared 'Exp' tree with stable name %d; i=%d" (hashStableNameHeight se) i @@ -747,161 +705,123 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp ] 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) + | DeclareVars lhs k value <- declareVars $ expType boundExp + = let + lyt' = PushLayout (incLayout k lyt) lhs (value weakenId) + in + AST.Let lhs (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) + Tag tp i -> evars $ prjIdx ("de Bruijn conversion tag " ++ show i) showType tp i lyt + Const tp v -> AST.Const tp v + Undef tp -> AST.Undef tp + Prj idx e -> cvtPrj idx (cvt e) + Nil -> AST.Nil + Pair e1 e2 -> AST.Pair (cvt e1) (cvt e2) + ToIndex shr sh ix -> AST.ToIndex shr (cvt sh) (cvt ix) + FromIndex shr sh e -> AST.FromIndex shr (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) + While tp p it i -> AST.While (cvtFun1 tp p) (cvtFun1 tp 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) + 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 shr e -> AST.ShapeSize shr (cvt e) Foreign ff f e -> AST.Foreign ff (convertFunWith config f) (cvt e) - Coerce e -> AST.Coerce (cvt e) + Coerce t1 t2 e -> AST.Coerce t1 t2 (cvt e) - cvtA :: Typeable a => ScopedAcc a -> AST.OpenAcc aenv a - cvtA = convertSharingAcc config alyt aenv + cvtPrj :: forall a b c env1 aenv1. PairIdx (a, b) c -> AST.OpenExp env1 aenv1 (a, b) -> AST.OpenExp env1 aenv1 c + cvtPrj PairIdxLeft (AST.Pair a _) = a + cvtPrj PairIdxRight (AST.Pair _ b) = b + cvtPrj ix a + | DeclareVars lhs _ value <- declareVars $ AST.expType a + = AST.Let lhs a $ cvtPrj ix $ evars $ value weakenId - cvtT :: Tuple ScopedExp tup -> Tuple (AST.OpenExp env aenv) tup - cvtT = convertSharingTuple config lyt alyt env' aenv + cvtA :: ScopedAcc a -> AST.OpenAcc aenv a + cvtA = convertSharingAcc config alyt 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 + cvtFun1 :: TupleType a -> (SmartExp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b) + cvtFun1 tp f + | DeclareVars lhs k value <- declareVars tp = + let + lyt' = PushLayout (incLayout k lyt) lhs (value weakenId) + body = f undefined + in + Lam lhs $ Body $ convertSharingExp config lyt' alyt env' aenv body -- 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 :: 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 - -> ArrayLayout 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 + AST.Let lhs bnd body -> AST.Let lhs bnd (cvtPrimFun f body) + x -> AST.PrimApp f x -- | Convert a unary functions -- convertSharingFun1 - :: forall a b aenv. (Elt a, Elt b) - => Config + :: Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables - -> (Exp a -> ScopedExp b) + -> TupleType a + -> (SmartExp 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) +convertSharingFun1 config alyt aenv tp f + | DeclareVars lhs _ value <- declareVars tp = + let + a = SmartExp undefined -- the 'tag' was already embedded in Phase 1 + lyt = PushLayout EmptyLayout lhs (value weakenId) + openF = convertSharingExp config lyt alyt [] aenv (f a) + in + Lam lhs (Body openF) -- | Convert a binary functions -- convertSharingFun2 - :: forall a b c aenv. (Elt a, Elt b, Elt c) - => Config + :: Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables - -> (Exp a -> Exp b -> ScopedExp c) + -> TupleType a + -> TupleType b + -> (SmartExp a -> SmartExp 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) +convertSharingFun2 config alyt aenv ta tb f + | DeclareVars lhs1 _ value1 <- declareVars ta + , DeclareVars lhs2 k2 value2 <- declareVars tb = + let + a = SmartExp undefined + b = SmartExp undefined + lyt1 = PushLayout EmptyLayout lhs1 (value1 k2) + lyt2 = PushLayout lyt1 lhs2 (value2 weakenId) + openF = convertSharingExp config lyt2 alyt [] aenv (f a b) + in + Lam lhs1 $ Lam lhs2 $ Body openF -- | 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 + :: Config -> ArrayLayout 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 @sh @a stencil) - openStencilFun = convertSharingExp config lyt alyt [] aenv body + -> StencilR sh a stencil + -> (SmartExp stencil -> ScopedExp b) + -> AST.Fun aenv (stencil -> b) +convertSharingStencilFun1 config alyt aenv stencil stencilFun + = convertSharingFun1 config alyt aenv (stencilType stencil) stencilFun -- | 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 + :: Config -> ArrayLayout 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 @sh @a stencil1) (stencilPrj @sh @b stencil2) - openStencilFun = convertSharingExp config lyt alyt [] aenv body + -> StencilR sh a stencil1 + -> StencilR sh b stencil2 + -> (SmartExp stencil1 -> SmartExp stencil2 -> ScopedExp c) + -> AST.Fun aenv (stencil1 -> stencil2 -> c) +convertSharingStencilFun2 config alyt aenv stencil1 stencil2 stencilFun + = convertSharingFun2 config alyt aenv (stencilType stencil1) (stencilType stencil2) stencilFun -- Sharing recovery @@ -968,15 +888,13 @@ convertSharingStencilFun2 config _ _ alyt aenv stencilFun = Lam (Lam (Body openS -- 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 + StableASTName :: 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 + StableASTName sn1 == StableASTName sn2 = eqStableName sn1 sn2 instance Hashable (StableASTName c) where hashWithSalt s (StableASTName sn) = hashWithSalt s sn @@ -989,7 +907,7 @@ makeStableAST e = e `seq` makeStableName e data StableNameHeight t = StableNameHeight (StableName t) Int instance Eq (StableNameHeight t) where - (StableNameHeight sn1 _) == (StableNameHeight sn2 _) = sn1 == sn2 + (StableNameHeight sn1 _) == (StableNameHeight sn2 _) = eqStableName sn1 sn2 higherSNH :: StableNameHeight t1 -> StableNameHeight t2 -> Bool StableNameHeight _ h1 `higherSNH` StableNameHeight _ h2 = h1 > h2 @@ -1074,7 +992,7 @@ lookupWithSharingAcc oc (StableSharingAcc (StableNameHeight 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 :: OccMap SmartExp -> StableSharingExp -> Int lookupWithSharingExp oc (StableSharingExp (StableNameHeight sn _) _) = lookupWithASTName oc (StableASTName sn) @@ -1084,33 +1002,44 @@ lookupWithSharingExp oc (StableSharingExp (StableNameHeight sn _) _) -- Stable name for 'SmartAcc' nodes including the height of the AST. -- -type StableAccName arrs = StableNameHeight (SmartAcc arrs) +type StableAccName t = StableNameHeight (SmartAcc t) -- 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 :: Typeable arrs - => StableAccName arrs -> SharingAcc acc exp arrs + AvarSharing :: StableAccName arrs -> ArraysR arrs -> SharingAcc acc exp arrs AletSharing :: StableSharingAcc -> acc arrs -> SharingAcc acc exp arrs - AccSharing :: Typeable arrs - => StableAccName arrs -> PreSmartAcc acc exp arrs -> SharingAcc acc exp arrs + AccSharing :: StableAccName arrs -> PreSmartAcc acc exp arrs -> SharingAcc acc exp arrs + +instance HasArraysRepr acc => HasArraysRepr (SharingAcc acc exp) where + arraysRepr (AvarSharing _ repr) = repr + arraysRepr (AletSharing _ acc) = arraysRepr acc + arraysRepr (AccSharing _ acc) = arraysRepr acc + -- 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) +instance HasArraysRepr UnscopedAcc where + arraysRepr (UnscopedAcc _ acc) = arraysRepr acc + + -- 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) +instance HasArraysRepr ScopedAcc where + arraysRepr (ScopedAcc _ acc) = arraysRepr acc + + -- Stable name for an array computation associated with its sharing-annotated version. -- data StableSharingAcc where - StableSharingAcc :: Typeable arrs - => StableAccName arrs + StableSharingAcc :: StableAccName arrs -> SharingAcc ScopedAcc ScopedExp arrs -> StableSharingAcc @@ -1118,19 +1047,17 @@ 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 + StableSharingAcc (StableNameHeight sn1 _) _ == StableSharingAcc (StableNameHeight sn2 _) _ + = eqStableName sn1 sn2 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 +matchStableAcc :: StableAccName arrs -> StableSharingAcc -> Bool +matchStableAcc (StableNameHeight sn1 _) (StableSharingAcc (StableNameHeight sn2 _) _) + = eqStableName sn1 sn2 -- Dummy entry for environments to be used for unused variables. -- @@ -1143,58 +1070,64 @@ noStableAccName = unsafePerformIO $ StableNameHeight <$> makeStableName undefine -- Stable name for 'Exp' nodes including the height of the AST. -- -type StableExpName t = StableNameHeight (Exp t) +type StableExpName t = StableNameHeight (SmartExp 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 + VarSharing :: StableExpName t -> TupleType t -> SharingExp acc exp t + LetSharing :: StableSharingExp -> exp t -> SharingExp acc exp t + ExpSharing :: StableExpName t -> PreSmartExp acc exp t -> SharingExp acc exp t + +instance HasExpType exp => HasExpType (SharingExp acc exp) where + expType (VarSharing _ tp) = tp + expType (LetSharing _ exp) = expType exp + expType (ExpSharing _ exp) = expType exp -- 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) +instance HasExpType UnscopedExp where + expType (UnscopedExp _ exp) = expType exp + -- 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) +instance HasExpType ScopedExp where + expType (ScopedExp _ exp) = expType exp + -- Expressions rooted in 'SmartAcc' computations. -- -- * When counting occurrences, the root of every expression embedded in an 'SmartAcc' is annotated by -- an occurrence map for that one expression (excluding any subterms that are rooted in embedded -- 'SmartAcc's.) -- -data RootExp t = RootExp (OccMap Exp) (UnscopedExp t) +data RootExp t = RootExp (OccMap SmartExp) (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 + StableSharingExp :: 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 + StableSharingExp (StableNameHeight sn1 _) _ == StableSharingExp (StableNameHeight sn2 _) _ = + eqStableName sn1 sn2 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 +matchStableExp :: StableExpName t -> StableSharingExp -> Bool +matchStableExp (StableNameHeight sn1 _) (StableSharingExp (StableNameHeight sn2 _) _) = eqStableName sn1 sn2 -- Dummy entry for environments to be used for unused variables. -- @@ -1295,8 +1228,7 @@ matchStableSeq sn1 (StableSharingSeq sn2 _) -- They are /not/ directly used to compute the de Brujin indices. -- makeOccMapAcc - :: Typeable arrs - => Config + :: Config -> Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, OccMap SmartAcc) @@ -1310,41 +1242,42 @@ makeOccMapAcc config lvl acc = do makeOccMapSharingAcc - :: Typeable arrs - => Config + :: Config -> OccMapHash SmartAcc -> Level -> SmartAcc 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 :: Level -> TupleType a -> (SmartExp a -> SmartExp b) -> IO (SmartExp 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 :: Level + -> TupleType a + -> TupleType b + -> (SmartExp a -> SmartExp b -> SmartExp c) + -> IO (SmartExp a -> SmartExp b -> RootExp c, Int) traverseFun2 = makeOccMapFun2 config accOccMap - traverseAfun1 :: (Typeable a, Typeable b) => Level -> (SmartAcc a -> SmartAcc b) -> IO (SmartAcc a -> UnscopedAcc b, Int) + traverseAfun1 :: Level -> ArraysR a -> (SmartAcc a -> SmartAcc b) -> IO (SmartAcc a -> UnscopedAcc b, Int) traverseAfun1 = makeOccMapAfun1 config accOccMap - traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int) + traverseExp :: Level -> SmartExp e -> IO (RootExp e, Int) traverseExp = makeOccMapExp config accOccMap traverseBoundary :: Level - -> PreBoundary SmartAcc Exp t - -> IO (PreBoundary UnscopedAcc RootExp t, Int) - traverseBoundary lvl bndy = + -> ShapeR sh + -> PreBoundary SmartAcc SmartExp (Array sh e) + -> IO (PreBoundary UnscopedAcc RootExp (Array sh e), Int) + traverseBoundary lvl shr 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 + (f', h) <- traverseFun1 lvl (shapeType shr) f return (Function f', h) -- traverseSeq :: forall arrs. Typeable arrs @@ -1352,7 +1285,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc -- -> IO (RootSeq arrs, Int) -- traverseSeq = makeOccMapRootSeq config accOccMap - traverseAcc :: forall arrs. Typeable arrs => Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) + traverseAcc :: forall arrs. Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) traverseAcc lvl acc@(SmartAcc pacc) = mfix $ \ ~(_, height) -> do -- Compute stable name and enter it into the occurrence map @@ -1371,169 +1304,168 @@ makeOccMapSharingAcc config accOccMap = traverseAcc -- 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 :: IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) -> IO (UnscopedAcc arrs, Int) reconstruct newAcc = case heightIfRepeatedOccurrence of Just height | acc_sharing `member` options config - -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height)), height) + -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height) (arraysRepr pacc)), 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 repr1 repr2 afun1 afun2 acc - -> reconstruct $ do - (afun1', h1) <- traverseAfun1 lvl afun1 - (afun2', h2) <- traverseAfun1 lvl afun2 + reconstruct $ case pacc of + Atag repr i -> return (Atag repr i, 0) -- height is 0! + Pipe repr1 repr2 repr3 afun1 afun2 acc + -> do + (afun1', h1) <- traverseAfun1 lvl repr1 afun1 + (afun2', h2) <- traverseAfun1 lvl repr2 afun2 (acc', h3) <- traverseAcc lvl acc - return (Pipe repr1 repr2 afun1' afun2' acc' + return (Pipe repr1 repr2 repr3 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 + Aforeign ff afun acc -> travA (Aforeign ff afun) acc + Acond e acc1 acc2 -> 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 repr pred iter init -> reconstruct $ do - (pred', h1) <- traverseAfun1 lvl pred - (iter', h2) <- traverseAfun1 lvl iter + Awhile repr pred iter init -> do + (pred', h1) <- traverseAfun1 lvl repr pred + (iter', h2) <- traverseAfun1 lvl repr iter (init', h3) <- traverseAcc lvl init return (Awhile repr pred' iter' init' , h1 `max` h2 `max` h3 + 1) - Anil -> reconstruct $ return (Anil, 0) - Apair acc1 acc2 -> reconstruct $ do + Anil -> return (Anil, 0) + Apair acc1 acc2 -> do (a', h1) <- traverseAcc lvl acc1 (b', h2) <- traverseAcc lvl acc2 return (Apair a' b', h1 `max` h2 + 1) - Aprj ix a -> reconstruct $ travA (Aprj ix) a + Aprj ix a -> travA (Aprj ix) a - Use arr -> reconstruct $ return (Use arr, 1) - Unit e -> reconstruct $ do + Use repr arr -> return (Use repr arr, 1) + Unit tp e -> do (e', h) <- traverseExp lvl e - return (Unit e', h + 1) - Generate e f -> reconstruct $ do + return (Unit tp e', h + 1) + Generate repr@(ArrayR shr _) e f + -> 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 + (f', h2) <- traverseFun1 lvl (shapeType shr) f + return (Generate repr e' f', h1 `max` h2 + 1) + Reshape shr e acc -> travEA (Reshape shr) e acc + Replicate si e acc -> travEA (Replicate si) e acc + Slice si acc e -> travEA (flip $ Slice si) e acc + Map t1 t2 f acc -> do + (f' , h1) <- traverseFun1 lvl t1 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 + return (Map t1 t2 f' acc', h1 `max` h2 + 1) + ZipWith t1 t2 t3 f acc1 acc2 + -> travF2A2 (ZipWith t1 t2 t3) t1 t2 f acc1 acc2 + Fold tp f e acc -> travF2EA (Fold tp) tp tp f e acc + Fold1 tp f acc -> travF2A (Fold1 tp) tp tp f acc + FoldSeg i tp f e acc1 acc2 -> do + (f' , h1) <- traverseFun2 lvl tp tp f (e' , h2) <- traverseExp lvl e (acc1', h3) <- traverseAcc lvl acc1 (acc2', h4) <- traverseAcc lvl acc2 - return (FoldSeg f' e' acc1' acc2', + return (FoldSeg i tp 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 + Fold1Seg i tp f acc1 acc2 -> travF2A2 (Fold1Seg i tp) tp tp f acc1 acc2 + Scanl tp f e acc -> travF2EA (Scanl tp) tp tp f e acc + Scanl' tp f e acc -> travF2EA (Scanl' tp) tp tp f e acc + Scanl1 tp f acc -> travF2A (Scanl1 tp) tp tp f acc + Scanr tp f e acc -> travF2EA (Scanr tp) tp tp f e acc + Scanr' tp f e acc -> travF2EA (Scanr' tp) tp tp f e acc + Scanr1 tp f acc -> travF2A (Scanr1 tp) tp tp f acc + Permute repr@(ArrayR shr tp) c acc1 p acc2 + -> do + (c' , h1) <- traverseFun2 lvl tp tp c + (p' , h2) <- traverseFun1 lvl (shapeType shr) p (acc1', h3) <- traverseAcc lvl acc1 (acc2', h4) <- traverseAcc lvl acc2 - return (Permute c' acc1' p' acc2', + return (Permute repr c' acc1' p' acc2', h1 `max` h2 `max` h3 `max` h4 + 1) - Backpermute e p acc -> reconstruct $ do + Backpermute shr e p acc -> do (e' , h1) <- traverseExp lvl e - (p' , h2) <- traverseFun1 lvl p + (p' , h2) <- traverseFun1 lvl (shapeType shr) 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 + return (Backpermute shr e' p' acc', h1 `max` h2 `max` h3 + 1) + Stencil s tp f bnd acc -> do + (f' , h1) <- makeOccMapStencil1 config accOccMap s lvl f + (bnd', h2) <- traverseBoundary lvl (stencilShape s) 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 + return (Stencil s tp f' bnd' acc', h1 `max` h2 `max` h3 + 1) + Stencil2 s1 s2 tp f bnd1 acc1 + bnd2 acc2 -> do + let shr = stencilShape s1 + (f' , h1) <- makeOccMapStencil2 config accOccMap s1 s2 lvl f + (bnd1', h2) <- traverseBoundary lvl shr bnd1 (acc1', h3) <- traverseAcc lvl acc1 - (bnd2', h4) <- traverseBoundary lvl bnd2 + (bnd2', h4) <- traverseBoundary lvl shr bnd2 (acc2', h5) <- traverseAcc lvl acc2 - return (Stencil2 s' bnd1' acc1' bnd2' acc2', + return (Stencil2 s1 s2 tp f' bnd1' acc1' bnd2' acc2', h1 `max` h2 `max` h3 `max` h4 `max` h5 + 1) - -- Collect s -> reconstruct $ do + -- Collect s -> do -- (s', h) <- traverseSeq lvl s -- return (Collect s', h + 1) where - travA :: Typeable arrs' - => (UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + travA :: (UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) -> SmartAcc arrs' -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travA c acc = do (acc', h) <- traverseAcc lvl acc return (c acc', h + 1) - travEA :: (Typeable arrs', Typeable b) - => (RootExp b -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) - -> Exp b -> SmartAcc arrs' -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) + travEA :: (RootExp b -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> SmartExp b -> SmartAcc arrs' -> IO (PreSmartAcc 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' + travF2A :: ((SmartExp b -> SmartExp c -> RootExp d) -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) - -> (Exp b -> Exp c -> Exp d) -> SmartAcc arrs' + -> TupleType b -> TupleType c + -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartAcc arrs' -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) - travF2A c fun acc + travF2A c t1 t2 fun acc = do - (fun', h1) <- traverseFun2 lvl fun + (fun', h1) <- traverseFun2 lvl t1 t2 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' -> PreSmartAcc UnscopedAcc RootExp arrs) - -> (Exp b -> Exp c -> Exp d) -> Exp e -> SmartAcc arrs' + travF2EA :: ((SmartExp b -> SmartExp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> TupleType b -> TupleType c + -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartExp e -> SmartAcc arrs' -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) - travF2EA c fun exp acc + travF2EA c t1 t2 fun exp acc = do - (fun', h1) <- traverseFun2 lvl fun + (fun', h1) <- traverseFun2 lvl t1 t2 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 -> PreSmartAcc UnscopedAcc RootExp arrs) - -> (Exp b -> Exp c -> Exp d) -> SmartAcc arrs1 -> SmartAcc arrs2 + travF2A2 :: ((SmartExp b -> SmartExp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreSmartAcc UnscopedAcc RootExp arrs) + -> TupleType b -> TupleType c + -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartAcc arrs1 -> SmartAcc arrs2 -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) - travF2A2 c fun acc1 acc2 + travF2A2 c t1 t2 fun acc1 acc2 = do - (fun' , h1) <- traverseFun2 lvl fun + (fun' , h1) <- traverseFun2 lvl t1 t2 fun (acc1', h2) <- traverseAcc lvl acc1 (acc2', h3) <- traverseAcc lvl acc2 return (c fun' acc1' acc2', h1 `max` h2 `max` h3 + 1) -makeOccMapAfun1 :: (Typeable a, Typeable b) - => Config +makeOccMapAfun1 :: Config -> OccMapHash SmartAcc -> Level + -> ArraysR a -> (SmartAcc a -> SmartAcc b) -> IO (SmartAcc a -> UnscopedAcc b, Int) -makeOccMapAfun1 config accOccMap lvl f = do - let x = SmartAcc (Atag lvl) +makeOccMapAfun1 config accOccMap lvl repr f = do + let x = SmartAcc (Atag repr lvl) -- (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+1) (f x) return (const (UnscopedAcc [lvl] body), height) @@ -1573,72 +1505,69 @@ makeOccMapAfun3 config accOccMap lvl f = do -- See Note [Traversing functions and side effects] -- makeOccMapExp - :: Typeable e - => Config + :: Config -> OccMapHash SmartAcc -> Level - -> Exp e + -> SmartExp e -> IO (RootExp e, Int) makeOccMapExp config accOccMap lvl = makeOccMapRootExp config accOccMap lvl [] makeOccMapFun1 - :: (Elt a, Typeable b) - => Config + :: Config -> OccMapHash SmartAcc -> Level - -> (Exp a -> Exp b) - -> IO (Exp a -> RootExp b, Int) -makeOccMapFun1 config accOccMap lvl f = do - let x = Exp (Tag lvl) + -> TupleType a + -> (SmartExp a -> SmartExp b) + -> IO (SmartExp a -> RootExp b, Int) +makeOccMapFun1 config accOccMap lvl tp f = do + let x = SmartExp (Tag tp lvl) -- (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (f x) return (const body, height) makeOccMapFun2 - :: (Elt a, Elt b, Typeable c) - => Config + :: Config -> OccMapHash SmartAcc -> 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) + -> TupleType a + -> TupleType b + -> (SmartExp a -> SmartExp b -> SmartExp c) + -> IO (SmartExp a -> SmartExp b -> RootExp c, Int) +makeOccMapFun2 config accOccMap lvl t1 t2 f = do + let x = SmartExp (Tag t1 (lvl+1)) + y = SmartExp (Tag t2 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 + :: forall sh a b stencil. + Config -> OccMapHash SmartAcc - -> SmartAcc (Array sh a) {- dummy -} + -> StencilR sh a stencil -> Level - -> (stencil -> Exp b) - -> IO (stencil -> RootExp b, Int) -makeOccMapStencil1 config accOccMap _ lvl stencil = do - let x = Exp (Tag lvl) - f = stencil . stencilPrj @sh @a + -> (SmartExp stencil -> SmartExp b) + -> IO (SmartExp stencil -> RootExp b, Int) +makeOccMapStencil1 config accOccMap s lvl stencil = do + let x = SmartExp (Tag (stencilType s) lvl) -- - (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (f x) + (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (stencil x) return (const body, height) makeOccMapStencil2 - :: forall sh a b c stencil1 stencil2. (Stencil sh a stencil1, Stencil sh b stencil2, Typeable c) - => Config + :: forall sh a b c stencil1 stencil2. + Config -> OccMapHash SmartAcc - -> SmartAcc (Array sh a) {- dummy -} - -> SmartAcc (Array sh b) {- dummy -} + -> StencilR sh a stencil1 + -> StencilR sh b stencil2 -> 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 @sh @a a) - (stencilPrj @sh @b b) + -> (SmartExp stencil1 -> SmartExp stencil2 -> SmartExp c) + -> IO (SmartExp stencil1 -> SmartExp stencil2 -> RootExp c, Int) +makeOccMapStencil2 config accOccMap s1 s2 lvl stencil = do + let x = SmartExp (Tag (stencilType s1) (lvl+1)) + y = SmartExp (Tag (stencilType s2) lvl) -- - (body, height) <- makeOccMapRootExp config accOccMap (lvl+2) [lvl, lvl+1] (f x y) + (body, height) <- makeOccMapRootExp config accOccMap (lvl+2) [lvl, lvl+1] (stencil x y) return (\_ _ -> body, height) @@ -1649,12 +1578,11 @@ makeOccMapStencil2 config accOccMap _ _ lvl stencil = do -- 2) a local occurrence map for that expression. -- makeOccMapRootExp - :: Typeable e - => Config + :: Config -> OccMapHash SmartAcc -> Level -- The level of currently bound scalar variables -> [Int] -- The tags of newly introduced free scalar variables in this expression - -> Exp e + -> SmartExp e -> IO (RootExp e, Int) makeOccMapRootExp config accOccMap lvl fvs exp = do traceLine "makeOccMapRootExp" "Enter" @@ -1668,17 +1596,16 @@ makeOccMapRootExp config accOccMap lvl fvs exp = do -- Generate sharing information for an open scalar expression. -- makeOccMapSharingExp - :: Typeable e - => Config + :: Config -> OccMapHash SmartAcc - -> OccMapHash Exp + -> OccMapHash SmartExp -> Level -- The level of currently bound variables - -> Exp e + -> SmartExp 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) + travE :: forall a. Level -> SmartExp a -> IO (UnscopedExp a, Int) + travE lvl exp@(SmartExp pexp) = mfix $ \ ~(_, height) -> do -- Compute stable name and enter it into the occurrence map -- @@ -1696,89 +1623,75 @@ makeOccMapSharingExp config accOccMap expOccMap = travE -- 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) + let reconstruct :: IO (PreSmartExp UnscopedAcc UnscopedExp a, Int) -> IO (UnscopedExp a, Int) reconstruct newExp = case heightIfRepeatedOccurrence of Just height | exp_sharing `member` options config - -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height)), height) + -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height) (expType pexp)), 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 + reconstruct $ case pexp of + Tag tp i -> return (Tag tp i, 0) -- height is 0! + Const tp c -> return (Const tp c, 1) + Undef tp -> return (Undef tp, 1) + Nil -> return (Nil, 1) + Pair e1 e2 -> travE2 Pair e1 e2 + Prj i e -> travE1 (Prj i) e + ToIndex shr sh ix -> travE2 (ToIndex shr) sh ix + FromIndex shr sh e -> travE2 (FromIndex shr) sh e + Cond e1 e2 e3 -> travE3 Cond e1 e2 e3 + While t p iter init -> do + (p' , h1) <- traverseFun1 lvl t p + (iter', h2) <- traverseFun1 lvl t 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 + return (While t p' iter' init', h1 `max` h2 `max` h3 + 1) + PrimConst c -> return (PrimConst c, 1) + PrimApp p e -> travE1 (PrimApp p) e + Index tp a e -> travAE (Index tp) a e + LinearIndex tp a i -> travAE (LinearIndex tp) a i + Shape shr a -> travA (Shape shr) a + ShapeSize shr e -> travE1 (ShapeSize shr) e + Foreign ff f e -> do (e', h) <- travE lvl e return (Foreign ff f e', h+1) - Coerce e -> reconstruct $ travE1 Coerce e + Coerce t1 t2 e -> travE1 (Coerce t1 t2) e where - traverseAcc :: Typeable arrs => Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) + traverseAcc :: Level -> SmartAcc 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 + traverseFun1 :: Level + -> TupleType a + -> (SmartExp a -> SmartExp b) + -> IO (SmartExp a -> UnscopedExp b, Int) + traverseFun1 lvl tp f = do - let x = Exp (Tag lvl) + let x = SmartExp (Tag tp 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 :: (UnscopedExp b -> PreSmartExp UnscopedAcc UnscopedExp a) -> SmartExp b + -> IO (PreSmartExp 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 :: (UnscopedExp b -> UnscopedExp c -> PreSmartExp UnscopedAcc UnscopedExp a) + -> SmartExp b -> SmartExp c + -> IO (PreSmartExp 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 :: (UnscopedExp b -> UnscopedExp c -> UnscopedExp d -> PreSmartExp UnscopedAcc UnscopedExp a) + -> SmartExp b -> SmartExp c -> SmartExp d + -> IO (PreSmartExp UnscopedAcc UnscopedExp a, Int) travE3 c e1 e2 e3 = do (e1', h1) <- travE lvl e1 @@ -1786,31 +1699,22 @@ makeOccMapSharingExp config accOccMap expOccMap = travE (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) -> SmartAcc b - -> IO (PreExp UnscopedAcc UnscopedExp a, Int) + travA :: (UnscopedAcc b -> PreSmartExp UnscopedAcc UnscopedExp a) -> SmartAcc b + -> IO (PreSmartExp 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) - -> SmartAcc b -> Exp c - -> IO (PreExp UnscopedAcc UnscopedExp a, Int) + travAE :: (UnscopedAcc b -> UnscopedExp c -> PreSmartExp UnscopedAcc UnscopedExp a) + -> SmartAcc b -> SmartExp c + -> IO (PreSmartExp 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 @@ -1971,11 +1875,10 @@ makeOccMapSharingSeq config accOccMap seqOccMap = traverseSeq type NodeCounts = ([NodeCount], Map.HashMap NodeName (Set.HashSet NodeName)) data NodeName where - NodeName :: Typeable a => StableName a -> NodeName + NodeName :: StableName a -> NodeName instance Eq NodeName where - (NodeName sn1) == (NodeName sn2) | Just sn2' <- gcast sn2 = sn1 == sn2' - | otherwise = False + (NodeName sn1) == (NodeName sn2) = eqStableName sn1 sn2 instance Hashable NodeName where hashWithSalt hash (NodeName sn1) = hash + hashStableName sn1 @@ -2082,11 +1985,11 @@ nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeNam -- insert x@(SeqNodeCount _ _) (y@(AccNodeCount _ _) : ys') -- = x : insert y ys' - (StableSharingAcc _ (AvarSharing _)) `pickNoneAvar` sa2 = sa2 - sa1 `pickNoneAvar` _sa2 = sa1 + (StableSharingAcc _ (AvarSharing _ _)) `pickNoneAvar` sa2 = sa2 + sa1 `pickNoneAvar` _sa2 = sa1 - (StableSharingExp _ (VarSharing _)) `pickNoneVar` sa2 = sa2 - sa1 `pickNoneVar` _sa2 = sa1 + (StableSharingExp _ (VarSharing _ _)) `pickNoneVar` sa2 = sa2 + sa1 `pickNoneVar` _sa2 = sa1 -- pickNoneSvar :: StableSharingSeq -> StableSharingSeq -> StableSharingSeq -- (StableSharingSeq _ (SvarSharing _)) `pickNoneSvar` sa2 = sa2 @@ -2110,7 +2013,7 @@ buildInitialEnvAcc tags sas = map (lookupSA sas) tags sas2 -> $internalError "buildInitialEnvAcc" $ "Encountered duplicate 'ATag's\n " ++ intercalate ", " (map showSA sas2) where - hasTag (StableSharingAcc _ (AccSharing _ (Atag tag2))) = tag1 == tag2 + hasTag (StableSharingAcc _ (AccSharing _ (Atag _ tag2))) = tag1 == tag2 hasTag sa = $internalError "buildInitialEnvAcc" $ "Encountered a node that is not a plain 'Atag'\n " ++ showSA sa @@ -2120,8 +2023,8 @@ buildInitialEnvAcc tags sas = map (lookupSA sas) tags 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 ++ "..." + 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 @@ -2141,7 +2044,7 @@ buildInitialEnvExp tags ses = map (lookupSE ses) tags ses2 -> $internalError "buildInitialEnvExp" ("Encountered a duplicate 'Tag'\n " ++ intercalate ", " (map showSE ses2)) where - hasTag (StableSharingExp _ (ExpSharing _ (Tag tag2))) = tag1 == tag2 + hasTag (StableSharingExp _ (ExpSharing _ (Tag _ tag2))) = tag1 == tag2 hasTag se = $internalError "buildInitialEnvExp" ("Encountered a node that is not a plain 'Tag'\n " ++ showSE se) @@ -2151,15 +2054,15 @@ buildInitialEnvExp tags ses = map (lookupSE ses) tags showSE (StableSharingExp _ (ExpSharing sn exp)) = show (hashStableNameHeight sn) ++ ": " ++ showPreExpOp exp - showSE (StableSharingExp _ (VarSharing sn)) = "VarSharing " ++ show (hashStableNameHeight sn) + 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 +isFreeVar (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag _ _))) _) = True +isFreeVar (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag _ _))) _) = True +isFreeVar _ = False -- Determine scope of shared subterms @@ -2177,8 +2080,7 @@ isFreeVar _ = False -- Precondition: there are only 'AvarSharing' and 'AccSharing' nodes in the argument. -- determineScopesAcc - :: Typeable a - => Config + :: Config -> [Level] -> OccMap SmartAcc -> UnscopedAcc a @@ -2203,19 +2105,19 @@ determineScopesSharingAcc config accOccMap = scopesAcc scopesAcc (UnscopedAcc _ (AletSharing _ _)) = $internalError "determineScopesSharingAcc: scopesAcc" "unexpected 'AletSharing'" - scopesAcc (UnscopedAcc _ (AvarSharing sn)) - = (ScopedAcc [] (AvarSharing sn), StableSharingAcc sn (AvarSharing sn) `insertAccNode` noNodeCounts) + scopesAcc (UnscopedAcc _ (AvarSharing sn tp)) + = (ScopedAcc [] (AvarSharing sn tp), StableSharingAcc sn (AvarSharing sn tp) `insertAccNode` noNodeCounts) scopesAcc (UnscopedAcc _ (AccSharing sn pacc)) = case pacc of - Atag i -> reconstruct (Atag i) noNodeCounts - Pipe repr1 repr2 afun1 afun2 acc + Atag tp i -> reconstruct (Atag tp i) noNodeCounts + Pipe repr1 repr2 repr3 afun1 afun2 acc -> let (afun1', accCount1) = scopesAfun1 afun1 (afun2', accCount2) = scopesAfun1 afun2 (acc', accCount3) = scopesAcc acc in - reconstruct (Pipe repr1 repr2 afun1' afun2' acc') + reconstruct (Pipe repr1 repr2 repr3 afun1' afun2' acc') (accCount1 +++ accCount2 +++ accCount3) Aforeign ff afun acc -> let @@ -2247,64 +2149,67 @@ determineScopesSharingAcc config accOccMap = scopesAcc reconstruct (Apair a1' a2') (accCount1 +++ accCount2) Aprj ix a -> travA (Aprj ix) a - Use arr -> reconstruct (Use arr) noNodeCounts - Unit e -> let + Use repr arr -> reconstruct (Use repr arr) noNodeCounts + Unit tp e -> let (e', accCount) = scopesExp e in - reconstruct (Unit e') accCount - Generate sh f -> let + reconstruct (Unit tp e') accCount + Generate repr 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 + reconstruct (Generate repr sh' f') (accCount1 +++ accCount2) + Reshape shr sh acc -> travEA (Reshape shr) sh acc + Replicate si n acc -> travEA (Replicate si) n acc + Slice si acc i -> travEA (flip $ Slice si) i acc + Map t1 t2 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 + reconstruct (Map t1 t2 f' acc') (accCount1 +++ accCount2) + ZipWith t1 t2 t3 f acc1 acc2 + -> travF2A2 (ZipWith t1 t2 t3) f acc1 acc2 + Fold tp f z acc -> travF2EA (Fold tp) f z acc + Fold1 tp f acc -> travF2A (Fold1 tp) f acc + FoldSeg i tp 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') + reconstruct (FoldSeg i tp 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 + Fold1Seg i tp f acc1 acc2 -> travF2A2 (Fold1Seg i tp) f acc1 acc2 + Scanl tp f z acc -> travF2EA (Scanl tp) f z acc + Scanl' tp f z acc -> travF2EA (Scanl' tp) f z acc + Scanl1 tp f acc -> travF2A (Scanl1 tp) f acc + Scanr tp f z acc -> travF2EA (Scanr tp) f z acc + Scanr' tp f z acc -> travF2EA (Scanr' tp) f z acc + Scanr1 tp f acc -> travF2A (Scanr1 tp) f acc + Permute repr 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') + reconstruct (Permute repr fc' acc1' fp' acc2') (accCount1 +++ accCount2 +++ accCount3 +++ accCount4) - Backpermute sh fp acc -> let + Backpermute shr sh fp acc + -> let (sh' , accCount1) = scopesExp sh (fp' , accCount2) = scopesFun1 fp (acc', accCount3) = scopesAcc acc in - reconstruct (Backpermute sh' fp' acc') + reconstruct (Backpermute shr sh' fp' acc') (accCount1 +++ accCount2 +++ accCount3) - Stencil st bnd acc -> let + Stencil sr tp 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 + reconstruct (Stencil sr tp st' bnd' acc') (accCount1 +++ accCount2 +++ accCount3) + Stencil2 s1 s2 tp st bnd1 acc1 bnd2 acc2 -> let (st' , accCount1) = scopesStencil2 acc1 acc2 st (bnd1', accCount2) = scopesBoundary bnd1 @@ -2312,7 +2217,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc (bnd2', accCount4) = scopesBoundary bnd2 (acc2', accCount5) = scopesAcc acc2 in - reconstruct (Stencil2 st' bnd1' acc1' bnd2' acc2') + reconstruct (Stencil2 s1 s2 tp st' bnd1' acc1' bnd2' acc2') (accCount1 +++ accCount2 +++ accCount3 +++ accCount4 +++ accCount5) -- Collect seq -> let -- (seq', accCount1) = scopesSeq seq @@ -2329,10 +2234,9 @@ determineScopesSharingAcc config accOccMap = scopesAcc (e' , accCount1) = scopesExp e (acc', accCount2) = scopesAcc acc - travF2A :: (Elt a, Elt b) - => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs' + travF2A :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) - -> (Exp a -> Exp b -> RootExp c) + -> (SmartExp a -> SmartExp b -> RootExp c) -> UnscopedAcc arrs' -> (ScopedAcc arrs, NodeCounts) travF2A c f acc = reconstruct (c f' acc') (accCount1 +++ accCount2) @@ -2340,10 +2244,9 @@ determineScopesSharingAcc config accOccMap = scopesAcc (f' , accCount1) = scopesFun2 f (acc', accCount2) = scopesAcc acc - travF2EA :: (Elt a, Elt b) - => ((Exp a -> Exp b -> ScopedExp c) -> ScopedExp e + travF2EA :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedExp e -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) - -> (Exp a -> Exp b -> RootExp c) + -> (SmartExp a -> SmartExp b -> RootExp c) -> RootExp e -> UnscopedAcc arrs' -> (ScopedAcc arrs, NodeCounts) @@ -2353,10 +2256,9 @@ determineScopesSharingAcc config accOccMap = scopesAcc (e' , accCount2) = scopesExp e (acc', accCount3) = scopesAcc acc - travF2A2 :: (Elt a, Elt b) - => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs1 + travF2A2 :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedAcc arrs1 -> ScopedAcc arrs2 -> PreSmartAcc ScopedAcc ScopedExp arrs) - -> (Exp a -> Exp b -> RootExp c) + -> (SmartExp a -> SmartExp b -> RootExp c) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> (ScopedAcc arrs, NodeCounts) @@ -2394,20 +2296,20 @@ determineScopesSharingAcc config accOccMap = scopesAcc reconstruct :: PreSmartAcc ScopedAcc ScopedExp arrs -> NodeCounts -> (ScopedAcc arrs, NodeCounts) - reconstruct newAcc@(Atag _) _subCount + reconstruct newAcc@(Atag tp _) _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) + (ScopedAcc [] (AvarSharing sn tp), thisCount) reconstruct newAcc subCount -- shared subtree => replace by a sharing variable (if 'recoverAccSharing' enabled) | accOccCount > 1 && acc_sharing `member` options config = let allCount = (StableSharingAcc sn sharingAcc `insertAccNode` newCount) in tracePure ("SHARED" ++ completed) (show allCount) - (ScopedAcc [] (AvarSharing sn), allCount) + (ScopedAcc [] (AvarSharing sn $ arraysRepr newAcc), allCount) -- neither shared nor free variable => leave it as it is | otherwise = tracePure ("Normal" ++ completed) (show newCount) @@ -2471,13 +2373,13 @@ determineScopesSharingAcc config accOccMap = scopesAcc (freeCounts, counts') = partition isBoundHere counts ssa = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts] - isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs - isBoundHere _ = False + 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 :: (SmartExp e1 -> RootExp e2) -> (SmartExp e1 -> ScopedExp e2, NodeCounts) scopesFun1 f = (const body, counts) where (body, counts) = scopesExp (f undefined) @@ -2485,9 +2387,8 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- 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 :: (SmartExp e1 -> SmartExp e2 -> RootExp e3) + -> (SmartExp e1 -> SmartExp e2 -> ScopedExp e3, NodeCounts) scopesFun2 f = (\_ _ -> body, counts) where (body, counts) = scopesExp (f undefined undefined) @@ -2495,8 +2396,8 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- 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-} + scopesStencil1 :: forall sh e1 e2 stencil. + UnscopedAcc (Array sh e1){-dummy-} -> (stencil -> RootExp e2) -> (stencil -> ScopedExp e2, NodeCounts) scopesStencil1 _ stencilFun = (const body, counts) @@ -2507,8 +2408,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- 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 e1){-dummy-} -> UnscopedAcc (Array sh e2){-dummy-} -> (stencil1 -> stencil2 -> RootExp e3) -> (stencil1 -> stencil2 -> ScopedExp e3, NodeCounts) @@ -2547,7 +2447,7 @@ determineScopesExp config accOccMap (RootExp expOccMap exp@(UnscopedExp fvs _)) determineScopesSharingExp :: Config -> OccMap SmartAcc - -> OccMap Exp + -> OccMap SmartExp -> UnscopedExp t -> (ScopedExp t, NodeCounts) determineScopesSharingExp config accOccMap expOccMap = scopesExp @@ -2555,7 +2455,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp scopesAcc :: UnscopedAcc a -> (ScopedAcc a, NodeCounts) scopesAcc = determineScopesSharingAcc config accOccMap - scopesFun1 :: (Exp a -> UnscopedExp b) -> (Exp a -> ScopedExp b, NodeCounts) + scopesFun1 :: (SmartExp a -> UnscopedExp b) -> (SmartExp a -> ScopedExp b, NodeCounts) scopesFun1 f = tracePure ("LAMBDA " ++ show ssa) (show counts) (const (ScopedExp ssa body'), (counts',graph)) where body@(UnscopedExp fvs _) = f undefined @@ -2563,65 +2463,49 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp (freeCounts, counts') = partition isBoundHere counts ssa = buildInitialEnvExp fvs [se | ExpNodeCount se _ <- freeCounts] - isBoundHere (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag i))) _) = i `elem` fvs - isBoundHere _ = False + 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 _ (VarSharing sn tp)) + = (ScopedExp [] (VarSharing sn tp), StableSharingExp sn (VarSharing sn tp) `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 + Tag tp i -> reconstruct (Tag tp i) noNodeCounts + Const tp c -> reconstruct (Const tp c) noNodeCounts + Undef tp -> reconstruct (Undef tp) noNodeCounts + Pair e1 e2 -> travE2 Pair e1 e2 + Nil -> reconstruct Nil noNodeCounts 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 + ToIndex shr sh ix -> travE2 (ToIndex shr) sh ix + FromIndex shr sh e -> travE2 (FromIndex shr) sh e Cond e1 e2 e3 -> travE3 Cond e1 e2 e3 - While p it i -> let + While tp 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) + in reconstruct (While tp 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 + Index tp a e -> travAE (Index tp) a e + LinearIndex tp a e -> travAE (LinearIndex tp) a e + Shape shr a -> travA (Shape shr) a + ShapeSize shr e -> travE1 (ShapeSize shr) e Foreign ff f e -> travE1 (Foreign ff f) e - Coerce e -> travE1 Coerce e + Coerce t1 t2 e -> travE1 (Coerce t1 t2) 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 + travE1 :: (ScopedExp a -> PreSmartExp 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) + travE2 :: (ScopedExp a -> ScopedExp b -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedExp a -> UnscopedExp b -> (ScopedExp t, NodeCounts) @@ -2630,7 +2514,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp (e1', accCount1) = scopesExp e1 (e2', accCount2) = scopesExp e2 - travE3 :: (ScopedExp a -> ScopedExp b -> ScopedExp c -> PreExp ScopedAcc ScopedExp t) + travE3 :: (ScopedExp a -> ScopedExp b -> ScopedExp c -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedExp a -> UnscopedExp b -> UnscopedExp c @@ -2641,13 +2525,13 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp (e2', accCount2) = scopesExp e2 (e3', accCount3) = scopesExp e3 - travA :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t) -> UnscopedAcc a + travA :: (ScopedAcc a -> PreSmartExp 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) + travAE :: (ScopedAcc a -> ScopedExp b -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedAcc a -> UnscopedExp b -> (ScopedExp t, NodeCounts) @@ -2656,11 +2540,11 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp (acc', accCountA) = scopesAcc acc (e' , accCountE) = scopesExp e - maybeFloatOutAcc :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t) + maybeFloatOutAcc :: (ScopedAcc a -> PreSmartExp ScopedAcc ScopedExp t) -> ScopedAcc a -> NodeCounts -> (ScopedExp t, NodeCounts) - maybeFloatOutAcc c acc@(ScopedAcc _ (AvarSharing _)) accCount -- nothing to float out + maybeFloatOutAcc c acc@(ScopedAcc _ (AvarSharing _ _)) accCount -- nothing to float out = reconstruct (c acc) accCount maybeFloatOutAcc c acc accCount | float_out_acc `member` options config = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount) @@ -2670,9 +2554,9 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp abstract :: ScopedAcc a -> (ScopedAcc a -> SharingAcc ScopedAcc ScopedExp a) -> (ScopedAcc a, StableSharingAcc) - abstract (ScopedAcc _ (AvarSharing _)) _ = $internalError "sharingAccToVar" "AvarSharing" + abstract (ScopedAcc _ (AvarSharing _ _)) _ = $internalError "sharingAccToVar" "AvarSharing" abstract (ScopedAcc ssa (AletSharing sa acc)) lets = abstract acc (lets . ScopedAcc ssa . AletSharing sa) - abstract acc@(ScopedAcc ssa (AccSharing sn _)) lets = (ScopedAcc ssa (AvarSharing sn), StableSharingAcc sn (lets acc)) + abstract acc@(ScopedAcc ssa (AccSharing sn a)) lets = (ScopedAcc ssa (AvarSharing sn $ arraysRepr a), StableSharingAcc sn (lets acc)) -- Occurrence count of the currently processed node expOccCount = let StableNameHeight sn' _ = sn @@ -2690,22 +2574,22 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp -- In either case, any completed 'NodeCounts' are injected as bindings using 'LetSharing' -- node. -- - reconstruct :: PreExp ScopedAcc ScopedExp t -> NodeCounts + reconstruct :: PreSmartExp ScopedAcc ScopedExp t -> NodeCounts -> (ScopedExp t, NodeCounts) - reconstruct newExp@(Tag _) _subCount + reconstruct newExp@(Tag tp _) _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) + (ScopedExp [] (VarSharing sn tp), thisCount) reconstruct newExp subCount -- shared subtree => replace by a sharing variable (if 'recoverExpSharing' enabled) | expOccCount > 1 && exp_sharing `member` options config = let allCount = StableSharingExp sn sharingExp `insertExpNode` newCount in tracePure ("SHARED" ++ completed) (show allCount) - (ScopedExp [] (VarSharing sn), allCount) + (ScopedExp [] (VarSharing sn $ expType newExp), allCount) -- neither shared nor free variable => leave it as it is | otherwise = tracePure ("Normal" ++ completed) (show newCount) @@ -2918,8 +2802,7 @@ determineScopesSharingSeq config accOccMap _seqOccMap = scopesSeq -- {-# NOINLINE recoverSharingAcc #-} recoverSharingAcc - :: Typeable a - => Config + :: Config -> Level -- The level of currently bound array variables -> [Level] -- The tags of newly introduced free array variables -> SmartAcc a @@ -2934,11 +2817,10 @@ recoverSharingAcc config alvl avars acc {-# NOINLINE recoverSharingExp #-} recoverSharingExp - :: Typeable e - => Config + :: Config -> Level -- The level of currently bound scalar variables -> [Level] -- The tags of newly introduced free scalar variables - -> Exp e + -> SmartExp e -> (ScopedExp e, [StableSharingExp]) recoverSharingExp config lvl fvar exp = let @@ -2958,8 +2840,7 @@ recoverSharingExp config lvl fvar exp {-- {-# NOINLINE recoverSharingSeq #-} recoverSharingSeq - :: Typeable e - => Config + :: Config -> Seq e -> (ScopedSeq e, [StableSharingSeq]) recoverSharingSeq config seq diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 0dfa875b9..c98525aed 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -3,6 +3,8 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Trafo.Shrink @@ -63,6 +65,63 @@ instance Kit acc => Shrink (PreOpenExp acc env aenv e) where instance Kit acc => Shrink (PreOpenFun acc env aenv f) where shrink' = shrinkFun +data VarsRange = VarsRange !Int !Int !RangeTuple -- first, count, tuple + +data RangeTuple + = RTNil + | RTSingle + | RTPair !RangeTuple !RangeTuple + +lhsVarsRange :: LeftHandSide s v env env' -> Maybe VarsRange +lhsVarsRange (LeftHandSideWildcard TupRunit) = Just $ VarsRange 0 0 RTNil +lhsVarsRange (LeftHandSideSingle _) = Just $ VarsRange 0 1 RTSingle +lhsVarsRange (LeftHandSidePair l1 l2) + | Just (VarsRange _ n1 t1) <- lhsVarsRange l1 + , Just (VarsRange _ n2 t2) <- lhsVarsRange l2 = Just $ VarsRange 0 (n1 + n2) $ RTPair t1 t2 +lhsVarsRange _ = Nothing + +lhsSize :: LeftHandSide s v env env' -> Int +lhsSize (LeftHandSideWildcard _) = 0 +lhsSize (LeftHandSideSingle _) = 1 +lhsSize (LeftHandSidePair l1 l2) = lhsSize l1 + lhsSize l2 + +weakenVarsRange :: LeftHandSide s v env env' -> VarsRange -> VarsRange +weakenVarsRange lhs (VarsRange i n t) = VarsRange (i + lhsSize lhs) n t + +matchEVarsRange :: VarsRange -> PreOpenExp acc env aenv t -> Bool +matchEVarsRange (VarsRange _ _ RTNil) Nil = True +matchEVarsRange (VarsRange i' _ RTSingle) (Evar (Var _ ix')) = go i' ix' + where + go :: Int -> Idx env t -> Bool + go 0 ZeroIdx = True + go i (SuccIdx ix) = go (i - 1) ix + go _ _ = False +matchEVarsRange (VarsRange i _ (RTPair t1 t2)) (Pair e1 e2) + = matchEVarsRange (VarsRange i 0 t1) e1 + && matchEVarsRange (VarsRange i 0 t2) e2 +matchEVarsRange _ _ = False + +varInRange :: VarsRange -> Var s env t -> Bool +varInRange (VarsRange i n _) (Var _ ix) = i <= j && j < i + n + where + j = idxToInt ix + +data Count + = Impossible -- Cannot inline this definition. This happens when the definition declares multiple variables (the right hand side returns a tuple) and the variables are used seperately. + | Infinity -- The variable is used in a loop. Inlining should only proceed if the computation is cheap. + | Finite {-# UNPACK #-} !Int + +instance Semigroup Count where + Impossible <> _ = Impossible + _ <> Impossible = Impossible + Infinity <> _ = Infinity + _ <> Infinity = Infinity + Finite a <> Finite b = Finite $ a + b + +loopCount :: Count -> Count +loopCount (Finite n) | n > 0 = Infinity +loopCount c = c + -- Shrinking -- ========= @@ -80,35 +139,49 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE lIMIT :: Int lIMIT = 1 + cheap :: PreOpenExp acc env aenv t -> Bool + cheap (Evar _) = True + cheap (Pair e1 e2) = cheap e1 && cheap e2 + cheap Nil = True + cheap Const{} = True + cheap PrimConst{} = True + cheap Undef{} = True + cheap (Coerce _ _ e) = cheap e + cheap _ = False + 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' + Let (LeftHandSideSingle _) bnd@Evar{} body -> Stats.inline "Var" . yes $ shrinkE (inline body bnd) + Let lhs bnd body + | shouldInline -> case inlineVars lhs (snd body') (snd bnd') of + Just inlined -> Stats.betaReduce msg . yes $ shrinkE inlined + _ -> error "shrinkExp: Unexpected failure while trying to inline some expression." + | otherwise -> Let lhs <$> bnd' <*> body' where + shouldInline = case uses of + Finite n -> n <= lIMIT || cheap (snd bnd') + Infinity -> cheap (snd bnd') + Impossible -> False + bnd' = shrinkE bnd body' = shrinkE body - uses = usesOfExp ZeroIdx (snd body') + uses = case lhsVarsRange lhs of + Nothing -> Impossible + Just range -> usesOfExp range (snd body') - msg = case uses of - 0 -> "dead exp" - _ -> "inline exp" -- forced inlining when lIMIT > 1 + msg = case uses of + Finite 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 + Evar v -> pure (Evar v) + Const t c -> pure (Const t c) + Undef t -> pure (Undef t) + Nil -> pure Nil + Pair x y -> Pair <$> shrinkE x <*> shrinkE y 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 + ToIndex shr sh ix -> ToIndex shr <$> shrinkE sh <*> shrinkE ix + FromIndex shr sh i -> FromIndex shr <$> 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) @@ -116,15 +189,9 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE 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 + ShapeSize shr sh -> ShapeSize shr <$> shrinkE sh 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 + Coerce t1 t2 e -> Coerce t1 t2 <$> shrinkE e shrinkF :: Kit acc => PreOpenFun acc env aenv t -> (Any, PreOpenFun acc env aenv t) shrinkF = first Any . shrinkFun @@ -136,9 +203,8 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE 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 - +shrinkFun (Lam l f) = Lam l <$> 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 @@ -274,49 +340,39 @@ shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrinkA" shrinkA -- 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 +usesOfExp :: forall acc env aenv t. VarsRange -> PreOpenExp acc env aenv t -> Count +usesOfExp range = countE where - countE :: PreOpenExp acc env aenv e -> Int + countE :: PreOpenExp acc env aenv e -> Count + countE exp | matchEVarsRange range exp = Finite 1 countE exp = case exp of - Var this - | Just Refl <- match this idx -> 1 - | otherwise -> 0 + Evar v + | varInRange range v -> Impossible + | otherwise -> Finite 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 + Let lhs bnd body -> countE bnd <> usesOfExp (weakenVarsRange lhs range) body + Const _ _ -> Finite 0 + Undef _ -> Finite 0 + Nil -> Finite 0 + Pair e1 e2 -> countE e1 <> countE e2 + IndexSlice _ ix sh -> countE ix <> countE sh + IndexFull _ ix sl -> countE ix <> countE sl + FromIndex _ sh i -> countE sh <> countE i + ToIndex _ sh e -> countE sh <> countE e + Cond p t e -> countE p <> countE t <> countE e + While p f x -> countE x <> loopCount (countF range p) <> countF range f + PrimConst _ -> Finite 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 + Shape _ -> Finite 0 + ShapeSize _ sh -> countE sh 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 + Coerce _ _ e -> countE e - countT :: Tuple (PreOpenExp acc env aenv) e -> Int - countT NilTup = 0 - countT (SnocTup t e) = countT t + countE e + countF :: VarsRange -> PreOpenFun acc env' aenv f -> Count + countF range' (Lam lhs f) = countF (weakenVarsRange lhs range') f + countF range' (Body b) = usesOfExp range' b -- 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 @@ -340,71 +396,64 @@ usesOfPreAcc withShape countAcc idx = count count :: PreOpenAcc acc aenv a -> Int count pacc = case pacc of - Avar (ArrayVar this) -> countIdx this + Avar (Var _ this) -> countIdx this -- - Alet lhs bnd body -> countA bnd + countAcc withShape (weakenWithLHS lhs idx) body - Apair a1 a2 -> countA a1 + countA a2 - Anil -> 0 - 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 + Alet lhs bnd body -> countA bnd + countAcc withShape (weakenWithLHS lhs >:> idx) body + Apair a1 a2 -> countA a1 + countA a2 + Anil -> 0 + 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 + Let _ bnd body -> countE bnd + countE body + Evar _ -> 0 + Const _ _ -> 0 + Undef _ -> 0 + Nil -> 0 + Pair x y -> countE x + countE y + IndexSlice _ ix sh -> countE ix + countE sh + IndexFull _ ix sl -> countE ix + countE sl + 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 Shape a - | withShape -> countA a - | otherwise -> 0 - Foreign _ _ e -> countE e - Coerce e -> countE e + | withShape -> countA a + | otherwise -> 0 + Foreign _ _ e -> countE e + Coerce _ _ e -> countE e countA :: acc aenv a -> Int countA = countAcc withShape idx @@ -416,12 +465,8 @@ usesOfPreAcc withShape countAcc idx = count -- 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 + countF (Lam _ f) = countF f + countF (Body b) = countE b {-- countS :: PreOpenSeq acc aenv senv arrs -> Int diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index dee10f711..5c808f27a 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -31,7 +31,6 @@ module Data.Array.Accelerate.Trafo.Simplify ( -- 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 @@ -40,16 +39,12 @@ 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, Shape, Elt(..), Z(..), (:.)(..) - , Tuple(..), IsTuple, fromTuple, TupleRepr, shapeToList ) +import Data.Array.Accelerate.Array.Representation ( Array, shapeToList ) import qualified Data.Array.Accelerate.Debug.Stats as Stats import qualified Data.Array.Accelerate.Debug.Flags as Debug import qualified Data.Array.Accelerate.Debug.Trace as Debug @@ -61,7 +56,7 @@ class Simplify f where instance Kit acc => Simplify (PreFun acc aenv f) where simplify = simplifyFun -instance (Kit acc, Elt e) => Simplify (PreExp acc aenv e) where +instance Kit acc => Simplify (PreExp acc aenv e) where simplify = simplifyExp @@ -204,38 +199,42 @@ recoverLoops _ bnd e3 -- introduced by the fusion transformation. This would benefit from a -- rewrite rule schema. -- +-- TODO: We currently pass around an environment Gamma, but we do not use it. +-- It might be helpful to do some inlining if this enables other optimizations. +-- Eg, for `let x = -y in -x`, the inlining would allow us to shorten it to `y`. +-- If we do not want to do inlining, we should remove the environment here. simplifyOpenExp - :: forall acc env aenv e. (Kit acc, Elt e) + :: forall acc env aenv e. (Kit acc) => 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 :: PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t) cvtE exp = case exp of - Let bnd body + Let lhs@(LeftHandSideSingle _) 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' + | otherwise -> Let lhs <$> 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) + Let lhs bnd body -> Let lhs <$> bnd' <*> body' + where + bnd' = cvtE bnd + env' = lhsExpr lhs env + body' = cvtE' env' body + + Evar var -> pure $ Evar var + Const tp c -> pure $ Const tp c + Undef tp -> pure $ Undef tp + Nil -> pure Nil + Pair e1 e2 -> Pair <$> cvtE e1 <*> cvtE e2 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) + ToIndex shr sh ix -> toIndex shr (cvtE sh) (cvtE ix) + FromIndex shr sh ix -> fromIndex shr (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) @@ -245,180 +244,54 @@ simplifyOpenExp env = first getAny . cvtE 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 + ShapeSize shr sh -> shapeSize shr (cvtE sh) 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 + Coerce t1 t2 e -> Coerce t1 t2 <$> 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' :: 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) + cond :: forall 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') + | 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 :: (Elt 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. (Elt 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. (Elt 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 @sh) (eltType @Z) - = Stats.ruleFired "shape/Z" $ yes (Const (fromElt Z)) + shape :: forall sh t. acc aenv (Array sh t) -> (Any, PreOpenExp acc env aenv sh) + shape a + | ArrayR ShapeRz _ <- arrayRepr a + = Stats.ruleFired "shape/Z" $ yes Nil shape a - = pure $ 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 + shapeSize :: forall sh. ShapeR sh -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) + shapeSize shr (_, extractConstTuple -> Just c) = Stats.ruleFired "shapeSize/const" $ yes (Const scalarTypeInt (product (shapeToList shr c))) + shapeSize shr sh = ShapeSize shr <$> 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) + toIndex :: forall sh. ShapeR 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 + toIndex shr sh ix = ToIndex shr <$> 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) + fromIndex :: forall sh. ShapeR 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 + fromIndex shr sh ix = FromIndex shr <$> sh <*> ix first :: (a -> a') -> (a,b) -> (a',b) first f (x,y) = (f x, y) @@ -426,6 +299,11 @@ simplifyOpenExp env = first getAny . cvtE yes :: x -> (Any, x) yes x = (Any True, x) +extractConstTuple :: PreOpenExp acc env aenv t -> Maybe t +extractConstTuple Nil = Just () +extractConstTuple (Pair e1 e2) = (,) <$> extractConstTuple e1 <*> extractConstTuple e2 +extractConstTuple (Const _ c) = Just c +extractConstTuple _ = Nothing -- Simplification for open functions -- @@ -434,16 +312,20 @@ simplifyOpenFun => 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 +simplifyOpenFun env (Body e) = Body <$> simplifyOpenExp env e +simplifyOpenFun env (Lam lhs f) = Lam lhs <$> simplifyOpenFun env' f where - env' = incExp env `pushExp` Var ZeroIdx + env' = lhsExpr lhs env +lhsExpr :: Kit acc => ELeftHandSide t env env' -> Gamma acc env env aenv -> Gamma acc env' env' aenv +lhsExpr (LeftHandSideWildcard _) env = env +lhsExpr (LeftHandSideSingle tp) env = incExp env `pushExp` Evar (Var tp ZeroIdx) +lhsExpr (LeftHandSidePair l1 l2) env = lhsExpr l2 $ lhsExpr l1 env -- 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 :: 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 @@ -547,8 +429,8 @@ ops = lens _ops (\Stats{..} v -> Stats { _ops = v, ..}) {-# 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 +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 @@ -564,14 +446,6 @@ summariseOpenExp = (terms +~ 1) . goE 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 @@ -613,33 +487,26 @@ summariseOpenExp = (terms +~ 1) . goE 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 + Let _ bnd body -> travE bnd +++ travE body & binders +~ 1 + Evar{} -> 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 + Undef _ -> zero + Nil -> zero & terms +~ 1 + Pair e1 e2 -> travE e1 +++ travE e2 & terms +~ 1 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 + 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 + ShapeSize _ sh -> travE sh PrimApp f x -> travPrimFun f +++ travE x - Coerce e -> travE e + Coerce _ _ e -> travE e travPrimFun :: PrimFun f -> Stats travPrimFun = (ops +~ 1) . goF diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 336859925..b9d1d2f7b 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Substitution @@ -23,7 +24,7 @@ module Data.Array.Accelerate.Trafo.Substitution ( -- ** Renaming & Substitution - inline, substitute, compose, + inline, inlineVars, compose, subTop, subAtop, -- ** Weakening @@ -34,16 +35,22 @@ module Data.Array.Accelerate.Trafo.Substitution ( -- ** Rebuilding terms RebuildAcc, Rebuildable(..), RebuildableAcc, - RebuildableExp(..), RebuildTup(..), rebuildWeakenVar + RebuildableExp(..), rebuildWeakenVar, + + -- ** Checks + isIdentity, isIdentityIndexing ) where import Data.Kind import Control.Applicative hiding ( Const ) +import Control.Monad import Prelude hiding ( exp, seq ) import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Array.Sugar ( Elt, Tuple(..), Array ) +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Array.Representation +import Data.Array.Accelerate.Analysis.Match import qualified Data.Array.Accelerate.Debug.Stats as Stats @@ -72,7 +79,36 @@ import qualified Data.Array.Accelerate.Debug.Stats as Stats -- a class of operations on variables that is closed under shifting. -- infixr `compose` -infixr `substitute` +-- infixr `substitute` + +lhsFullVars :: forall s a env1 env2. LeftHandSide s a env1 env2 -> Maybe (Vars s env2 a) +lhsFullVars = fmap snd . go weakenId + where + go :: forall env env' b. (env' :> env2) -> LeftHandSide s b env env' -> Maybe (env :> env2, Vars s env2 b) + go k (LeftHandSideWildcard TupRunit) = Just (k, VarsNil) + go k (LeftHandSideSingle s) = Just $ (weakenSucc $ k, VarsSingle $ Var s $ k >:> ZeroIdx) + go k (LeftHandSidePair l1 l2) + | Just (k', v2) <- go k l2 + , Just (k'', v1) <- go k' l1 = Just (k'', VarsPair v1 v2) + go _ _ = Nothing + +bindingIsTrivial :: LeftHandSide s a env1 env2 -> Vars s env2 b -> Maybe (a :~: b) +bindingIsTrivial lhs vars + | Just lhsVars <- lhsFullVars lhs + , Just Refl <- matchVars vars lhsVars = Just Refl +bindingIsTrivial _ _ = Nothing + +isIdentity :: PreOpenFun acc env aenv (a -> b) -> Maybe (a :~: b) +isIdentity (Lam lhs (Body (extractExpVars -> Just vars))) = bindingIsTrivial lhs vars +isIdentity _ = Nothing + +-- Detects whether the function is of the form \ix -> a ! ix +isIdentityIndexing :: PreOpenFun acc env aenv (a -> b) -> Maybe (acc aenv (Array a b)) +isIdentityIndexing (Lam lhs (Body body)) + | Index a ix <- body + , Just vars <- extractExpVars ix + , Just Refl <- bindingIsTrivial lhs vars = Just a +isIdentityIndexing _ = Nothing -- | Replace the first variable with the given expression. The environment -- shrinks. @@ -83,40 +119,113 @@ inline :: RebuildableAcc acc -> PreOpenExp acc env aenv t inline f g = Stats.substitution "inline" $ rebuildE (subTop g) f +inlineVars :: forall acc env env' aenv t1 t2. + RebuildableAcc acc + => ELeftHandSide t1 env env' + -> PreOpenExp acc env' aenv t2 + -> PreOpenExp acc env aenv t1 + -> Maybe (PreOpenExp acc env aenv t2) +inlineVars lhsBound expr bound + | Just vars <- lhsFullVars lhsBound = substitute (strengthenWithLHS lhsBound) weakenId vars expr + where + substitute :: forall env1 env2 t. + env1 :?> env2 + -> env :> env2 + -> ExpVars env1 t1 + -> PreOpenExp acc env1 aenv t + -> Maybe (PreOpenExp acc env2 aenv t) + substitute _ k2 vars (extractExpVars -> Just vars') + | Just Refl <- matchVars vars vars' = Just $ weakenE k2 bound + substitute k1 k2 vars e = case e of + Let lhs e1 e2 + | Exists lhs' <- rebuildLHS lhs -> Let lhs' <$> travE e1 <*> substitute (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weaken` vars) e2 + Evar (Var t ix) -> Evar . Var t <$> k1 ix + Foreign asm f e1 -> Foreign asm f <$> travE e1 + Pair e1 e2 -> Pair <$> travE e1 <*> travE e2 + Nil -> Just Nil + IndexSlice si e1 e2 -> IndexSlice si <$> travE e1 <*> travE e2 + IndexFull si e1 e2 -> IndexFull si <$> travE e1 <*> travE e2 + ToIndex shr e1 e2 -> ToIndex shr <$> travE e1 <*> travE e2 + FromIndex shr e1 e2 -> FromIndex shr <$> travE e1 <*> travE e2 + Cond e1 e2 e3 -> Cond <$> travE e1 <*> travE e2 <*> travE e3 + While f1 f2 e1 -> While <$> travF f1 <*> travF f2 <*> travE e1 + Const t c -> Just $ Const t c + PrimConst c -> Just $ PrimConst c + PrimApp p e1 -> PrimApp p <$> travE e1 + Index a e1 -> Index a <$> travE e1 + LinearIndex a e1 -> LinearIndex a <$> travE e1 + Shape a -> Just $ Shape a + ShapeSize shr e1 -> ShapeSize shr <$> travE e1 + Undef t -> Just $ Undef t + Coerce t1 t2 e1 -> Coerce t1 t2 <$> travE e1 + + where + travE :: PreOpenExp acc env1 aenv s -> Maybe (PreOpenExp acc env2 aenv s) + travE = substitute k1 k2 vars + + travF :: PreOpenFun acc env1 aenv s -> Maybe (PreOpenFun acc env2 aenv s) + travF = substituteF k1 k2 vars + + substituteF :: forall env1 env2 t. + env1 :?> env2 + -> env :> env2 + -> ExpVars env1 t1 + -> PreOpenFun acc env1 aenv t + -> Maybe (PreOpenFun acc env2 aenv t) + substituteF k1 k2 vars (Body e) = Body <$> substitute k1 k2 vars e + substituteF k1 k2 vars (Lam lhs f) + | Exists lhs' <- rebuildLHS lhs = Lam lhs' <$> substituteF (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weaken` vars) f + +inlineVars _ _ _ = Nothing + + -- | 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 +{- substitute' :: RebuildableAcc acc + => 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 + | isIdentity f = g -- don't rebind an identity function + | isIdentity g = f + | otherwise = Let g $ rebuildE split f where - split :: Elt c => Idx (env,b) c -> PreOpenExp acc ((env,a),b) aenv c + split :: Idx (env,b) c -> PreOpenExp acc ((env,a),b) aenv c split ZeroIdx = Var ZeroIdx split (SuccIdx ix) = Var (SuccIdx (SuccIdx ix)) +substitute :: RebuildableAcc acc + => LeftHandSide b env envb + -> PreOpenExp acc envb c + -> LeftHandSide a env enva + -> PreOpenExp acc enva b +-} -- | Composition of unary functions. -- -compose :: (RebuildableAcc acc, Elt c) +compose :: RebuildableAcc acc => 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" +compose f@(Lam lhsB (Body c)) g@(Lam lhsA (Body b)) + | Stats.substitution "compose" False = undefined + | Just Refl <- isIdentity f = g -- don't rebind an identity function + | Just Refl <- isIdentity g = f + + | Exists lhsB' <- rebuildLHS lhsB + = Lam lhsA $ Body $ Let lhsB' b (weakenE (shiftWithLHS lhsB lhsB' $ weakenWithLHS lhsA) c) + -- = Stats.substitution "compose" . Lam lhs2 . 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 +subTop :: PreOpenExp acc env aenv s -> ExpVar (env, s) t -> PreOpenExp acc env aenv t +subTop s (Var _ ZeroIdx ) = s +subTop _ (Var tp (SuccIdx ix)) = Evar $ Var tp ix subAtop :: PreOpenAcc acc aenv t -> ArrayVar (aenv, t) (Array sh2 e2) -> PreOpenAcc acc aenv (Array sh2 e2) -subAtop t (ArrayVar ZeroIdx ) = t -subAtop _ (ArrayVar (SuccIdx idx)) = Avar $ ArrayVar idx +subAtop t (Var _ ZeroIdx ) = t +subAtop _ (Var repr (SuccIdx idx)) = Avar $ Var repr idx data Identity a = Identity { runIdentity :: a } @@ -153,13 +262,13 @@ class Rebuildable f where 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')) + => (forall e'. ExpVar env e' -> f' (fe (AccClo (f env)) env' aenv e')) -> f env aenv e -> f' (f env' aenv e) {-# INLINEABLE rebuildE #-} rebuildE :: SyntacticExp fe - => (forall e'. Elt e' => Idx env e' -> fe (AccClo (f env)) env' aenv e') + => (forall e'. ExpVar env e' -> fe (AccClo (f env)) env' aenv e') -> f env aenv e -> f env' aenv e rebuildE v = runIdentity . rebuildPartialE (Identity . v) @@ -190,14 +299,6 @@ instance RebuildableAcc acc => Rebuildable (PreOpenAfun acc) where {-# INLINEABLE rebuildPartial #-} rebuildPartial x = Stats.substitution "rebuild" $ rebuildAfun rebuildPartial x --- 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 = Stats.substitution "rebuild" . RebuildTup <$> rebuildTup rebuildPartial (pure . IE) v (unRTup t) - instance Rebuildable OpenAcc where type AccClo OpenAcc = OpenAcc {-# INLINEABLE rebuildPartial #-} @@ -240,20 +341,23 @@ class Sink f where instance Sink Idx where {-# INLINEABLE weaken #-} - weaken k = k + weaken = (>:>) -instance Sink ArrayVar where +instance Sink (Var s) where {-# INLINEABLE weaken #-} - weaken k (ArrayVar ix) = ArrayVar (k ix) + weaken k (Var s ix) = Var s (k >:> ix) -instance Sink ArrayVars where +instance Sink (Vars s) where {-# INLINEABLE weaken #-} - weaken _ ArrayVarsNil = ArrayVarsNil - weaken k (ArrayVarsArray v) = ArrayVarsArray $ weaken k v - weaken k (ArrayVarsPair v w) = ArrayVarsPair (weaken k v) (weaken k w) + weaken _ VarsNil = VarsNil + weaken k (VarsSingle v) = VarsSingle $ weaken k v + weaken k (VarsPair v w) = VarsPair (weaken k v) (weaken k w) rebuildWeakenVar :: env :> env' -> ArrayVar env (Array sh e) -> PreOpenAcc acc env' (Array sh e) -rebuildWeakenVar k (ArrayVar idx) = Avar $ ArrayVar $ k idx +rebuildWeakenVar k (Var s idx) = Avar $ Var s $ k >:> idx + +rebuildWeakenEvar :: env :> env' -> ExpVar env t -> PreOpenExp acc env' aenv t +rebuildWeakenEvar k (Var s idx) = Evar $ Var s $ k >:> idx instance RebuildableAcc acc => Sink (PreOpenAcc acc) where {-# INLINEABLE weaken #-} @@ -271,10 +375,6 @@ instance RebuildableAcc acc => Sink (PreOpenFun acc env) where {-# INLINEABLE weaken #-} weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) -instance RebuildableAcc acc => Sink (RebuildTup acc env) where - {-# INLINEABLE weaken #-} - weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) - instance RebuildableAcc acc => Sink (PreBoundary acc) where {-# INLINEABLE weaken #-} weaken k bndy = @@ -307,11 +407,11 @@ class SinkExp f where instance RebuildableAcc acc => SinkExp (PreOpenExp acc) where {-# INLINEABLE weakenE #-} - weakenE v = Stats.substitution "weakenE" . rebuildE (IE . v) + weakenE v = Stats.substitution "weakenE" . rebuildE (rebuildWeakenEvar v) instance RebuildableAcc acc => SinkExp (PreOpenFun acc) where {-# INLINEABLE weakenE #-} - weakenE v = Stats.substitution "weakenE" . rebuildE (IE . v) + weakenE v = Stats.substitution "weakenE" . rebuildE (rebuildWeakenEvar v) -- See above for why this is disabled. -- {-# RULES @@ -332,11 +432,27 @@ type env :?> env' = forall t'. Idx env t' -> Maybe (Idx env' t') {-# INLINEABLE strengthen #-} strengthen :: forall f env env' t. Rebuildable f => env :?> env' -> f env t -> Maybe (f env' t) -strengthen k x = Stats.substitution "strengthen" $ rebuildPartial @f @Maybe @IdxA (\(ArrayVar idx) -> fmap (IA . ArrayVar) $ k idx) x -- (\(ArrayVar idx) -> fmap (IA . ArrayVar) $ k idx) +strengthen k x = Stats.substitution "strengthen" $ rebuildPartial @f @Maybe @IdxA (\(Var s ix) -> fmap (IA . Var s) $ k ix) x {-# INLINEABLE strengthenE #-} -strengthenE :: RebuildableExp f => env :?> env' -> f env aenv t -> Maybe (f env' aenv t) -strengthenE k x = Stats.substitution "strengthenE" $ rebuildPartialE (fmap IE . k) x +strengthenE :: forall f env env' aenv t. RebuildableExp f => env :?> env' -> f env aenv t -> Maybe (f env' aenv t) +strengthenE k x = Stats.substitution "strengthenE" $ rebuildPartialE @f @Maybe @IdxE (\(Var tp ix) -> fmap (IE . Var tp) $ k ix) x + +strengthenWithLHS :: LeftHandSide s t env1 env2 -> env2 :?> env1 +strengthenWithLHS (LeftHandSideWildcard _) = Just +strengthenWithLHS (LeftHandSideSingle _) = \ix -> case ix of + ZeroIdx -> Nothing + SuccIdx i -> Just i +strengthenWithLHS (LeftHandSidePair l1 l2) = strengthenWithLHS l2 >=> strengthenWithLHS l1 + +strengthenAfter :: LeftHandSide s t env1 env2 -> LeftHandSide s t env1' env2' -> env1 :?> env1' -> env2 :?> env2' +strengthenAfter (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k +strengthenAfter (LeftHandSideSingle _) (LeftHandSideSingle _) k = \ix -> case ix of + ZeroIdx -> Just ZeroIdx + SuccIdx i -> SuccIdx <$> k i +strengthenAfter (LeftHandSidePair l1 l2) (LeftHandSidePair l1' l2') k + = strengthenAfter l2 l2' $ strengthenAfter l1 l1' k +strengthenAfter _ _ _ = error "Substitution.strengthenAfter: left hand sides do not match" -- Simultaneous Substitution =================================================== -- @@ -348,98 +464,95 @@ strengthenE k x = Stats.substitution "strengthenE" $ rebuildPartialE (fmap IE . -- 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 + varIn :: ExpVar env t -> f acc env aenv t + expOut :: f acc env aenv t -> PreOpenExp acc env aenv t + weakenExp :: RebuildAcc acc -> f acc env aenv t -> f acc (env, s) aenv t + -- weakenExpAcc :: RebuildAcc acc -> f acc env aenv t -> f acc env (aenv, s) t -newtype IdxE (acc :: Type -> Type -> Type) env aenv t = IE { unIE :: Idx env t } +newtype IdxE (acc :: Type -> Type -> Type) env aenv t = IE { unIE :: ExpVar env t } instance SyntacticExp IdxE where varIn = IE - expOut = Var . unIE - weakenExp _ = IE . SuccIdx . unIE + expOut = Evar . unIE + weakenExp _ (IE (Var tp ix)) = IE $ Var tp $ SuccIdx ix -- weakenExpAcc _ = IE . unIE instance SyntacticExp PreOpenExp where - varIn = Var + varIn = Evar 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) + :: (Applicative f, SyntacticExp fe) => 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) + -> RebuildEvar f fe acc env env' aenv + -> RebuildEvar f fe acc (env, s) (env', s) aenv +shiftE _ _ (Var tp ZeroIdx) = pure $ varIn (Var tp ZeroIdx) +shiftE k v (Var tp (SuccIdx ix)) = weakenExp k <$> v (Var tp ix) + +{-# INLINEABLE shiftE' #-} +shiftE' + :: (Applicative f, SyntacticExp fa) + => ELeftHandSide t env1 env1' + -> ELeftHandSide t env2 env2' + -> RebuildAcc acc + -> RebuildEvar f fa acc env1 env2 aenv + -> RebuildEvar f fa acc env1' env2' aenv +shiftE' (LeftHandSideWildcard _) (LeftHandSideWildcard _) _ v = v +shiftE' (LeftHandSideSingle _) (LeftHandSideSingle _) k v = shiftE k v +shiftE' (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k v = shiftE' b1 b2 k $ shiftE' a1 a2 k v +shiftE' _ _ _ _ = error "Substitution: left hand sides do not match" + {-# INLINEABLE rebuildPreOpenExp #-} rebuildPreOpenExp :: (Applicative f, SyntacticExp fe, SyntacticAcc fa) => RebuildAcc acc - -> (forall t'. Elt t' => Idx env t' -> f (fe acc env' aenv' t')) + -> RebuildEvar f fe acc env env' aenv' -> RebuildAvar f fa acc aenv aenv' -> 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')) - -> RebuildAvar f fa acc aenv aenv' - -> 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 + Const t c -> pure $ Const t c + PrimConst c -> pure $ PrimConst c + Undef t -> pure $ Undef t + Evar var -> expOut <$> v var + Let lhs a b + | Exists lhs' <- rebuildLHS lhs + -> Let lhs' <$> rebuildPreOpenExp k v av a <*> rebuildPreOpenExp k (shiftE' lhs lhs' k v) av b + Pair e1 e2 -> Pair <$> rebuildPreOpenExp k v av e1 <*> rebuildPreOpenExp k v av e2 + Nil -> pure $ Nil + 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 shr sh ix -> ToIndex shr <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av ix + FromIndex shr sh ix -> FromIndex shr <$> 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 shr sh -> ShapeSize shr <$> rebuildPreOpenExp k v av sh + Foreign ff f e -> Foreign ff f <$> rebuildPreOpenExp k v av e + Coerce t1 t2 e -> Coerce t1 t2 <$> 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')) + -> RebuildEvar f fe acc env env' aenv' -> RebuildAvar f fa acc aenv aenv' -> 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 + Lam lhs f + | Exists lhs' <- rebuildLHS lhs + -> Lam lhs' <$> rebuildFun k (shiftE' lhs lhs' k v) av f -- The array environment -- ----------------- @@ -458,9 +571,9 @@ class SyntacticAcc f where weakenAcc :: RebuildAcc acc -> f acc aenv (Array sh e) -> f acc (aenv, s) (Array sh e) instance SyntacticAcc IdxA where - avarIn = IA - accOut = Avar . unIA - weakenAcc _ (IA (ArrayVar idx)) = IA $ ArrayVar $ SuccIdx idx + avarIn = IA + accOut = Avar . unIA + weakenAcc _ (IA (Var s idx)) = IA $ Var s $ SuccIdx idx instance SyntacticAcc PreOpenAcc where avarIn = Avar @@ -470,6 +583,9 @@ instance SyntacticAcc PreOpenAcc where type RebuildAvar f (fa :: (* -> * -> *) -> * -> * -> *) acc aenv aenv' = forall sh e. ArrayVar aenv (Array sh e) -> f (fa acc aenv' (Array sh e)) +type RebuildEvar f fe (acc :: * -> * -> *) env env' aenv' = + forall t'. ExpVar env t' -> f (fe acc env' aenv' t') + {-# INLINEABLE shiftA #-} shiftA :: (Applicative f, SyntacticAcc fa) @@ -477,18 +593,18 @@ shiftA -> RebuildAvar f fa acc aenv aenv' -> ArrayVar (aenv, s) (Array sh e) -> f (fa acc (aenv', s) (Array sh e)) -shiftA _ _ (ArrayVar ZeroIdx) = pure $ avarIn $ ArrayVar ZeroIdx -shiftA k v (ArrayVar (SuccIdx ix)) = weakenAcc k <$> v (ArrayVar ix) +shiftA _ _ (Var s ZeroIdx) = pure $ avarIn $ Var s ZeroIdx +shiftA k v (Var s (SuccIdx ix)) = weakenAcc k <$> v (Var s ix) shiftA' :: (Applicative f, SyntacticAcc fa) - => LeftHandSide t aenv1 aenv1' - -> LeftHandSide t aenv2 aenv2' + => ALeftHandSide t aenv1 aenv1' + -> ALeftHandSide t aenv2 aenv2' -> RebuildAcc acc -> RebuildAvar f fa acc aenv1 aenv2 -> RebuildAvar f fa acc aenv1' aenv2' shiftA' (LeftHandSideWildcard _) (LeftHandSideWildcard _) _ v = v -shiftA' LeftHandSideArray LeftHandSideArray k v = shiftA k v +shiftA' (LeftHandSideSingle _) (LeftHandSideSingle _) k v = shiftA k v shiftA' (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k v = shiftA' b1 b2 k $ shiftA' a1 a2 k v shiftA' _ _ _ _ = error "Substitution: left hand sides do not match" @@ -509,7 +625,7 @@ rebuildPreOpenAcc -> f (PreOpenAcc acc aenv' t) rebuildPreOpenAcc k av acc = case acc of - Use a -> pure (Use a) + Use repr a -> pure $ Use repr a Alet lhs a b -> rebuildAlet k av lhs a b Avar ix -> accOut <$> av ix Apair as bs -> Apair <$> k av as <*> k av bs @@ -518,17 +634,17 @@ rebuildPreOpenAcc k av acc = 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 + Reshape shr e a -> Reshape shr <$> rebuildPreOpenExp k (pure . IE) av e <*> k av a + Generate repr e f -> Generate repr <$> rebuildPreOpenExp k (pure . IE) av e <*> rebuildFun k (pure . IE) av f + Transform repr sh ix f a -> Transform repr <$> 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 + Map tp f a -> Map tp <$> rebuildFun k (pure . IE) av f <*> k av a + ZipWith tp f a1 a2 -> ZipWith tp <$> 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 + FoldSeg itp f z a s -> FoldSeg itp <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a <*> k av s + Fold1Seg itp f a s -> Fold1Seg itp <$> 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 @@ -536,9 +652,9 @@ rebuildPreOpenAcc k av acc = 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 + Backpermute shr sh f a -> Backpermute shr <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av f <*> k av a + Stencil sr tp f b a -> Stencil sr tp <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b <*> k av a + Stencil2 s1 s2 tp f b1 a1 b2 a2 -> Stencil2 s1 s2 tp <$> 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 @@ -559,7 +675,7 @@ rebuildAlet :: forall f fa acc aenv1 aenv1' aenv2 bndArrs arrs. (Applicative f, SyntacticAcc fa) => RebuildAcc acc -> RebuildAvar f fa acc aenv1 aenv2 - -> LeftHandSide bndArrs aenv1 aenv1' + -> ALeftHandSide bndArrs aenv1 aenv1' -> acc aenv1 bndArrs -> acc aenv1' arrs -> f (PreOpenAcc acc aenv2 arrs) @@ -567,9 +683,9 @@ rebuildAlet k av lhs1 bind1 body1 = case rebuildLHS lhs1 of Exists lhs2 -> Alet lhs2 <$> k av bind1 <*> k (shiftA' lhs1 lhs2 k av) body1 {-# INLINEABLE rebuildLHS #-} -rebuildLHS :: LeftHandSide arr aenv1 aenv1' -> Exists (LeftHandSide arr aenv2) +rebuildLHS :: LeftHandSide s t aenv1 aenv1' -> Exists (LeftHandSide s t aenv2) rebuildLHS (LeftHandSideWildcard r) = Exists $ LeftHandSideWildcard r -rebuildLHS LeftHandSideArray = Exists $ LeftHandSideArray +rebuildLHS (LeftHandSideSingle s) = Exists $ LeftHandSideSingle s rebuildLHS (LeftHandSidePair as bs) = case rebuildLHS as of Exists as' -> case rebuildLHS bs of Exists bs' -> Exists $ LeftHandSidePair as' bs' @@ -635,3 +751,8 @@ rebuildC k v c = rebuildT (SnocAtup t s) = SnocAtup <$> (rebuildT t) <*> (rebuildC k v s) --} +extractExpVars :: PreOpenExp acc env aenv a -> Maybe (ExpVars env a) +extractExpVars Nil = Just VarsNil +extractExpVars (Pair e1 e2) = VarsPair <$> extractExpVars e1 <*> extractExpVars e2 +extractExpVars (Evar v) = Just $ VarsSingle v +extractExpVars _ = Nothing diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index b098ae112..082d72375 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -74,6 +74,7 @@ module Data.Array.Accelerate.Type ( ) where import Data.Orphans () -- orphan instances for 8-tuples and beyond +import Data.Array.Accelerate.Orphans () -- Prim Half import Control.Monad.ST import Data.Bits @@ -117,6 +118,9 @@ data NonNumDict a where NonNumDict :: ( Bounded a, Eq a, Ord a, Show a, Storable a ) => NonNumDict a +data TypeableDict a where + TypeableDict :: Typeable a => TypeableDict a + -- Scalar type representation -- @@ -171,7 +175,7 @@ data SingleType a where NonNumSingleType :: NonNumType a -> SingleType a data VectorType a where - VectorType :: {-# UNPACK #-} !Int -> SingleType a -> VectorType (Vec n a) + VectorType :: KnownNat n => {-# UNPACK #-} !Int -> SingleType a -> VectorType (Vec n a) -- Showing type names -- @@ -279,7 +283,74 @@ nonNumDict :: NonNumType a -> NonNumDict a nonNumDict TypeBool = NonNumDict nonNumDict TypeChar = NonNumDict - +typeableDict :: TupleType tp -> TypeableDict tp +typeableDict TupRunit = TypeableDict +typeableDict (TupRpair t1 t2) + | TypeableDict <- typeableDict t1 + , TypeableDict <- typeableDict t2 = TypeableDict +typeableDict (TupRsingle tp) = scalarTypeableDict tp + +scalarTypeableDict :: ScalarType tp -> TypeableDict tp +scalarTypeableDict (SingleScalarType tp) = singleTypeableDict tp +scalarTypeableDict (VectorScalarType (VectorType _ tp)) + | TypeableDict <- singleTypeableDict tp = TypeableDict + +singleTypeableDict :: SingleType tp -> TypeableDict tp +singleTypeableDict (NumSingleType (IntegralNumType tp)) = case tp of + TypeInt -> TypeableDict + TypeInt8 -> TypeableDict + TypeInt16 -> TypeableDict + TypeInt32 -> TypeableDict + TypeInt64 -> TypeableDict + TypeWord -> TypeableDict + TypeWord8 -> TypeableDict + TypeWord16 -> TypeableDict + TypeWord32 -> TypeableDict + TypeWord64 -> TypeableDict +singleTypeableDict (NumSingleType (FloatingNumType tp)) = case tp of + TypeHalf -> TypeableDict + TypeFloat -> TypeableDict + TypeDouble -> TypeableDict +singleTypeableDict (NonNumSingleType TypeChar) = TypeableDict +singleTypeableDict (NonNumSingleType TypeBool) = TypeableDict + +showType :: TupleType tp -> ShowS +showType TupRunit = showString "()" +showType (TupRsingle tp) = showString $ showScalarType tp +showType (TupRpair t1 t2) = showString "(" . showType t1 . showString ", " . showType t2 . showString ")" + +showScalarType :: ScalarType tp -> String +showScalarType (SingleScalarType tp) = showSingleType tp +showScalarType (VectorScalarType (VectorType n tp)) = "Vec " ++ show n ++ " " ++ showSingleType tp + +showSingleType :: SingleType tp -> String +showSingleType (NumSingleType (IntegralNumType tp)) = case tp of + TypeInt -> "Int" + TypeInt8 -> "Int8" + TypeInt16 -> "Int16" + TypeInt32 -> "Int32" + TypeInt64 -> "Int64" + TypeWord -> "Word" + TypeWord8 -> "Word8" + TypeWord16 -> "Word16" + TypeWord32 -> "Word32" + TypeWord64 -> "Word64" +showSingleType (NumSingleType (FloatingNumType tp)) = case tp of + TypeHalf -> "Half" + TypeFloat -> "Float" + TypeDouble -> "Double" +showSingleType (NonNumSingleType TypeChar) = "Char" +showSingleType (NonNumSingleType TypeBool) = "Bool" + +-- Common used types in the compiler. +scalarTypeBool :: ScalarType Bool +scalarTypeBool = SingleScalarType $ NonNumSingleType TypeBool + +scalarTypeInt :: ScalarType Int +scalarTypeInt = SingleScalarType $ NumSingleType $ IntegralNumType TypeInt + +scalarTypeWord8 :: ScalarType Word8 +scalarTypeWord8 = SingleScalarType $ NumSingleType $ IntegralNumType TypeWord8 -- Tuple representation -- ------------------- @@ -309,6 +380,27 @@ instance Show (TupR ScalarType a) where show (TupRsingle t) = show t show (TupRpair a b) = "(" ++ show a ++ "," ++ show b ++")" +type Tup2 a b = (((), a), b) +type Tup3 a b c = ((((), a), b), c) +type Tup5 a b c d e = ((((((), a), b), c), d), e) +type Tup7 a b c d e f g = ((((((((), a), b), c), d), e), f), g) +type Tup9 a b c d e f g h i = ((((((((((), a), b), c), d), e), f), g), h), i) + +tupR2 :: TupR s t1 -> TupR s t2 -> TupR s (Tup2 t1 t2) +tupR2 t1 t2 = TupRunit `TupRpair` t1 `TupRpair` t2 + +tupR3 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s (Tup3 t1 t2 t3) +tupR3 t1 t2 t3 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 + +tupR5 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s t4 -> TupR s t5 -> TupR s (Tup5 t1 t2 t3 t4 t5) +tupR5 t1 t2 t3 t4 t5 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 `TupRpair` t4 `TupRpair` t5 + +tupR7 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s t4 -> TupR s t5 -> TupR s t6 -> TupR s t7 -> TupR s (Tup7 t1 t2 t3 t4 t5 t6 t7) +tupR7 t1 t2 t3 t4 t5 t6 t7 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 `TupRpair` t4 `TupRpair` t5 `TupRpair` t6 `TupRpair` t7 + +tupR9 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s t4 -> TupR s t5 -> TupR s t6 -> TupR s t7 -> TupR s t8 -> TupR s t9 -> TupR s (Tup9 t1 t2 t3 t4 t5 t6 t7 t8 t9) +tupR9 t1 t2 t3 t4 t5 t6 t7 t8 t9 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 `TupRpair` t4 `TupRpair` t5 `TupRpair` t6 `TupRpair` t7 `TupRpair` t8 `TupRpair` t9 + -- Type-level bit sizes -- -------------------- @@ -379,6 +471,29 @@ vecToArray (Vec ba#) = go 0# instance Eq (Vec n a) where Vec ba1# == Vec ba2# = ByteArray ba1# == ByteArray ba2# +data IsPrim a where + IsPrim :: Prim a => IsPrim a + +getPrim :: SingleType a -> IsPrim a +getPrim (NumSingleType (IntegralNumType tp)) = case tp of + TypeInt -> IsPrim + TypeInt8 -> IsPrim + TypeInt16 -> IsPrim + TypeInt32 -> IsPrim + TypeInt64 -> IsPrim + TypeWord -> IsPrim + TypeWord8 -> IsPrim + TypeWord16 -> IsPrim + TypeWord32 -> IsPrim + TypeWord64 -> IsPrim +getPrim (NumSingleType (FloatingNumType tp)) = case tp of + TypeHalf -> IsPrim + TypeFloat -> IsPrim + TypeDouble -> IsPrim +getPrim (NonNumSingleType TypeChar) = IsPrim +getPrim (NonNumSingleType TypeBool) = error "prim: We don't support vector of bools yet" + + -- Type synonyms for common SIMD vector types -- diff --git a/src/Data/Array/Accelerate/Unsafe.hs b/src/Data/Array/Accelerate/Unsafe.hs index 82824e28f..4701618e9 100644 --- a/src/Data/Array/Accelerate/Unsafe.hs +++ b/src/Data/Array/Accelerate/Unsafe.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Data.Array.Accelerate.Unsafe -- Copyright : [2009..2019] The Accelerate Team @@ -15,7 +17,7 @@ module Data.Array.Accelerate.Unsafe ( -- ** Unsafe operations - undef, coerce, + undef, coerce, Coerce ) where @@ -39,11 +41,10 @@ import Data.Array.Accelerate.Smart -- 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. +-- The type class 'Coerce' assures that there is a coercion between the two +-- types. -- -- @since 1.2.0.0 -- -coerce :: (Elt a, Elt b) => Exp a -> Exp b -coerce = mkUnsafeCoerce - +coerce :: Coerce (EltRepr a) (EltRepr b) => Exp a -> Exp b +coerce = mkCoerce From da18b951f85c969971929199e0b03114ff210b6c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 11 Mar 2020 12:23:47 +0100 Subject: [PATCH 160/316] export liftArraysR --- src/Data/Array/Accelerate/AST.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 67cff57df..3da133ce4 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -111,7 +111,7 @@ module Data.Array.Accelerate.AST ( liftIdx, liftTupleIdx, liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp, - liftLHS, liftArray, + liftArray, liftArraysR, liftLHS, -- Utilities Exists(..), weakenWithLHS, (:>), @@ -1605,8 +1605,8 @@ liftPreOpenAcc liftA pacc = Stencil2 f b1 a1 b2 a2 -> [|| Stencil2 $$(liftF f) $$(liftB b1) $$(liftA a1) $$(liftB b2) $$(liftA a2) ||] liftLHS :: LeftHandSide arrs aenv aenv' -> Q (TExp (LeftHandSide arrs aenv aenv')) -liftLHS (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftArraysR r) ||] liftLHS LeftHandSideArray = [|| LeftHandSideArray ||] +liftLHS (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftArraysR r) ||] liftLHS (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftLHS a) $$(liftLHS b) ||] liftArraysR :: ArraysR arrs -> Q (TExp (ArraysR arrs)) From 63ed0538ff6a77b3dc5d7609aae199d7a07b895f Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 18 Mar 2020 12:16:09 +0100 Subject: [PATCH 161/316] Refactor to use surface types for expressions --- src/Data/Array/Accelerate/AST.hs | 44 +- src/Data/Array/Accelerate/Analysis/Hash.hs | 4 +- src/Data/Array/Accelerate/Analysis/Match.hs | 7 +- .../Array/Accelerate/Array/Representation.hs | 37 +- src/Data/Array/Accelerate/Array/Sugar.hs | 18 +- src/Data/Array/Accelerate/Data/Either.hs | 33 +- src/Data/Array/Accelerate/Data/Maybe.hs | 25 +- src/Data/Array/Accelerate/Interpreter.hs | 959 ++++++++---------- src/Data/Array/Accelerate/Pretty.hs | 2 +- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 4 +- src/Data/Array/Accelerate/Pretty/Print.hs | 4 +- src/Data/Array/Accelerate/Trafo.hs | 22 +- src/Data/Array/Accelerate/Trafo/Base.hs | 52 +- src/Data/Array/Accelerate/Trafo/Fusion.hs | 682 +++++++------ src/Data/Array/Accelerate/Trafo/Sharing.hs | 20 +- src/Data/Array/Accelerate/Trafo/Shrink.hs | 4 +- .../Array/Accelerate/Trafo/Substitution.hs | 11 +- 17 files changed, 975 insertions(+), 953 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 6ce91b391..7ce9683c0 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -84,7 +84,7 @@ module Data.Array.Accelerate.AST ( -- * Typed de Bruijn indices Idx(..), idxToInt, tupleIdxToInt, Var(..), Vars(..), ArrayVar, ArrayVars, ExpVar, ExpVars, - evars, LeftHandSide(..), ALeftHandSide, ELeftHandSide, + evars, varsType, LeftHandSide(..), ALeftHandSide, ELeftHandSide, -- * Valuation environment Val(..), push, prj, @@ -117,7 +117,7 @@ module Data.Array.Accelerate.AST ( -- Utilities Exists(..), weakenWithLHS, (:>), weakenId, weakenSucc, weakenSucc', (.>), (>:>), - shift, shiftWithLHS, + sink, sinkWithLHS, -- debugging showPreAccOp, showPreExpOp, showShortendArr, showElement @@ -278,9 +278,8 @@ weakenSucc' (Weaken f) = Weaken (SuccIdx . f) weakenSucc :: (env, t) :> env' -> env :> env' weakenSucc (Weaken f) = Weaken (f . SuccIdx) --- TODO: Rename to sink -shift :: forall env env' t. env :> env' -> (env, t) :> (env', t) -shift (Weaken f) = Weaken g +sink :: forall env env' t. env :> env' -> (env, t) :> (env', t) +sink (Weaken f) = Weaken g where g :: Idx (env, t) t' -> Idx (env', t) t' g ZeroIdx = ZeroIdx @@ -290,12 +289,11 @@ infixr 9 .> (.>) :: env2 :> env3 -> env1 :> env2 -> env1 :> env3 (.>) (Weaken f) (Weaken g) = Weaken (f . g) --- TODO: REname to sinkWithLHS -shiftWithLHS :: LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> env1 :> env2 -> env1' :> env2' -shiftWithLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k -shiftWithLHS (LeftHandSideSingle _) (LeftHandSideSingle _) k = shift k -shiftWithLHS (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k = shiftWithLHS b1 b2 $ shiftWithLHS a1 a2 k -shiftWithLHS _ _ _ = error "shiftWithLHS: left hand sides do not match" +sinkWithLHS :: LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> env1 :> env2 -> env1' :> env2' +sinkWithLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k +sinkWithLHS (LeftHandSideSingle _) (LeftHandSideSingle _) k = sink k +sinkWithLHS (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k = sinkWithLHS b1 b2 $ sinkWithLHS a1 a2 k +sinkWithLHS _ _ _ = error "sinkWithLHS: left hand sides do not match" weakenWithLHS :: forall s t env env'. LeftHandSide s t env env' -> env :> env' weakenWithLHS = go weakenId @@ -327,6 +325,11 @@ evars VarsNil = Nil evars (VarsSingle var) = Evar var evars (VarsPair v1 v2) = evars v1 `Pair` evars v2 +varsType :: Vars s env t -> TupR s t +varsType (VarsSingle (Var tp _)) = TupRsingle tp +varsType VarsNil = TupRunit +varsType (VarsPair v1 v2) = varsType v1 `TupRpair` varsType v2 + -- | Collective array computations parametrised over array variables -- represented with de Bruijn indices. -- @@ -374,7 +377,8 @@ data PreOpenAcc acc aenv a where -- 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 :: PreOpenAfun acc aenv (arrs1 -> arrs2) + Apply :: ArraysR arrs2 + -> PreOpenAfun acc aenv (arrs1 -> arrs2) -> acc aenv arrs1 -> PreOpenAcc acc aenv arrs2 @@ -412,7 +416,8 @@ data PreOpenAcc acc aenv a where -- Capture a scalar (or a tuple of scalars) in a singleton array -- - Unit :: PreExp acc aenv e + Unit :: TupleType e + -> PreExp acc aenv e -> PreOpenAcc acc aenv (Scalar e) -- Change the shape of an array without altering its contents. @@ -774,8 +779,7 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr (Avar (Var repr _)) = TupRsingle repr arraysRepr (Apair as bs) = TupRpair (arraysRepr as) (arraysRepr bs) arraysRepr Anil = TupRunit - arraysRepr (Apply (Alam _ (Abody a)) _) = arraysRepr a - arraysRepr (Apply _ _) = error "Tomorrow will arrive, on time" + arraysRepr (Apply repr _ _) = repr arraysRepr (Aforeign _ (Alam _ (Abody a)) _) = arraysRepr a arraysRepr (Aforeign _ (Abody _) _) = error "And what have you got, at the end of the day?" arraysRepr (Aforeign _ (Alam _ (Alam _ _)) _) = error "A bottle of whisky. And a new set of lies." @@ -783,7 +787,7 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr (Awhile _ (Alam lhs _) _) = lhsToTupR lhs arraysRepr (Awhile _ _ _) = error "I want my, I want my MTV!" arraysRepr (Use repr _) = TupRsingle repr - arraysRepr (Unit e) = arraysRarray ShapeRz $ expType e + arraysRepr (Unit tp _) = arraysRarray ShapeRz tp arraysRepr (Reshape sh _ a) = let TupRsingle (ArrayR _ tp) = arraysRepr a in arraysRarray sh tp arraysRepr (Generate repr _ _) = TupRsingle repr @@ -1325,12 +1329,12 @@ rnfPreOpenAcc rnfA pacc = Avar (Var repr ix) -> rnfArrayR repr `seq` rnfIdx ix Apair as bs -> rnfA as `seq` rnfA bs Anil -> () - Apply afun acc -> rnfAF afun `seq` rnfA acc + Apply repr afun acc -> rnfTupR rnfArrayR repr `seq` rnfAF afun `seq` rnfA acc Aforeign asm afun a -> rnf (Sugar.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 repr arr -> rnfArray repr arr - Unit x -> rnfE x + Unit tp x -> rnfTupleType tp `seq` rnfE x Reshape shr sh a -> rnfShapeR shr `seq` rnfE sh `seq` rnfA a Generate repr sh f -> rnfArrayR repr `seq` rnfE sh `seq` rnfF f Transform repr sh p f a -> rnfArrayR repr `seq` rnfE sh `seq` rnfF p `seq` rnfF f `seq` rnfA a @@ -1691,12 +1695,12 @@ liftPreOpenAcc liftA pacc = Avar (Var tp ix) -> [|| Avar (Var $$(liftArrayR tp) $$(liftIdx ix)) ||] Apair as bs -> [|| Apair $$(liftA as) $$(liftA bs) ||] Anil -> [|| Anil ||] - Apply f a -> [|| Apply $$(liftAF f) $$(liftA a) ||] + Apply repr f a -> [|| Apply $$(liftArraysR repr) $$(liftAF f) $$(liftA a) ||] Aforeign asm f a -> [|| Aforeign $$(Sugar.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 repr a -> [|| Use $$(liftArrayR repr) $$(liftArray repr a) ||] - Unit e -> [|| Unit $$(liftE e) ||] + Unit tp e -> [|| Unit $$(liftTupleType tp) $$(liftE e) ||] Reshape shr sh a -> [|| Reshape $$(liftShapeR shr) $$(liftE sh) $$(liftA a) ||] Generate repr sh f -> [|| Generate $$(liftArrayR repr) $$(liftE sh) $$(liftF f) ||] Transform repr sh p f a -> [|| Transform $$(liftArrayR repr) $$(liftE sh) $$(liftF p) $$(liftF f) $$(liftA a) ||] diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index fba76156a..00600896a 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -168,11 +168,11 @@ encodePreOpenAcc options encodeAcc pacc = Avar (Var repr v) -> intHost $(hashQ "Avar") <> encodeArrayType repr <> deep (encodeIdx v) Apair a1 a2 -> intHost $(hashQ "Apair") <> travA a1 <> travA a2 Anil -> intHost $(hashQ "Anil") - Apply f a -> intHost $(hashQ "Apply") <> travAF f <> travA a + Apply _ f a -> intHost $(hashQ "Apply") <> travAF f <> travA a Aforeign _ f a -> intHost $(hashQ "Aforeign") <> travAF f <> travA a Use repr a -> intHost $(hashQ "Use") <> encodeArrayType repr <> deep (encodeArray a) Awhile p f a -> intHost $(hashQ "Awhile") <> travAF f <> travAF p <> travA a - Unit e -> intHost $(hashQ "Unit") <> travE e + Unit _ e -> intHost $(hashQ "Unit") <> travE e Generate _ e f -> intHost $(hashQ "Generate") <> deepE e <> travF f -- We don't need to encode the type of 'e' when perfect is False, as 'e' is an expression of type Bool. -- We thus use `deep (travE e)` instead of `deepE e`. diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index edfeb60cf..485511503 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -93,7 +93,7 @@ matchPreOpenAcc matchAcc encodeAcc = match match Anil Anil = Just Refl - match (Apply f1 a1) (Apply f2 a2) + match (Apply _ f1 a1) (Apply _ f2 a2) | Just Refl <- matchPreOpenAfun matchAcc f1 f2 , Just Refl <- matchAcc a1 a2 = Just Refl @@ -122,8 +122,9 @@ matchPreOpenAcc matchAcc encodeAcc = match | Just Refl <- matchArray repr1 repr2 a1 a2 = Just Refl - match (Unit e1) (Unit e2) - | Just Refl <- matchExp e1 e2 + match (Unit t1 e1) (Unit t2 e2) + | Just Refl <- matchTupleType t1 t2 + , Just Refl <- matchExp e1 e2 = Just Refl match (Reshape _ sh1 a1) (Reshape _ sh2 a2) diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index 036f5a5ef..a8a5bc270 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -25,7 +25,7 @@ module Data.Array.Accelerate.Array.Representation ( -- * Array data type in terms of representation types Array(..), ArrayR(..), arraysRarray, arraysRtuple2, arrayRshape, arrayRtype, rnfArray, rnfShape, ArraysR, TupleType, Scalar, Vector, Matrix, fromList, toList, Segments, shape, reshape, concatVectors, - showArrayR, showArraysR, + showArrayR, showArraysR, fromFunction, fromFunctionM, -- * Array shapes, indices, and slices ShapeR(..), Slice(..), SliceIndex(..), @@ -33,7 +33,7 @@ module Data.Array.Accelerate.Array.Representation ( -- * Shape functions rank, size, empty, ignore, intersect, union, toIndex, fromIndex, iter, iter1, - rangeToShape, shapeToRange, shapeToList, listToShape, listToShape', shapeType, + rangeToShape, shapeToRange, shapeToList, listToShape, listToShape', shapeType, shapeEq, -- * Slice shape functions sliceShape, sliceShapeR, sliceDomainR, enumSlices, @@ -55,6 +55,7 @@ import GHC.Base ( quotInt, remInt ) import Prelude hiding ((!!)) import Data.List ( intercalate ) import Text.Show ( showListWith ) +import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.Vector.Unboxed as U -- |Array data type, where the type arguments regard the representation types of the shape and elements. @@ -81,6 +82,34 @@ reshape shr sh shr' (Array sh' adata) (!!) :: (TupleType e, Array sh e) -> Int -> e (tp, Array _ adata) !! i = unsafeIndexArrayData tp adata i +-- | Create an array from its representation function, applied at each index of +-- the array. +-- +{-# INLINEABLE fromFunction #-} +fromFunction :: ArrayR (Array sh e) -> sh -> (sh -> e) -> Array sh e +fromFunction repr sh f = unsafePerformIO $! fromFunctionM repr sh (return . f) + +-- | Create an array using a monadic function applied at each index. +-- +-- @since 1.2.0.0 +-- +{-# INLINEABLE fromFunctionM #-} +fromFunctionM :: ArrayR (Array sh e) -> sh -> (sh -> IO e) -> IO (Array sh e) +fromFunctionM (ArrayR shr tp) sh f = do + let !n = size shr sh + arr <- newArrayData tp n + -- + let write !i + | i >= n = return () + | otherwise = do + v <- f (fromIndex shr sh i) + unsafeWriteArrayData tp arr i v + write (i+1) + -- + write 0 + return $! arr `seq` Array sh arr + + {-# INLINEABLE concatVectors #-} concatVectors :: TupleType e -> [Vector e] -> Vector e concatVectors tp vs = adata `seq` Array ((), len) adata @@ -219,6 +248,10 @@ fromIndex (ShapeRcons shr) (sh, sz) i ShapeRz -> $indexCheck "fromIndex" i sz i _ -> i `remInt` sz +shapeEq :: ShapeR sh -> sh -> sh -> Bool +shapeEq ShapeRz () () = True +shapeEq (ShapeRcons shr) (sh, i) (sh', i') = i == i' && shapeEq shr sh sh' + -- 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 diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 89c808a67..73d10f914 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -959,19 +959,11 @@ fromFunction sh f = unsafePerformIO $! fromFunctionM sh (return . f) -- {-# INLINEABLE fromFunctionM #-} fromFunctionM :: forall sh e. (Shape sh, Elt e) => sh -> (sh -> IO e) -> IO (Array sh e) -fromFunctionM sh f = do - let !n = size sh - arr <- newArrayData (eltType @e) n - -- - let write !i - | i >= n = return () - | otherwise = do - v <- f (fromIndex sh i) - unsafeWriteArrayData (eltType @e) arr i (fromElt v) - write (i+1) - -- - write 0 - return $! arr `seq` Array $ Repr.Array (fromElt sh) arr +fromFunctionM sh f = Array <$> Repr.fromFunctionM (arrayR @sh @e) (fromElt sh) f' + where + f' x = do + y <- f $ toElt x + return $ fromElt y -- | Create a vector from the concatenation of the given list of vectors. diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index 5881001fa..d74e11fb9 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -33,7 +33,7 @@ import Data.Array.Accelerate.Array.Sugar hiding ( (!) import Data.Array.Accelerate.Language hiding ( chr ) import Data.Array.Accelerate.Prelude hiding ( filter ) import Data.Array.Accelerate.Interpreter -import Data.Array.Accelerate.Product +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -80,14 +80,16 @@ isRight x = tag x == 1 -- instead. -- fromLeft :: (Elt a, Elt b) => Exp (Either a b) -> Exp a -fromLeft x = Exp $ SuccTupIdx ZeroTupIdx `Prj` x +fromLeft x = a + where T3 _ a _ = asTuple 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 +fromRight x = b + where T3 _ _ b = asTuple 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@, @@ -136,7 +138,8 @@ instance (Elt a, Elt b) => Semigroup (Exp (Either a b)) where #endif tag :: (Elt a, Elt b) => Exp (Either a b) -> Exp Word8 -tag x = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` x +tag x = t + where T3 t _ _ = asTuple x instance (Elt a, Elt b) => Elt (Either a b) where type EltRepr (Either a b) = TupleRepr (Word8, EltRepr a, EltRepr b) @@ -146,21 +149,13 @@ instance (Elt a, Elt b) => Elt (Either a b) where eltType = eltType @(Word8,a,b) toElt ((((),0),a),_) = Left (toElt a) toElt (_ ,b) = Right (toElt b) - fromElt (Left a) = ((((),0), fromElt a), fromElt (evalUndef @b)) - fromElt (Right b) = ((((),1), fromElt (evalUndef @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), evalUndef @b) - fromProd (Right b) = ((((), 1), evalUndef @a), b) - prod = prod @Elt @(Word8,a,b) + fromElt (Left a) = ((((),0), fromElt a ), evalUndef $ eltType @b) + fromElt (Right b) = ((((),1), evalUndef $ eltType @a), fromElt 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 + lift (Left a) = toEither $ T3 (constant 0) (lift a) undef + lift (Right b) = toEither $ T3 (constant 1) undef (lift b) -- Utilities @@ -200,3 +195,9 @@ filter' keep arr emptyArray :: (Shape sh, Elt e) => Acc (Array sh e) emptyArray = fill (constant empty) undef +asTuple :: Exp (Either a b) -> Exp (Word8, a, b) +asTuple (Exp e) = Exp e + +toEither :: Exp (Word8, a, b) -> Exp (Either a b) +toEither (Exp e) = Exp e + diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index f3e3901e0..ccae9274e 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -33,7 +33,6 @@ import Data.Array.Accelerate.Array.Sugar hiding ( (!) import Data.Array.Accelerate.Language hiding ( chr ) import Data.Array.Accelerate.Prelude hiding ( filter ) import Data.Array.Accelerate.Interpreter -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -48,7 +47,7 @@ import Data.Array.Accelerate.Data.Semigroup #endif import Data.Maybe ( Maybe(..) ) -import Prelude ( (.), ($), const, otherwise ) +import Prelude ( ($), const, otherwise ) -- | Lift a value into a 'Just' constructor @@ -92,7 +91,7 @@ fromMaybe d x = cond (isNothing x) d (fromJust x) -- instead. -- fromJust :: Elt a => Exp (Maybe a) -> Exp a -fromJust x = Exp $ ZeroTupIdx `Prj` x +fromJust (Exp x) = Exp $ SmartExp $ PairIdxRight `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; @@ -142,7 +141,7 @@ instance (Semigroup (Exp a), Elt a) => Semigroup (Exp (Maybe a)) where tag :: Elt a => Exp (Maybe a) -> Exp Word8 -tag x = Exp $ SuccTupIdx ZeroTupIdx `Prj` x +tag (Exp x) = Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxLeft x instance Elt a => Elt (Maybe a) where @@ -153,21 +152,17 @@ instance Elt a => Elt (Maybe a) where eltType = eltType @(Word8,a) toElt (((),0),_) = Nothing toElt (_ ,x) = Just (toElt x) - fromElt Nothing = (((),0), fromElt (evalUndef @a)) + fromElt Nothing = (((),0), evalUndef $ eltType @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), evalUndef @a) - fromProd (Just a) = (((), 1), a) - prod = prod @Elt @(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 + lift Nothing = Exp $ SmartExp $ Pair t $ unExp $ undef @(Plain a) + where + t = SmartExp $ Pair (SmartExp Nil) $ SmartExp $ Const scalarTypeWord8 0 + lift (Just x) = Exp $ SmartExp $ Pair t $ unExp $ lift x + where + t = SmartExp $ Pair (SmartExp Nil) $ SmartExp $ Const scalarTypeWord8 1 -- Utilities diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index e75d0c357..135f2c24f 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -42,15 +42,14 @@ module Data.Array.Accelerate.Interpreter ( - Smart.Acc, Arrays, + Smart.Acc, Sugar.Arrays, Afunction, AfunctionR, -- * Interpret an array expression run, run1, runN, -- Internal (hidden) - evalPrj, - evalPrim, evalPrimConst, evalUndef, evalCoerce, + evalPrim, evalPrimConst, evalUndef, evalCoerceScalar, ) where @@ -63,7 +62,6 @@ import Data.Bits import Data.Char ( chr, ord ) import Data.Primitive.ByteArray import Data.Primitive.Types -import Data.Typeable import System.IO.Unsafe ( unsafePerformIO ) import Text.Printf ( printf ) import Unsafe.Coerce @@ -71,17 +69,14 @@ import Prelude hiding ( (!! -- friends import Data.Array.Accelerate.AST hiding ( Boundary, PreBoundary(..) ) -import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Analysis.Type ( sizeOfScalarType, sizeOfSingleType ) +import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Representation +import qualified Data.Array.Accelerate.Array.Sugar as 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 Smart import qualified Data.Array.Accelerate.Trafo as AST @@ -93,7 +88,7 @@ import qualified Data.Array.Accelerate.Debug as D -- | Run a complete embedded array program using the reference interpreter. -- -run :: Arrays a => Smart.Acc a -> a +run :: Sugar.Arrays a => Smart.Acc a -> a run a = unsafePerformIO execute where !acc = convertAcc a @@ -101,11 +96,11 @@ run a = unsafePerformIO execute D.dumpGraph $!! acc D.dumpSimplStats res <- phase "execute" D.elapsed $ evaluate $ evalOpenAcc acc Empty - return $ toArr res + return $ Sugar.toArr $ snd res -- | This is 'runN' specialised to an array program of one argument. -- -run1 :: (Arrays a, Arrays b) => (Smart.Acc a -> Smart.Acc b) -> a -> b +run1 :: (Sugar.Arrays a, Sugar.Arrays b) => (Smart.Acc a -> Smart.Acc b) -> a -> b run1 = runN -- | Prepare and execute an embedded array program. @@ -121,8 +116,8 @@ runN f = go !go = eval (afunctionRepr @f) afun Empty -- eval :: AfunctionRepr g (AfunctionR g) (AreprFunctionR g) -> DelayedOpenAfun aenv (AreprFunctionR g) -> Val aenv -> AfunctionR g - eval (AfunctionReprLam reprF) (Alam lhs f) aenv = \a -> eval reprF f $ aenv `push` (lhs, fromArr a) - eval AfunctionReprBody (Abody b) aenv = unsafePerformIO $ phase "execute" D.elapsed (toArr <$> evaluate (evalOpenAcc b aenv)) + eval (AfunctionReprLam reprF) (Alam lhs f) aenv = \a -> eval reprF f $ aenv `push` (lhs, Sugar.fromArr a) + eval AfunctionReprBody (Abody b) aenv = unsafePerformIO $ phase "execute" D.elapsed (Sugar.toArr . snd <$> evaluate (evalOpenAcc b aenv)) eval _ _aenv _ = error "Two men say they're Jesus; one of them must be wrong" -- -- | Stream a lazily read list of input arrays through the given program, @@ -148,7 +143,8 @@ phase n fmt go = D.timed D.dump_phases (\wall cpu -> printf "phase %s: %s" n (fm -- not require an optional Manifest|Delayed data type to evaluate the program. -- data Delayed a where - Delayed :: sh + Delayed :: ArrayR (Array sh e) + -> sh -> (sh -> e) -> (Int -> e) -> Delayed (Array sh e) @@ -157,13 +153,18 @@ data Delayed a where -- Array expression evaluation -- --------------------------- -type EvalAcc acc = forall aenv a. acc aenv a -> Val aenv -> a +type EvalAcc acc = forall aenv a. acc aenv a -> Val aenv -> WithReprs a + +type WithReprs acc = (ArraysR acc, acc) + +fromFunction' :: ArrayR (Array sh e) -> sh -> (sh -> e) -> WithReprs (Array sh e) +fromFunction' repr sh f = (TupRsingle repr, fromFunction repr sh f) -- Evaluate an open array function -- evalOpenAfun :: DelayedOpenAfun aenv f -> Val aenv -> f evalOpenAfun (Alam lhs f) aenv = \a -> evalOpenAfun f $ aenv `push` (lhs, a) -evalOpenAfun (Abody b) aenv = evalOpenAcc b aenv +evalOpenAfun (Abody b) aenv = snd $ evalOpenAcc b aenv -- The core interpreter for optimised array programs @@ -172,19 +173,20 @@ evalOpenAcc :: forall aenv a. DelayedOpenAcc aenv a -> Val aenv - -> a + -> WithReprs a evalOpenAcc AST.Delayed{} _ = $internalError "evalOpenAcc" "expected manifest array" evalOpenAcc (AST.Manifest pacc) aenv = let - manifest :: forall a'. DelayedOpenAcc aenv a' -> a' + manifest :: forall a'. DelayedOpenAcc aenv a' -> WithReprs a' manifest acc = - let a' = evalOpenAcc acc aenv - repr = arraysRepr acc - in rnfArrays repr a' `seq` a' + let (repr, a') = evalOpenAcc acc aenv + in rnfArrays repr a' `seq` (repr, a') - delayed :: (Shape sh, Elt e) => DelayedOpenAcc aenv (Array sh e) -> Delayed (Array sh e) - delayed AST.Delayed{..} = Delayed (evalE extentD) (evalF indexD) (evalF linearIndexD) - delayed (manifest -> a) = Delayed (shape a) (a!) (a!!) + delayed :: DelayedOpenAcc aenv (Array sh e) -> Delayed (Array sh e) + delayed AST.Delayed{..} = Delayed reprD (evalE extentD) (evalF indexD) (evalF linearIndexD) + delayed a' = Delayed repr (shape a) ((repr, a) !) ((arrayRtype repr, a) !!) + where + (TupRsingle repr, a) = manifest a' evalE :: DelayedExp aenv t -> t evalE exp = evalPreExp evalOpenAcc exp aenv @@ -196,37 +198,43 @@ evalOpenAcc (AST.Manifest pacc) aenv = evalB bnd = evalPreBoundary evalOpenAcc bnd aenv in case pacc of - Avar (ArrayVar ix) -> prj ix aenv - Alet lhs acc1 acc2 -> evalOpenAcc acc2 $ aenv `push` (lhs, manifest acc1) - Apair acc1 acc2 -> (manifest acc1, manifest acc2) - Anil -> () - Apply afun acc -> evalOpenAfun afun aenv $ manifest acc - Aforeign _ afun acc -> evalOpenAfun afun Empty $ manifest acc + Avar (Var repr ix) -> (TupRsingle repr, prj ix aenv) + Alet lhs acc1 acc2 -> evalOpenAcc acc2 $ aenv `push` (lhs, snd $ manifest acc1) + Apair acc1 acc2 -> let + (r1, a1) = manifest acc1 + (r2, a2) = manifest acc2 + in + (TupRpair r1 r2, (a1, a2)) + Anil -> (TupRunit, ()) + Apply repr afun acc -> (repr, evalOpenAfun afun aenv $ snd $ manifest acc) + Aforeign (_ :: asm (a1 -> a2)) afun acc + -> (Sugar.arrays @a2, evalOpenAfun afun Empty $ snd $ manifest acc) Acond p acc1 acc2 | evalE p -> manifest acc1 | otherwise -> manifest acc2 - Awhile cond body acc -> go (manifest acc) + Awhile cond body acc -> (repr, go initial) where + (repr, initial) = manifest acc p = evalOpenAfun cond aenv f = evalOpenAfun body aenv go !x - | p x ! Z = go (f x) - | otherwise = x + | (ArrayR ShapeRz (TupRsingle scalarTypeBool), p x) ! () = go (f x) + | otherwise = x - Use arr -> arr - Unit e -> unitOp (evalE e) + Use repr arr -> (TupRsingle repr, arr) + Unit tp e -> unitOp tp (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) + Map tp f acc -> mapOp tp (evalF f) (delayed acc) + Generate repr sh f -> generateOp repr (evalE sh) (evalF f) + Transform repr sh p f acc -> transformOp repr (evalE sh) (evalF p) (evalF f) (delayed acc) + Backpermute shr sh p acc -> backpermuteOp shr (evalE sh) (evalF p) (delayed acc) + Reshape shr sh acc -> reshapeOp shr (evalE sh) (manifest acc) - ZipWith f acc1 acc2 -> zipWithOp (evalF f) (delayed acc1) (delayed acc2) + ZipWith tp f acc1 acc2 -> zipWithOp tp (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) @@ -234,8 +242,8 @@ evalOpenAcc (AST.Manifest pacc) aenv = -- --------- 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) + FoldSeg i f z acc seg -> foldSegOp i (evalF f) (evalE z) (delayed acc) (delayed seg) + Fold1Seg i f acc seg -> fold1SegOp i (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) @@ -243,55 +251,58 @@ evalOpenAcc (AST.Manifest pacc) aenv = 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) + Stencil s tp sten b acc -> stencilOp s tp (evalF sten) (evalB b) (delayed acc) + Stencil2 s1 s2 tp sten b1 a1 b2 a2 + -> stencil2Op s1 s2 tp (evalF sten) (evalB b1) (delayed a1) (evalB b2) (delayed a2) -- Array primitives -- ---------------- -unitOp :: Elt e => e -> Scalar e -unitOp e = fromFunction Z (const e) +unitOp :: TupleType e -> e -> WithReprs (Scalar e) +unitOp tp e = fromFunction' (ArrayR ShapeRz tp) () (const e) generateOp - :: (Shape sh, Elt e) - => sh + :: ArrayR (Array sh e) + -> sh -> (sh -> e) - -> Array sh e -generateOp = fromFunction + -> WithReprs (Array sh e) +generateOp = fromFunction' transformOp - :: (Shape sh', Elt b) - => sh' + :: ArrayR (Array sh' 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)) + -> WithReprs (Array sh' b) +transformOp repr sh' p f (Delayed _ _ xs _) + = fromFunction' repr sh' (\ix -> f (xs $ p ix)) reshapeOp - :: (Shape sh, Shape sh') - => 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 + :: ShapeR sh + -> sh + -> WithReprs (Array sh' e) + -> WithReprs (Array sh e) +reshapeOp newShapeR newShape (TupRsingle (ArrayR shr tp), (Array sh adata)) + = $boundsCheck "reshape" "shape mismatch" (size newShapeR newShape == size shr sh) + ( TupRsingle (ArrayR newShapeR tp) + , Array newShape adata + ) replicateOp - :: (Shape sh, Shape sl, Elt slix, Elt e) - => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) + :: SliceIndex slix sl co sh -> slix - -> Array sl e - -> Array sh e -replicateOp slice slix arr - = fromFunction (toElt sh) (\ix -> arr ! liftToElt pf ix) + -> WithReprs (Array sl e) + -> WithReprs (Array sh e) +replicateOp slice slix (TupRsingle repr@(ArrayR _ tp), arr) + = fromFunction' repr' sh (\ix -> (repr, arr) ! pf ix) where - (sh, pf) = extend slice (fromElt slix) (fromElt (shape arr)) + repr' = ArrayR (sliceDomainR slice) tp + (sh, pf) = extend slice slix (shape arr) extend :: SliceIndex slix sl co dim -> slix @@ -308,15 +319,15 @@ replicateOp slice slix arr sliceOp - :: (Shape sh, Shape sl, Elt slix, Elt e) - => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) - -> Array sh e + :: SliceIndex slix sl co sh + -> WithReprs (Array sh e) -> slix - -> Array sl e -sliceOp slice arr slix - = fromFunction (toElt sh') (\ix -> arr ! liftToElt pf ix) + -> WithReprs (Array sl e) +sliceOp slice (TupRsingle repr@(ArrayR _ tp), arr) slix + = fromFunction' repr' sh' (\ix -> (repr, arr) ! pf ix) where - (sh', pf) = restrict slice (fromElt slix) (fromElt (shape arr)) + repr' = ArrayR (sliceShapeR slice) tp + (sh', pf) = restrict slice slix (shape arr) restrict :: SliceIndex slix sl co sh -> slix @@ -332,22 +343,22 @@ sliceOp slice arr slix 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)) +mapOp :: TupleType b + -> (a -> b) + -> Delayed (Array sh a) + -> WithReprs (Array sh b) +mapOp tp f (Delayed (ArrayR shr _) sh xs _) + = fromFunction' (ArrayR shr tp) 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)) + :: TupleType c + -> (a -> b -> c) + -> Delayed (Array sh a) + -> Delayed (Array sh b) + -> WithReprs (Array sh c) +zipWithOp tp f (Delayed (ArrayR shr _) shx xs _) (Delayed _ shy ys _) + = fromFunction' (ArrayR shr tp) (intersect shr shx shy) (\ix -> f (xs ix) (ys ix)) -- zipWith'Op -- :: (Shape sh, Elt a) @@ -356,7 +367,7 @@ zipWithOp f (Delayed shx xs _) (Delayed shy ys _) -- -> 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 +-- = fromFunction' (shx `union` shy) (\ix -> if ix `outside` shx -- then ys ix -- else if ix `outside` shy -- then xs ix @@ -366,502 +377,469 @@ zipWithOp f (Delayed shx xs _) (Delayed shy ys _) foldOp - :: (Shape sh, Elt e) - => (e -> e -> 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) + -> Delayed (Array (sh, Int) e) + -> WithReprs (Array sh e) +foldOp f z (Delayed (ArrayR (ShapeRcons shr) tp) (sh, n) arr _) + = fromFunction' (ArrayR shr tp) sh (\ix -> iter (ShapeRcons ShapeRz) ((), n) (\((), 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 _) + :: (e -> e -> e) + -> Delayed (Array (sh, Int) e) + -> WithReprs (Array sh e) +fold1Op f (Delayed (ArrayR (ShapeRcons shr) tp) (sh, n) arr _) = $boundsCheck "fold1" "empty array" (n > 0) - $ fromFunction sh (\ix -> iter1 (Z:.n) (\(Z:.i) -> arr (ix :. i)) f) + $ fromFunction' (ArrayR shr tp) sh (\ix -> iter1 (ShapeRcons ShapeRz) ((), n) (\((), i) -> arr (ix, i)) f) foldSegOp - :: forall sh e i. (Shape sh, Elt e, Elt i, IsIntegral i) - => (e -> e -> e) + :: IntegralType i + -> (e -> e -> e) -> e - -> Delayed (Array (sh :. Int) e) + -> Delayed (Array (sh, Int) e) -> Delayed (Segments i) - -> Array (sh :. Int) e -foldSegOp f z (Delayed (sh :. _) arr _) (Delayed (Z :. n) _ seg) - | IntegralDict <- integralDict (integralType :: IntegralType i) + -> WithReprs (Array (sh, Int) e) +foldSegOp itp f z (Delayed repr (sh, _) arr _) (Delayed _ ((), n) _ seg) + | IntegralDict <- integralDict itp = $boundsCheck "foldSeg" "empty segment descriptor" (n > 0) - $ fromFunction (sh :. n-1) - $ \(sz :. ix) -> let start = fromIntegral $ seg ix + $ fromFunction' repr (sh, n-1) + $ \(sz, ix) -> let start = fromIntegral $ seg ix end = fromIntegral $ seg (ix+1) in $boundsCheck "foldSeg" "empty segment" (end >= start) - $ iter (Z :. end-start) (\(Z:.i) -> arr (sz :. start+i)) f z + $ iter (ShapeRcons ShapeRz) ((), end-start) (\((), i) -> arr (sz, start+i)) f z fold1SegOp - :: forall sh e i. (Shape sh, Elt e, Elt i, IsIntegral i) - => (e -> e -> e) - -> Delayed (Array (sh :. Int) e) + :: IntegralType i + -> (e -> e -> e) + -> Delayed (Array (sh, Int) e) -> Delayed (Segments i) - -> Array (sh :. Int) e -fold1SegOp f (Delayed (sh :. _) arr _) (Delayed (Z :. n) _ seg) - | IntegralDict <- integralDict (integralType :: IntegralType i) + -> WithReprs (Array (sh, Int) e) +fold1SegOp itp f (Delayed repr (sh, _) arr _) (Delayed _ ((), n) _ seg) + | IntegralDict <- integralDict itp = $boundsCheck "foldSeg" "empty segment descriptor" (n > 0) - $ fromFunction (sh :. n-1) - $ \(sz :. ix) -> let start = fromIntegral $ seg ix + $ fromFunction' repr (sh, n-1) + $ \(sz, ix) -> let start = fromIntegral $ seg ix end = fromIntegral $ seg (ix+1) in $boundsCheck "fold1Seg" "empty segment" (end > start) - $ iter1 (Z :. end-start) (\(Z:.i) -> arr (sz :. start+i)) f + $ iter1 (ShapeRcons ShapeRz) ((), end-start) (\((), i) -> arr (sz, start+i)) f scanl1Op - :: (Shape sh, Elt e) - => (e -> e -> e) - -> Delayed (Array (sh:.Int) e) - -> Array (sh:.Int) e -scanl1Op f (Delayed sh@(_ :. n) ain _) + :: (e -> e -> e) + -> Delayed (Array (sh, Int) e) + -> WithReprs (Array (sh, Int) e) +scanl1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) = $boundsCheck "scanl1" "empty array" (n > 0) - $ adata `seq` Array (fromElt sh) adata + ( TupRsingle $ ArrayR shr tp + , adata `seq` Array sh adata + ) where - f' = sinkFromElt2 f -- (adata, _) = runArrayData $ do - aout <- newArrayData (size sh) + aout <- newArrayData tp (size shr 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) + let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh (sz, 0)) (ain (sz, 0)) + write (sz, i) = do + x <- unsafeReadArrayData tp aout (toIndex shr sh (sz, i-1)) + let y = ain (sz, i) + unsafeWriteArrayData tp aout (toIndex shr sh (sz, i)) (f x y) - iter sh write (>>) (return ()) + iter shr sh write (>>) (return ()) return (aout, undefined) scanlOp - :: (Shape sh, Elt e) - => (e -> e -> 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 + -> Delayed (Array (sh, Int) e) + -> WithReprs (Array (sh, Int) e) +scanlOp f z (Delayed (ArrayR shr tp) (sh, n) ain _) + = ( TupRsingle $ ArrayR shr tp + , adata `seq` Array sh' adata + ) where - sh' = sh :. n+1 - f' = sinkFromElt2 f + sh' = (sh, n+1) -- (adata, _) = runArrayData $ do - aout <- newArrayData (size sh') + aout <- newArrayData tp (size shr 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) + let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh' (sz, 0)) z + write (sz, i) = do + x <- unsafeReadArrayData tp aout (toIndex shr sh' (sz, i-1)) + let y = ain (sz, i-1) + unsafeWriteArrayData tp aout (toIndex shr sh' (sz, i)) (f x y) - iter sh' write (>>) (return ()) + iter shr sh' write (>>) (return ()) return (aout, undefined) scanl'Op - :: (Shape sh, Elt e) - => (e -> e -> e) + :: (e -> e -> e) -> e - -> Delayed (Array (sh:.Int) e) - -> ArrRepr (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 ) + -> Delayed (Array (sh, Int) e) + -> WithReprs (((), Array (sh, Int) e), Array sh e) +scanl'Op f z (Delayed (ArrayR shr@(ShapeRcons shr') tp) (sh, n) ain _) + = ( TupRunit `TupRpair` TupRsingle (ArrayR shr tp) `TupRpair` TupRsingle (ArrayR shr' tp) + , aout `seq` asum `seq` ( ( (), Array (sh, n) aout ) + , Array 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)) + ((aout, asum), _) = runArrayData $ do + aout <- newArrayData tp (size shr (sh, n)) + asum <- newArrayData tp (size shr' sh) + + let write (sz, 0) + | n == 0 = unsafeWriteArrayData tp asum (toIndex shr' sh sz) z + | otherwise = unsafeWriteArrayData tp aout (toIndex shr (sh, n) (sz, 0)) z + write (sz, i) = do + x <- unsafeReadArrayData tp aout (toIndex shr (sh, n) (sz, i-1)) + let y = 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) + then unsafeWriteArrayData tp asum (toIndex shr' sh sz) (f x y) + else unsafeWriteArrayData tp aout (toIndex shr (sh, n) (sz, i)) (f x y) - iter (sh:.n+1) write (>>) (return ()) - return (AD_Pair aout asum, undefined) + iter shr (sh, n+1) write (>>) (return ()) + return ((aout, asum), undefined) scanrOp - :: (Shape sh, Elt e) - => (e -> e -> 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 + -> Delayed (Array (sh, Int) e) + -> WithReprs (Array (sh, Int) e) +scanrOp f z (Delayed (ArrayR shr tp) (sz, n) ain _) + = ( TupRsingle (ArrayR shr tp) + , adata `seq` Array sh' adata + ) where - sh' = sz :. n+1 - f' = sinkFromElt2 f + sh' = (sz, n+1) -- (adata, _) = runArrayData $ do - aout <- newArrayData (size sh') + aout <- newArrayData tp (size shr 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) + let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh' (sz, n)) z + write (sz, i) = do + let x = ain (sz, n-i) + y <- unsafeReadArrayData tp aout (toIndex shr sh' (sz, n-i+1)) + unsafeWriteArrayData tp aout (toIndex shr sh' (sz, n-i)) (f x y) - iter sh' write (>>) (return ()) + iter shr 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 _) + :: (e -> e -> e) + -> Delayed (Array (sh, Int) e) + -> WithReprs (Array (sh, Int) e) +scanr1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) = $boundsCheck "scanr1" "empty array" (n > 0) - $ adata `seq` Array (fromElt sh) adata + ( TupRsingle $ ArrayR shr tp + , adata `seq` Array sh adata + ) where - f' = sinkFromElt2 f - -- (adata, _) = runArrayData $ do - aout <- newArrayData (size sh) + aout <- newArrayData tp (size shr 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) + let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh (sz, n-1)) (ain (sz, n-1)) + write (sz, i) = do + let x = ain (sz, n-i-1) + y <- unsafeReadArrayData tp aout (toIndex shr sh (sz, n-i)) + unsafeWriteArrayData tp aout (toIndex shr sh (sz, n-i-1)) (f x y) - iter sh write (>>) (return ()) + iter shr sh write (>>) (return ()) return (aout, undefined) scanr'Op - :: forall sh e. (Shape sh, Elt e) - => (e -> e -> e) + :: (e -> e -> e) -> e - -> Delayed (Array (sh:.Int) e) - -> ArrRepr (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 ) + -> Delayed (Array (sh, Int) e) + -> WithReprs (((), Array (sh, Int) e), Array sh e) +scanr'Op f z (Delayed (ArrayR shr@(ShapeRcons shr') tp) (sh, n) ain _) + = ( TupRunit `TupRpair` TupRsingle (ArrayR shr tp) `TupRpair` TupRsingle (ArrayR shr' tp) + , aout `seq` asum `seq` ( ((), Array (sh, n) aout ) + , Array sh asum ) + ) where - f' = sinkFromElt2 f - -- - (AD_Pair aout asum, _) = runArrayData $ do - aout <- newArrayData (size (sh:.n)) - asum <- newArrayData (size sh) + ((aout, asum), _) = runArrayData $ do + aout <- newArrayData tp (size shr (sh, n)) + asum <- newArrayData tp (size shr' 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) + let write (sz, 0) + | n == 0 = unsafeWriteArrayData tp asum (toIndex shr' sh sz) z + | otherwise = unsafeWriteArrayData tp aout (toIndex shr (sh, n) (sz, n-1)) z - write (sz:.i) = do - x <- return $ fromElt (ain (sz:.n-i)) - y <- unsafeReadArrayData aout (toIndex (sh:.n) (sz:.n-i)) + write (sz, i) = do + let x = ain (sz, n-i) + y <- unsafeReadArrayData tp aout (toIndex shr (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) + then unsafeWriteArrayData tp asum (toIndex shr' sh sz) (f x y) + else unsafeWriteArrayData tp aout (toIndex shr (sh, n) (sz, n-i-1)) (f x y) - iter (sh:.n+1) write (>>) (return ()) - return (AD_Pair aout asum, undefined) + iter shr (sh, n+1) write (>>) (return ()) + return ((aout, asum), undefined) permuteOp - :: (Shape sh, Shape sh', Elt e) - => (e -> e -> e) - -> Array sh' e + :: (e -> e -> e) + -> WithReprs (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 + -> WithReprs (Array sh' e) +permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR shr tp) sh _ ain) + = (TupRsingle $ ArrayR shr' tp, adata `seq` Array sh' adata) where sh' = shape def - n' = size sh' - f' = sinkFromElt2 f + n' = size shr' sh' + + ignore' :: ShapeR sh -> sh + ignore' ShapeRz = () + ignore' (ShapeRcons shr) = (ignore' shr, 0) + + ignore = ignore' shr' -- (adata, _) = runArrayData $ do - aout <- newArrayData n' + aout <- newArrayData tp n' let -- initialise array with default values init i | i >= n' = return () | otherwise = do - x <- unsafeReadArrayData adef i - unsafeWriteArrayData aout i x + x <- unsafeReadArrayData tp adef i + unsafeWriteArrayData tp 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 + i = toIndex shr sh src + j = toIndex shr' sh' dst in - unless (fromElt dst == R.ignore) $ do - x <- return . fromElt $ ain i - y <- unsafeReadArrayData aout j - unsafeWriteArrayData aout j (f' x y) + unless (shapeEq shr' dst ignore) $ do + let x = ain i + y <- unsafeReadArrayData tp aout j + unsafeWriteArrayData tp aout j (f x y) init 0 - iter sh update (>>) (return ()) + iter shr sh update (>>) (return ()) return (aout, undefined) backpermuteOp - :: (Shape sh', Elt e) - => sh' + :: ShapeR sh' + -> sh' -> (sh' -> sh) -> Delayed (Array sh e) - -> Array sh' e -backpermuteOp sh' p (Delayed _ arr _) - = fromFunction sh' (\ix -> arr $ p ix) + -> WithReprs (Array sh' e) +backpermuteOp shr sh' p (Delayed (ArrayR _ tp) _ arr _) + = fromFunction' (ArrayR shr tp) sh' (\ix -> arr $ p ix) stencilOp - :: (Stencil sh a stencil, Elt b) - => (stencil -> b) + :: StencilR sh a stencil + -> TupleType 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) + -> WithReprs (Array sh b) +stencilOp stencil tp f bnd arr@(Delayed _ sh _ _) + = fromFunction' (ArrayR shr tp) sh + $ f . stencilAccess stencil (bounded shr bnd arr) + where + shr = stencilShape stencil stencil2Op - :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c) - => (stencil1 -> stencil2 -> c) + :: StencilR sh a stencil1 + -> StencilR sh b stencil2 + -> TupleType 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 + -> WithReprs (Array sh c) +stencil2Op s1 s2 tp stencil bnd1 arr1@(Delayed _ sh1 _ _) bnd2 arr2@(Delayed _ sh2 _ _) + = fromFunction' (ArrayR shr tp) (intersect shr sh1 sh2) f where - f ix = stencil (stencilAccess (bounded bnd1 arr1) ix) - (stencilAccess (bounded bnd2 arr2) ix) + f ix = stencil (stencilAccess s1 (bounded shr bnd1 arr1) ix) + (stencilAccess s2 (bounded shr bnd2 arr2) ix) + shr = stencilShape s1 stencilAccess - :: Stencil sh e stencil - => (sh -> e) + :: StencilR sh e stencil + -> (sh -> e) -> sh -> stencil -stencilAccess = goR stencil +stencilAccess stencil = goR (stencilShape stencil) 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 = + goR :: ShapeR sh -> StencilR sh e stencil -> (sh -> e) -> sh -> stencil + goR _ (StencilRunit3 _) rf ix = let - z :. i = ix - rf' d = rf (z :. i+d) + (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) + ((( () + , 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) + ((((( () + , 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) + ((((((( () + , 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 - ) + ((((((((( () + , 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) + goR (ShapeRcons shr) (StencilRtup3 s1 s2 s3) rf ix = + let (i, ix') = uncons shr ix + rf' d ds = rf (cons shr (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) + ((( () + , goR shr s1 (rf' (-1)) ix') + , goR shr s2 (rf' 0) ix') + , goR shr s3 (rf' 1) ix') + + goR (ShapeRcons shr) (StencilRtup5 s1 s2 s3 s4 s5) rf ix = + let (i, ix') = uncons shr ix + rf' d ds = rf (cons shr (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) + ((((( () + , goR shr s1 (rf' (-2)) ix') + , goR shr s2 (rf' (-1)) ix') + , goR shr s3 (rf' 0) ix') + , goR shr s4 (rf' 1) ix') + , goR shr s5 (rf' 2) ix') + + goR (ShapeRcons shr) (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) rf ix = + let (i, ix') = uncons shr ix + rf' d ds = rf (cons shr (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) + ((((((( () + , goR shr s1 (rf' (-3)) ix') + , goR shr s2 (rf' (-2)) ix') + , goR shr s3 (rf' (-1)) ix') + , goR shr s4 (rf' 0) ix') + , goR shr s5 (rf' 1) ix') + , goR shr s6 (rf' 2) ix') + , goR shr s7 (rf' 3) ix') + + goR (ShapeRcons shr) (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) rf ix = + let (i, ix') = uncons shr ix + rf' d ds = rf (cons shr (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' - ) + ((((((((( () + , goR shr s1 (rf' (-4)) ix') + , goR shr s2 (rf' (-3)) ix') + , goR shr s3 (rf' (-2)) ix') + , goR shr s4 (rf' (-1)) ix') + , goR shr s5 (rf' 0) ix') + , goR shr s6 (rf' 1) ix') + , goR shr s7 (rf' 2) ix') + , goR shr s8 (rf' 3) ix') + , goR shr 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 @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" + cons :: ShapeR sh -> Int -> sh -> (sh, Int) + cons ShapeRz ix () = ((), ix) + cons (ShapeRcons shr) ix (sh, sz) = (cons shr ix sh, sz) -- 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 @(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" + uncons :: ShapeR sh -> (sh, Int) -> (Int, sh) + uncons ShapeRz ((), v) = (v, ()) + uncons (ShapeRcons shr) (v1, v2) = let (i, v1') = uncons shr v1 + in (i, (v1', v2)) bounded - :: (Shape sh, Elt e) - => Boundary (Array sh e) + :: ShapeR sh + -> Boundary (Array sh e) -> Delayed (Array sh e) -> sh -> e -bounded bnd (Delayed sh f _) ix = - if inside sh ix +bounded shr bnd (Delayed _ sh f _) ix = + if inside shr sh ix then f ix else case bnd of Function g -> g ix - Constant v -> toElt v - _ -> f (bound sh ix) + Constant v -> v + _ -> f (bound shr 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 @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" + inside :: ShapeR sh -> sh -> sh -> Bool + inside ShapeRz () () = True + inside (ShapeRcons shr) (sh, sz) (ih, iz) = iz >= 0 && iz < sz && inside shr sh ih -- 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 @sh) (fromElt sh1) (fromElt ix1) + bound :: ShapeR sh -> sh -> sh -> sh + bound ShapeRz () () = () + bound (ShapeRcons shr) (sh, sz) (ih, iz) = (bound shr sh ih, ih') 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" - + ih' + | 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 -- toSeqOp :: forall slix sl dim co e proxy. (Elt slix, Shape sl, Shape dim, Elt e) -- => SliceIndex (EltRepr slix) @@ -882,11 +860,11 @@ 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) + Constant :: t -> Boundary (Array sh t) + Function :: (sh -> e) -> Boundary (Array sh e) -evalPreBoundary :: EvalAcc acc -> AST.PreBoundary acc aenv t -> Val aenv -> Boundary t +evalPreBoundary :: HasArraysRepr acc => EvalAcc acc -> AST.PreBoundary acc aenv t -> Val aenv -> Boundary t evalPreBoundary evalAcc bnd aenv = case bnd of AST.Clamp -> Clamp @@ -901,20 +879,20 @@ evalPreBoundary evalAcc bnd aenv = -- Evaluate a closed scalar expression -- -evalPreExp :: EvalAcc acc -> PreExp acc aenv t -> Val aenv -> t -evalPreExp evalAcc e aenv = evalPreOpenExp evalAcc e EmptyElt aenv +evalPreExp :: HasArraysRepr acc => EvalAcc acc -> PreExp acc aenv t -> Val aenv -> t +evalPreExp evalAcc e aenv = evalPreOpenExp evalAcc e Empty 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 +evalPreFun :: HasArraysRepr acc => EvalAcc acc -> PreFun acc aenv t -> Val aenv -> t +evalPreFun evalAcc f aenv = evalPreOpenFun evalAcc f Empty 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 +evalPreOpenFun :: HasArraysRepr acc => EvalAcc acc -> PreOpenFun acc env aenv t -> Val env -> Val aenv -> t +evalPreOpenFun evalAcc (Body e) env aenv = evalPreOpenExp evalAcc e env aenv +evalPreOpenFun evalAcc (Lam lhs f) env aenv = + \x -> evalPreOpenFun evalAcc f (env `push` (lhs, x)) aenv -- Evaluate an open scalar expression @@ -925,11 +903,16 @@ evalPreOpenFun evalAcc (Lam f) env aenv = -- mapped over an array, the array argument would be evaluated many times -- leading to a large amount of wasteful recomputation. -- +-- TODO: If we change the argument of Shape, Index and LinearIndex to be an array +-- variable (instead of an arbitrary array computation), we could remove the +-- HasArraysRepr constraint and just pattern match on the Var. +-- evalPreOpenExp :: forall acc env aenv t. - EvalAcc acc + HasArraysRepr acc + => EvalAcc acc -> PreOpenExp acc env aenv t - -> ValElt env + -> Val env -> Val aenv -> t evalPreOpenExp evalAcc pexp env aenv = @@ -940,27 +923,24 @@ evalPreOpenExp evalAcc pexp env aenv = evalF :: PreOpenFun acc env aenv f' -> f' evalF f = evalPreOpenFun evalAcc f env aenv - evalA :: acc aenv a -> a + evalA :: acc aenv a -> WithReprs a evalA a = evalAcc a aenv in case pexp of - Let exp1 exp2 -> let !v1 = evalE exp1 - env' = env `PushElt` fromElt v1 + Let lhs exp1 exp2 -> let !v1 = evalE exp1 + env' = env `push` (lhs, v1) in evalPreOpenExp evalAcc exp2 env' aenv - Var ix -> prjElt ix env - Const c -> toElt c - Undef -> evalUndef + Evar (Var _ ix) -> prj ix env + Const _ c -> c + Undef tp -> evalUndefScalar tp 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)) + Nil -> () + Pair e1 e2 -> let !v1 = evalE e1 + !v2 = evalE e2 + in (v1, v2) + IndexSlice slice slix sh -> restrict slice (evalE slix) + (evalE sh) where restrict :: SliceIndex slix sl co sh -> slix -> sh -> sl restrict SliceNil () () = () @@ -970,8 +950,8 @@ evalPreOpenExp evalAcc pexp env aenv = restrict (SliceFixed sliceIdx) (slx, _i) (sl, _sz) = restrict sliceIdx slx sl - IndexFull slice slix sh -> toElt $ extend slice (fromElt (evalE slix)) - (fromElt (evalE sh)) + IndexFull slice slix sh -> extend slice (evalE slix) + (evalE sh) where extend :: SliceIndex slix sl co sh -> slix -> sl -> sh extend SliceNil () () = () @@ -982,8 +962,8 @@ evalPreOpenExp evalAcc pexp env aenv = 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) + ToIndex shr sh ix -> toIndex shr (evalE sh) (evalE ix) + FromIndex shr sh ix -> fromIndex shr (evalE sh) (evalE ix) Cond c t e | evalE c -> evalE t | otherwise -> evalE e @@ -996,29 +976,28 @@ evalPreOpenExp evalAcc pexp env aenv = | 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) + Index acc ix -> let (TupRsingle repr, a) = evalA acc + in (repr, a) ! evalE ix + LinearIndex acc i -> let (TupRsingle repr, a) = evalA acc + ix = fromIndex (arrayRshape repr) (shape a) (evalE i) + in (repr, a) ! ix + Shape acc -> shape $ snd $ evalA acc + ShapeSize shr sh -> size shr (evalE sh) + Foreign _ f e -> evalPreOpenFun evalAcc f Empty Empty $ evalE e + Coerce t1 t2 e -> evalCoerceScalar t1 t2 (evalE e) -- Constant values -- --------------- -evalUndef :: forall a. Elt a => a -evalUndef = toElt (undef (eltType @a)) - where - undef :: TupleType t -> t - undef TypeRunit = () - undef (TypeRpair a b) = (undef a, undef b) - undef (TypeRscalar t) = scalar t +evalUndef :: TupleType a -> a +evalUndef TupRunit = () +evalUndef (TupRsingle tp) = evalUndefScalar tp +evalUndef (TupRpair t1 t2) = (evalUndef t1, evalUndef t2) +evalUndefScalar :: ScalarType a -> a +evalUndefScalar = scalar + where scalar :: ScalarType t -> t scalar (SingleScalarType t) = single t scalar (VectorScalarType t) = vector t @@ -1048,28 +1027,6 @@ evalUndef = toElt (undef (eltType @a)) -- Coercions -- --------- -evalCoerce :: forall a b. (Elt a, Elt b) => a -> b -evalCoerce = toElt . go (eltType @a) (eltType @b) . fromElt - where - go :: TupleType s -> TupleType t -> s -> t - go TypeRunit TypeRunit () = () - go (TypeRpair s1 s2) (TypeRpair t1 t2) (x,y) = (go s1 t1 x, go s2 t2 y) - go (TypeRscalar s) (TypeRscalar t) x - = $internalCheck "evalCoerce" "sizes not equal" (sizeOfScalarType s == sizeOfScalarType t) - $ evalCoerceScalar s t x - -- - -- newtype wrappers are typically declared similarly to `EltRepr (T a) = ((), EltRepr a)' - -- so add some special cases for dealing with redundant parentheses. - -- - 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))) - - -- Coercion between two scalar types. We require that the size of the source and -- destination values are equal (this is not checked at this point). -- @@ -1236,22 +1193,6 @@ 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 -- ----------------------------------- diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index fc549c4c0..82ffffbb5 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -158,7 +158,7 @@ extractOpenAcc (OpenAcc pacc) = pacc prettyDelayedOpenAcc :: PrettyAcc DelayedOpenAcc prettyDelayedOpenAcc context aenv (Manifest pacc) = prettyPreOpenAcc context prettyDelayedOpenAcc extractDelayedOpenAcc aenv pacc -prettyDelayedOpenAcc _ aenv (Delayed sh f _) +prettyDelayedOpenAcc _ aenv (Delayed _ sh f _) = parens $ nest shiftwidth $ sep [ delayed "delayed" diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 565b4b33a..282377d13 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -211,7 +211,7 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = deps = (vt, Just "T") : (ve, Just "F") : map (,port) vs return $ PNode ident doc deps - Apply afun acc -> apply <$> prettyDelayedAfun detail aenv afun + Apply _ afun acc -> apply <$> prettyDelayedAfun detail aenv afun <*> prettyDelayedOpenAcc detail ctx aenv acc Awhile p f x -> do @@ -229,7 +229,7 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = Anil -> "()" .$ [] Use repr arr -> "use" .$ [ return $ PDoc (prettyArray repr arr) [] ] - Unit e -> "unit" .$ [ ppE e ] + Unit _ e -> "unit" .$ [ ppE e ] Generate _ sh f -> "generate" .$ [ ppE sh, ppF f ] Transform _ sh ix f xs -> "transform" .$ [ ppE sh, ppF ix, ppF f, ppA xs ] Reshape _ sh xs -> "reshape" .$ [ ppE sh, ppA xs ] diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 3390e94cb..f5476ef5c 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -130,7 +130,7 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = Alet{} -> prettyAlet ctx prettyAcc extractAcc aenv pacc Apair{} -> prettyAtuple prettyAcc extractAcc aenv pacc Anil -> "()" - Apply f a -> apply + Apply _ f a -> apply where op = Operator ">->" Infix L 1 apply = sep [ ppAF f, group (sep [opName op, ppA a]) ] @@ -151,7 +151,7 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = Aforeign ff _f a -> "aforeign" .$ [ pretty (strForeign ff), ppA a ] Awhile p f a -> "awhile" .$ [ ppAF p, ppAF f, ppA a ] Use repr arr -> "use" .$ [ prettyArray repr arr ] - Unit e -> "unit" .$ [ ppE e ] + Unit _ e -> "unit" .$ [ ppE e ] Reshape _ sh a -> "reshape" .$ [ ppE sh, ppA a ] Generate _ sh f -> "generate" .$ [ ppE sh, ppF f ] Transform _ sh p f a -> "transform" .$ [ ppE sh, ppF p, ppF f, ppA a ] diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 579c75fe0..5e38edf22 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -57,11 +57,11 @@ import Control.DeepSeq import Data.Typeable import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Array.Sugar ( Arrays, Elt, ArrRepr ) +import Data.Array.Accelerate.Array.Sugar ( ArrRepr, EltRepr ) import Data.Array.Accelerate.Trafo.Base ( Match(..), matchDelayedOpenAcc, encodeDelayedOpenAcc ) import Data.Array.Accelerate.Trafo.Config import Data.Array.Accelerate.Trafo.Fusion ( DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun, DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun ) -import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr ) +import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr, EltReprFunctionR ) import Data.Array.Accelerate.Trafo.Substitution import qualified Data.Array.Accelerate.AST as AST import qualified Data.Array.Accelerate.Trafo.Fusion as Fusion @@ -83,15 +83,14 @@ import Data.Array.Accelerate.Debug.Timed -- | Convert a closed array expression to de Bruijn form while also -- incorporating sharing observation and array fusion. -- -convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc (ArrRepr arrs) +convertAcc :: Acc arrs -> DelayedAcc (ArrRepr arrs) convertAcc = convertAccWith defaultOptions -convertAccWith :: Arrays arrs => Config -> Acc arrs -> DelayedAcc (ArrRepr arrs) -convertAccWith config acc +convertAccWith :: Config -> Acc arrs -> DelayedAcc (ArrRepr arrs) +convertAccWith config = phase "array-fusion" (Fusion.convertAccWith config) -- phase "vectorise-sequences" Vectorise.vectoriseSeqAcc `when` vectoriseSequences - $ phase "sharing-recovery" (Sharing.convertAccWith config) - $ acc + . phase "sharing-recovery" (Sharing.convertAccWith config) -- | Convert a unary function over array computations, incorporating sharing @@ -101,17 +100,16 @@ convertAfun :: Afunction f => f -> DelayedAfun (AreprFunctionR f) convertAfun = convertAfunWith defaultOptions convertAfunWith :: Afunction f => Config -> f -> DelayedAfun (AreprFunctionR f) -convertAfunWith config acc +convertAfunWith config = phase "array-fusion" (Fusion.convertAfunWith config) -- phase "vectorise-sequences" Vectorise.vectoriseSeqAfun `when` vectoriseSequences - $ phase "sharing-recovery" (Sharing.convertAfunWith config) - $ acc + . phase "sharing-recovery" (Sharing.convertAfunWith config) -- | Convert a closed scalar expression, incorporating sharing observation and -- optimisation. -- -convertExp :: Elt e => Exp e -> AST.Exp () e +convertExp :: Exp e -> AST.Exp () (EltRepr e) convertExp = phase "exp-simplify" Rewrite.simplify -- XXX: only if simplification is enabled . phase "sharing-recovery" Sharing.convertExp @@ -120,7 +118,7 @@ convertExp -- | Convert closed scalar functions, incorporating sharing observation and -- optimisation. -- -convertFun :: Function f => f -> AST.Fun () (FunctionR f) +convertFun :: Function f => f -> AST.Fun () (EltReprFunctionR f) convertFun = phase "exp-simplify" Rewrite.simplify . phase "sharing-recovery" Sharing.convertFun diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index 80d19fe6e..27e083da5 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -45,7 +45,7 @@ module Data.Array.Accelerate.Trafo.Base ( -- Environments Gamma(..), incExp, prjExp, pushExp, Extend(..), pushArrayEnv, append, bind, - Sink(..), sink, sink1, + Sink(..), sinkA, sink1, PreOpenExp', bindExps, -- Adding new variables to the environment @@ -53,6 +53,9 @@ module Data.Array.Accelerate.Trafo.Base ( -- Checks isIdentity, isIdentityIndexing, + + -- Utilities + mkIntersect, mkUnion, ) where -- standard library @@ -384,7 +387,7 @@ sinkGamma -> 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) +sinkGamma ext (PushExp env e) = PushExp (sinkGamma ext env) (sinkA ext e) --} -- As part of various transformations we often need to lift out array valued @@ -425,9 +428,8 @@ bind (PushEnv g lhs a) = bind g . Alet lhs a . inject -- bindings have come into scope according to the witness and no old things have -- vanished. -- --- Rename to sinkA -sink :: Sink f => Extend s acc env env' -> f env t -> f env' t -sink env = weaken (sinkWeaken env) -- TODO: Fix Stats sink vs sink1 +sinkA :: Sink f => Extend s acc env env' -> f env t -> f env' t +sinkA env = weaken (sinkWeaken env) -- TODO: Fix Stats sinkA vs sink1 sinkWeaken :: Extend s acc env env' -> env :> env' sinkWeaken BaseEnv = Stats.substitution "sink" weakenId @@ -436,7 +438,7 @@ sinkWeaken (PushEnv e (LeftHandSideSingle _) _) = weakenSucc' $ sinkWeaken e sinkWeaken (PushEnv e (LeftHandSidePair l1 l2) _) = sinkWeaken (PushEnv (PushEnv e l1 undefined) l2 undefined) sink1 :: Sink f => Extend s acc env env' -> f (env,t') t -> f (env',t') t -sink1 env = weaken $ shift $ sinkWeaken env +sink1 env = weaken $ sink $ sinkWeaken env -- Wrapper around PreOpenExp, with the order of type arguments env and aenv flipped newtype PreOpenExp' acc aenv env e = PreOpenExp' (PreOpenExp acc env aenv e) @@ -447,3 +449,41 @@ bindExps :: Kit acc -> PreOpenExp acc env aenv e bindExps BaseEnv = id bindExps (PushEnv g lhs (PreOpenExp' b)) = bindExps g . Let lhs b + + +-- Utilities for working with shapes +mkShapeBinary :: (HasArraysRepr acc, RebuildableAcc acc) + => (forall env'. PreOpenExp acc env' aenv Int -> PreOpenExp acc env' aenv Int -> PreOpenExp acc env' aenv Int) + -> ShapeR sh + -> PreOpenExp acc env aenv sh + -> PreOpenExp acc env aenv sh + -> PreOpenExp acc env aenv sh +mkShapeBinary _ ShapeRz _ _ = Nil +mkShapeBinary f (ShapeRcons shr) (Pair as a) (Pair bs b) = mkShapeBinary f shr as bs `Pair` f a b +mkShapeBinary f shr (Let lhs bnd a) b = Let lhs bnd $ mkShapeBinary f shr a (weakenE (weakenWithLHS lhs) b) +mkShapeBinary f shr a (Let lhs bnd b) = Let lhs bnd $ mkShapeBinary f shr (weakenE (weakenWithLHS lhs) a) b +mkShapeBinary f shr a b@Pair{} -- `a` is not Pair + | DeclareVars lhs k value <- declareVars $ shapeType shr + = Let lhs a $ mkShapeBinary f shr (evars $ value weakenId) (weakenE k b) +mkShapeBinary f shr a b -- `b` is not a Pair + | DeclareVars lhs k value <- declareVars $ shapeType shr + = Let lhs b $ mkShapeBinary f shr (weakenE k a) (evars $ value weakenId) + +mkIntersect :: (HasArraysRepr acc, RebuildableAcc acc) + => ShapeR sh + -> PreOpenExp acc env aenv sh + -> PreOpenExp acc env aenv sh + -> PreOpenExp acc env aenv sh +mkIntersect = mkShapeBinary f + where + f a b = PrimApp (PrimMin singleType) $ Pair a b + +mkUnion :: (HasArraysRepr acc, RebuildableAcc acc) + => ShapeR sh + -> PreOpenExp acc env aenv sh + -> PreOpenExp acc env aenv sh + -> PreOpenExp acc env aenv sh +mkUnion = mkShapeBinary f + where + f a b = PrimApp (PrimMax singleType) $ Pair a b + diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 38a0d7404..cfda2b8fd 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -58,9 +58,8 @@ import Data.Array.Accelerate.Trafo.Config 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, ArraysR(..), arraysRtuple2 - , Elt, EltRepr, Shape, Tuple(..), eltType ) +import Data.Array.Accelerate.Array.Representation hiding (fromIndex, toIndex, shape) +import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Type import Data.Array.Accelerate.Debug.Flags ( array_fusion ) @@ -129,16 +128,16 @@ convertOpenAcc config = manifest config . computeAcc . embedOpenAcc config -- 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) => Config -> OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e) +delayed :: Config -> OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e) delayed config (embedOpenAcc config -> Embed env cc) | BaseEnv <- env = case simplify cc of Done v -> avarsIn v - Yield (cvtE -> sh) (cvtF -> f) -> Delayed sh f (f `compose` fromIndex sh) - Step (cvtE -> sh) (cvtF -> p) (cvtF -> f) v + Yield repr (cvtE -> sh) (cvtF -> f) -> Delayed repr sh f (f `compose` fromIndex (arrayRshape repr) sh) + Step repr (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) + , Just Refl <- isIdentity p -> Delayed repr sh (f `compose` indexArray v) (f `compose` linearIndex v) + | f' <- f `compose` indexArray v `compose` p -> Delayed repr sh f' (f' `compose` fromIndex (arrayRshape repr) sh) -- | otherwise = manifest config (computeAcc (Embed env cc)) @@ -147,8 +146,8 @@ delayed config (embedOpenAcc config -> Embed env cc) cvtE = convertOpenExp config cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f - cvtF (Lam f) = Lam (cvtF f) - cvtF (Body b) = Body (cvtE b) + cvtF (Lam lhs f) = Lam lhs (cvtF f) + cvtF (Body b) = Body (cvtE b) -- Convert array programs as manifest terms. @@ -161,14 +160,14 @@ manifest config (OpenAcc pacc) = -- Non-fusible terms -- ----------------- Avar ix -> Avar ix - Use arr -> Use arr - Unit e -> Unit (cvtE e) + Use repr arr -> Use repr arr + Unit tp e -> Unit tp (cvtE e) Alet lhs bnd body -> alet lhs (manifest config bnd) (manifest config body) Acond p t e -> Acond (cvtE p) (manifest config t) (manifest config e) Awhile p f a -> Awhile (cvtAF p) (cvtAF f) (manifest config a) Apair a1 a2 -> Apair (manifest config a1) (manifest config a2) Anil -> Anil - Apply f a -> apply (cvtAF f) (manifest config a) + Apply repr f a -> apply repr (cvtAF f) (manifest config a) Aforeign ff f a -> Aforeign ff (cvtAF f) (manifest config a) -- Producers @@ -179,11 +178,11 @@ manifest config (OpenAcc pacc) = -- of a let-binding to be used multiple times. The input array here -- should be a evaluated array term, else something went wrong. -- - Map f a -> Map (cvtF f) (delayed config a) - Generate sh f -> Generate (cvtE sh) (cvtF f) - Transform sh p f a -> Transform (cvtE sh) (cvtF p) (cvtF f) (delayed config a) - Backpermute sh p a -> Backpermute (cvtE sh) (cvtF p) (delayed config a) - Reshape sl a -> Reshape (cvtE sl) (manifest config a) + Map tp f a -> Map tp (cvtF f) (delayed config a) + Generate repr sh f -> Generate repr (cvtE sh) (cvtF f) + Transform repr sh p f a -> Transform repr (cvtE sh) (cvtF p) (cvtF f) (delayed config a) + Backpermute shr sh p a -> Backpermute shr (cvtE sh) (cvtF p) (delayed config a) + Reshape slr sl a -> Reshape slr (cvtE sl) (manifest config a) Replicate{} -> fusionError Slice{} -> fusionError @@ -198,8 +197,8 @@ manifest config (OpenAcc pacc) = -- Fold f z a -> Fold (cvtF f) (cvtE z) (delayed config a) Fold1 f a -> Fold1 (cvtF f) (delayed config a) - FoldSeg f z a s -> FoldSeg (cvtF f) (cvtE z) (delayed config a) (delayed config s) - Fold1Seg f a s -> Fold1Seg (cvtF f) (delayed config a) (delayed config s) + FoldSeg i f z a s -> FoldSeg i (cvtF f) (cvtE z) (delayed config a) (delayed config s) + Fold1Seg i f a s -> Fold1Seg i (cvtF f) (delayed config a) (delayed config s) Scanl f z a -> Scanl (cvtF f) (cvtE z) (delayed config a) Scanl1 f a -> Scanl1 (cvtF f) (delayed config a) Scanl' f z a -> Scanl' (cvtF f) (cvtE z) (delayed config a) @@ -207,20 +206,22 @@ manifest config (OpenAcc pacc) = Scanr1 f a -> Scanr1 (cvtF f) (delayed config a) Scanr' f z a -> Scanr' (cvtF f) (cvtE z) (delayed config a) Permute f d p a -> Permute (cvtF f) (manifest config d) (cvtF p) (delayed config a) - Stencil f x a -> Stencil (cvtF f) (cvtB x) (delayed config a) - Stencil2 f x a y b -> Stencil2 (cvtF f) (cvtB x) (delayed config a) (cvtB y) (delayed config b) + Stencil s tp f x a -> Stencil s tp (cvtF f) (cvtB x) (delayed config a) + Stencil2 s1 s2 tp f x a y b + -> Stencil2 s1 s2 tp (cvtF f) (cvtB x) (delayed config a) (cvtB y) (delayed config b) -- Collect s -> Collect (cvtS s) where -- Flatten needless let-binds, which can be introduced by the -- conversion to the internal embeddable representation. -- - alet :: LeftHandSide a aenv aenv' + alet :: ALeftHandSide a aenv aenv' -> DelayedOpenAcc aenv a -> DelayedOpenAcc aenv' b -> PreOpenAcc DelayedOpenAcc aenv b alet lhs bnd body - | Just Refl <- aletBodyIsTrivial lhs body + | Just bodyVars <- extractArrayVars body + , Just Refl <- bindingIsTrivial lhs bodyVars , Manifest x <- bnd = x -- @@ -234,17 +235,19 @@ manifest config (OpenAcc pacc) = -- > compute :: Acc a -> Acc a -- > compute = id >-> id -- - apply :: PreOpenAfun DelayedOpenAcc aenv (a -> b) + apply :: ArraysR b + -> PreOpenAfun DelayedOpenAcc aenv (a -> b) -> DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv b - apply afun x + apply repr afun x | Alam lhs (Abody body) <- afun - , Just Refl <- aletBodyIsTrivial lhs body + , Just bodyVars <- extractArrayVars body + , Just Refl <- bindingIsTrivial lhs bodyVars , Manifest x' <- x = Stats.ruleFired "applyD/identity" x' -- | otherwise - = Apply afun x + = Apply repr afun x cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f cvtAF (Alam lhs f) = Alam lhs (cvtAF f) @@ -256,8 +259,8 @@ manifest config (OpenAcc pacc) = -- 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) + cvtF (Lam lhs f) = Lam lhs (cvtF f) + cvtF (Body b) = Body (cvtE b) cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t cvtE = convertOpenExp config @@ -272,21 +275,16 @@ manifest config (OpenAcc pacc) = convertOpenExp :: Config -> OpenExp env aenv t -> DelayedOpenExp env aenv t convertOpenExp config 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 + Let lhs bnd body -> Let lhs (cvtE bnd) (cvtE body) + Evar var -> Evar var + Const tp c -> Const tp c + Undef tp -> Undef tp + Nil -> Nil + Pair e1 e2 -> Pair (cvtE e1) (cvtE e2) 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) + ToIndex shr sh ix -> ToIndex shr (cvtE sh) (cvtE ix) + FromIndex shr sh ix -> FromIndex shr (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 @@ -294,21 +292,15 @@ convertOpenExp config exp = Index a sh -> Index (manifest config a) (cvtE sh) LinearIndex a i -> LinearIndex (manifest config a) (cvtE i) Shape a -> Shape (manifest config a) - ShapeSize sh -> ShapeSize (cvtE sh) - Intersect s t -> Intersect (cvtE s) (cvtE t) - Union s t -> Union (cvtE s) (cvtE t) + ShapeSize shr sh -> ShapeSize shr (cvtE sh) Foreign ff f e -> Foreign ff (cvtF f) (cvtE e) - Coerce e -> Coerce (cvtE e) + Coerce t1 t2 e -> Coerce t1 t2 (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) + cvtF (Lam lhs f) = Lam lhs (cvtF f) + cvtF (Body b) = Body (cvtE b) cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t cvtE = convertOpenExp config @@ -411,7 +403,7 @@ embedPreAcc config embedAcc elimAcc pacc Alet lhs bnd body -> aletD embedAcc elimAcc lhs bnd body Anil -> done $ Anil Acond p at ae -> acondD embedAcc (cvtE p) at ae - Apply f a -> done $ Apply (cvtAF f) (cvtA a) + Apply repr f a -> done $ Apply repr (cvtAF f) (cvtA a) Awhile p f a -> done $ Awhile (cvtAF p) (cvtAF f) (cvtA a) Apair a1 a2 -> done $ Apair (cvtA a1) (cvtA a2) Aforeign ff f a -> done $ Aforeign ff (cvtAF f) (cvtA a) @@ -419,8 +411,8 @@ embedPreAcc config embedAcc elimAcc pacc -- Array injection Avar v -> done $ Avar v - Use arrs -> done $ Use arrs - Unit e -> done $ Unit (cvtE e) + Use repr arr -> done $ Use repr arr + Unit tp e -> done $ Unit tp (cvtE e) -- Producers -- --------- @@ -435,16 +427,17 @@ embedPreAcc config embedAcc elimAcc pacc -- independently of all others, and so we can aggressively fuse arbitrary -- sequences of these operations. -- - Generate sh f -> generateD (cvtE sh) (cvtF f) + Generate repr sh f -> generateD repr (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) + Map tp f a -> mapD tp (cvtF f) (embedAcc a) + ZipWith tp f a b -> fuse2 (into (zipWithD tp) (cvtF f)) a b + Transform repr sh p f a -> transformD repr (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) + Backpermute slr sl p a + -> fuse (into2 (backpermuteD slr) (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 slr sl a -> reshapeD slr (embedAcc a) (cvtE sl) -- Consumers -- --------- @@ -462,21 +455,23 @@ embedPreAcc config embedAcc elimAcc pacc -- node, so that the producer can be directly embedded into the consumer -- during the code generation phase. -- - Fold f z a -> embed ArraysRarray (into2 Fold (cvtF f) (cvtE z)) a - Fold1 f a -> embed ArraysRarray (into Fold1 (cvtF f)) a - FoldSeg f z a s -> embed2 ArraysRarray (into2 FoldSeg (cvtF f) (cvtE z)) a s - Fold1Seg f a s -> embed2 ArraysRarray (into Fold1Seg (cvtF f)) a s - Scanl f z a -> embed ArraysRarray (into2 Scanl (cvtF f) (cvtE z)) a - Scanl1 f a -> embed ArraysRarray (into Scanl1 (cvtF f)) a - Scanl' f z a -> embed arraysRtuple2 (into2 Scanl' (cvtF f) (cvtE z)) a - Scanr f z a -> embed ArraysRarray (into2 Scanr (cvtF f) (cvtE z)) a - Scanr1 f a -> embed ArraysRarray (into Scanr1 (cvtF f)) a - Scanr' f z a -> embed arraysRtuple2 (into2 Scanr' (cvtF f) (cvtE z)) a - Permute f d p a -> embed2 ArraysRarray (into2 permute (cvtF f) (cvtF p)) d a - Stencil f x a -> embed ArraysRarray (into2 stencil1 (cvtF f) (cvtB x)) a - Stencil2 f x a y b -> embed2 ArraysRarray (into3 stencil2 (cvtF f) (cvtB x) (cvtB y)) a b + Fold f z a -> embed repr (into2 Fold (cvtF f) (cvtE z)) a + Fold1 f a -> embed repr (into Fold1 (cvtF f)) a + FoldSeg i f z a s -> embed2 repr (into2 (FoldSeg i) (cvtF f) (cvtE z)) a s + Fold1Seg i f a s -> embed2 repr (into (Fold1Seg i) (cvtF f)) a s + Scanl f z a -> embed repr (into2 Scanl (cvtF f) (cvtE z)) a + Scanl1 f a -> embed repr (into Scanl1 (cvtF f)) a + Scanl' f z a -> embed repr (into2 Scanl' (cvtF f) (cvtE z)) a + Scanr f z a -> embed repr (into2 Scanr (cvtF f) (cvtE z)) a + Scanr1 f a -> embed repr (into Scanr1 (cvtF f)) a + Scanr' f z a -> embed repr (into2 Scanr' (cvtF f) (cvtE z)) a + Permute f d p a -> embed2 repr (into2 permute (cvtF f) (cvtF p)) d a + Stencil s t f x a -> embed repr (into2 (stencil1 s t) (cvtF f) (cvtB x)) a + Stencil2 s1 s2 t f x a y b + -> embed2 repr (into3 (stencil2 s1 s2 t) (cvtF f) (cvtB x) (cvtB y)) a b where + repr = arraysRepr pacc -- If fusion is not enabled, force terms to the manifest representation -- unembed :: Embed acc aenv arrs -> Embed acc aenv arrs @@ -487,8 +482,8 @@ embedPreAcc config embedAcc elimAcc pacc = case extractArrayVars $ inject pacc of Just vars -> Embed env $ Done vars _ - | DeclareArrays lhs _ value <- declareArrays (arraysRepr pacc) - -> Embed (PushEnv env lhs $ inject pacc) $ Done $ value id + | DeclareVars lhs _ value <- declareVars (arraysRepr pacc) + -> Embed (PushEnv env lhs $ inject pacc) $ Done $ value weakenId cvtA :: acc aenv' a -> acc aenv' a cvtA = computeAcc . embedAcc @@ -509,8 +504,8 @@ embedPreAcc config embedAcc elimAcc pacc -- when this duplication is beneficial (keeping in mind that the stencil -- implementations themselves may share neighbouring elements). -- - stencil1 f x a = Stencil f x a - stencil2 f x y a b = Stencil2 f x a y b + stencil1 s t f x a = Stencil s t f x a + stencil2 s1 s2 t f x y a b = Stencil2 s1 s2 t f x a y b -- Conversions for closed scalar functions and expressions. This just -- applies scalar simplifications. @@ -518,7 +513,7 @@ embedPreAcc config embedAcc elimAcc pacc cvtF :: PreFun acc aenv' t -> PreFun acc aenv' t cvtF = simplify - cvtE :: Elt t => PreExp acc aenv' t -> PreExp acc aenv' t + cvtE :: PreExp acc aenv' t -> PreExp acc aenv' t cvtE = simplify cvtB :: PreBoundary acc aenv' t -> PreBoundary acc aenv' t @@ -530,36 +525,36 @@ embedPreAcc config embedAcc elimAcc pacc -- 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) + into :: Sink f => (f env' a -> b) -> f env a -> Extend ArrayR acc env env' -> b + into op a env = op (sinkA 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) + => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b -> Extend ArrayR acc env env' -> c + into2 op a b env = op (sinkA env a) (sinkA 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) + => (f1 env' a -> f2 env' b -> f3 env' c -> d) -> f1 env a -> f2 env b -> f3 env c -> Extend ArrayR acc env env' -> d + into3 op a b c env = op (sinkA env a) (sinkA env b) (sinkA env c) -- Operations which can be fused into consumers. Move all of the local -- bindings out of the way so that the fusible function operates -- directly on the delayed representation. See also: [Representing -- delayed arrays] -- - fuse :: (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs) + fuse :: (forall aenv'. Extend ArrayR 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 :: (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs -> Cunctation acc aenv' cs) + fuse2 :: (forall aenv'. Extend ArrayR 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) + , Embed env0 cc0 <- embedAcc (sinkA env1 a0) , env <- env1 `append` env0 - = Embed env (op env (sink env0 cc1) cc0) + = Embed env (op env (sinkA env0 cc1) cc0) -- Consumer operations which will be evaluated. -- @@ -593,42 +588,42 @@ embedPreAcc config embedAcc elimAcc pacc -- update the array of default values. -- embed :: ArraysR bs - -> (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs) + -> (forall aenv'. Extend ArrayR acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs) -> acc aenv as -> Embed acc aenv bs embed reprBs op (embedAcc -> Embed env cc) | Done{} <- cc - , DeclareArrays lhs _ value <- declareArrays reprBs - = Embed (PushEnv BaseEnv lhs $ inject (op BaseEnv (computeAcc (Embed env cc)))) $ Done $ value id + , DeclareVars lhs _ value <- declareVars reprBs + = Embed (PushEnv BaseEnv lhs $ inject (op BaseEnv (computeAcc (Embed env cc)))) $ Done $ value weakenId | otherwise -- Next line is duplicated for both branches, as the type variable for the environment is instantiated differently - , DeclareArrays lhs _ value <- declareArrays reprBs - = Embed (PushEnv env lhs $ inject (op env (inject (compute cc)))) $ Done $ value id + , DeclareVars lhs _ value <- declareVars reprBs + = Embed (PushEnv env lhs $ inject (op env (inject (compute cc)))) $ Done $ value weakenId embed2 :: ArraysR cs - -> (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs) + -> (forall aenv'. Extend ArrayR acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs) -> acc aenv as -> acc aenv bs -> Embed acc aenv cs embed2 reprCs op (embedAcc -> Embed env1 cc1) a0 | Done{} <- cc1 , a1 <- computeAcc (Embed env1 cc1) - = embed reprCs (\env0 -> op env0 (sink env0 a1)) a0 + = embed reprCs (\env0 -> op env0 (sinkA env0 a1)) a0 -- - | Embed env0 cc0 <- embedAcc (sink env1 a0) + | Embed env0 cc0 <- embedAcc (sinkA env1 a0) , env <- env1 `append` env0 = case cc0 of Done{} - | DeclareArrays lhs _ value <- declareArrays reprCs - -> Embed (PushEnv env1 lhs $ inject (op env1 (inject (compute cc1)) (computeAcc (Embed env0 cc0)))) $ Done $ value id + | DeclareVars lhs _ value <- declareVars reprCs + -> Embed (PushEnv env1 lhs $ inject (op env1 (inject (compute cc1)) (computeAcc (Embed env0 cc0)))) $ Done $ value weakenId _ -- Next line is duplicated for both branches, as the type variable for the environment is instantiated differently - | DeclareArrays lhs _ value <- declareArrays reprCs - -> Embed (PushEnv env lhs $ inject (op env (inject (compute (sink env0 cc1))) (inject (compute cc0)))) $ Done $ value id + | DeclareVars lhs _ value <- declareVars reprCs + -> Embed (PushEnv env lhs $ inject (op env (inject (compute (sinkA env0 cc1))) (inject (compute cc0)))) $ Done $ value weakenId -- 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) + -- -> (forall aenv'. Extend ArrayR 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) @@ -637,13 +632,13 @@ embedPreAcc config embedAcc elimAcc pacc -- trav2 :: (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) + -- -> (forall aenv'. Extend ArrayR 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) + -- trav2 f1 f0 op (f1 . embedAcc -> Embed env1 cc1) (f0 . embedAcc . sinkA env1 -> Embed env0 cc0) -- | env <- env1 `append` env0 - -- , acc1 <- inject . compute $ sink env0 cc1 + -- , acc1 <- inject . compute $ sinkA env0 cc1 -- , acc0 <- inject . compute $ cc0 -- = Embed (env `pushArrayEnv` inject (op env acc1 acc0)) doneZeroIdx @@ -759,7 +754,7 @@ data ExtendProducer acc aenv senv arrs where -- 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 ??? +-- append :: Extend ArrayR env env1 -> Extend ArrayR env env2 -> Extend ArrayR env ??? -- -- And hence, no way to combine the terms of the delayed representation. -- @@ -773,10 +768,12 @@ data ExtendProducer acc aenv senv arrs where -- 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 + Embed :: Extend ArrayR acc aenv aenv' + -> Cunctation acc aenv' a + -> Embed acc aenv a +instance HasArraysRepr acc => HasArraysRepr (Embed acc) where + arraysRepr (Embed _ c) = arraysRepr c -- Cunctation (n): the action or an instance of delaying; a tardy action. -- @@ -799,8 +796,8 @@ data Cunctation acc aenv a where -- 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 + Yield :: ArrayR (Array sh e) + -> PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> Cunctation acc aenv (Array sh e) @@ -810,8 +807,8 @@ data Cunctation acc aenv a where -- 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' + Step :: ArrayR (Array sh' b) + -> PreExp acc aenv sh' -> PreFun acc aenv (sh' -> sh) -> PreFun acc aenv (a -> b) -> ArrayVar aenv (Array sh a) @@ -820,24 +817,28 @@ data Cunctation acc aenv a where instance Kit acc => Simplify (Cunctation acc aenv a) where simplify = \case Done v -> Done v - Yield (simplify -> sh) (simplify -> f) -> Yield sh f - Step (simplify -> sh) (simplify -> p) (simplify -> f) v + Yield repr (simplify -> sh) (simplify -> f) -> Yield repr sh f + Step repr (simplify -> sh) (simplify -> p) (simplify -> f) v | Just Refl <- match sh (arrayShape v) , Just Refl <- isIdentity p - , Just Refl <- isIdentity f -> Done $ ArrayVarsArray v - | otherwise -> Step sh p f v + , Just Refl <- isIdentity f -> Done $ VarsSingle v + | otherwise -> Step repr sh p f v +instance HasArraysRepr (Cunctation acc) where + arraysRepr (Done v) = varsType v + arraysRepr (Yield repr _ _) = TupRsingle repr + arraysRepr (Step repr _ _ _ _) = TupRsingle repr -- Convert a real AST node into the internal representation -- done :: Kit acc => PreOpenAcc acc aenv a -> Embed acc aenv a done pacc | Just vars <- extractArrayVars $ inject pacc = Embed BaseEnv (Done vars) - | otherwise = case declareArrays (arraysRepr pacc) of - DeclareArrays lhs _ value -> Embed (PushEnv BaseEnv lhs $ inject pacc) $ Done $ value id + | otherwise = case declareVars (arraysRepr pacc) of + DeclareVars lhs _ value -> Embed (PushEnv BaseEnv lhs $ inject pacc) $ Done $ value weakenId -doneZeroIdx :: (Shape sh, Elt e) => Cunctation acc (aenv, Array sh e) (Array sh e) -doneZeroIdx = Done $ ArrayVarsArray $ ArrayVar ZeroIdx +doneZeroIdx :: ArrayR (Array sh e) -> Cunctation acc (aenv, Array sh e) (Array sh e) +doneZeroIdx repr = Done $ VarsSingle $ Var repr ZeroIdx -- Recast a cunctation into a mapping from indices to elements. -- @@ -846,9 +847,10 @@ yield :: Kit acc -> 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 (ArrayVarsArray v@ArrayVar{}) -> Yield (arrayShape v) (indexArray v) + Yield{} -> cc + Step repr sh p f v -> Yield repr sh (f `compose` indexArray v `compose` p) + Done (VarsSingle v@(Var repr _)) + -> Yield repr (arrayShape v) (indexArray v) -- Recast a cunctation into transformation step form. Not possible if the source @@ -859,17 +861,18 @@ step :: Kit acc -> Maybe (Cunctation acc aenv (Array sh e)) step cc = case cc of - Yield{} -> Nothing - Step{} -> Just cc - Done (ArrayVarsArray v@ArrayVar{}) -> Just $ Step (arrayShape v) identity identity v + Yield{} -> Nothing + Step{} -> Just cc + Done (VarsSingle v@(Var repr@(ArrayR shr tp) _)) + -> Just $ Step repr (arrayShape v) (identity $ shapeType shr) (identity tp) v -- 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 + | Just (Step _ sh _ _ _) <- step cc = sh + | Yield _ sh _ <- yield cc = sh -- Environment manipulation @@ -878,8 +881,8 @@ shape cc instance Kit acc => Sink (Cunctation acc) where weaken k = \case 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) + Step repr sh p f v -> Step repr (weaken k sh) (weaken k p) (weaken k f) (weaken k v) + Yield repr sh f -> Yield repr (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 @@ -944,47 +947,47 @@ computeAcc :: Kit acc => Embed acc aenv arrs -> acc aenv arrs computeAcc (Embed BaseEnv cc) = inject (compute cc) computeAcc (Embed env@(PushEnv bot lhs top) cc) = case simplify cc of - Done v -> bindA env (avarsIn v) - Yield sh f -> bindA env (inject (Generate sh f)) - Step sh p f v@(ArrayVar ix) + Done v -> bindA env (avarsIn v) + Yield repr sh f -> bindA env (inject (Generate repr sh f)) + Step repr sh p f v@(Var _ ix) | Just Refl <- match sh (arrayShape v) , Just Refl <- isIdentity p -> case ix of ZeroIdx - | LeftHandSideArray <- lhs - , Just g <- strengthen noTop f -> bindA bot (inject (Map g top)) - _ -> bindA env (inject (Map f (avarIn v))) + | LeftHandSideSingle ArrayR{} <- lhs + , Just g <- strengthen noTop f -> bindA bot (inject (Map (arrayRtype repr) g top)) + _ -> bindA env (inject (Map (arrayRtype repr) f (avarIn v))) | Just Refl <- isIdentity f -> case ix of ZeroIdx - | LeftHandSideArray <- lhs + | LeftHandSideSingle ArrayR{} <- lhs , Just q <- strengthen noTop p - , Just sz <- strengthen noTop sh -> bindA bot (inject (Backpermute sz q top)) - _ -> bindA env (inject (Backpermute sh p (avarIn v))) + , Just sz <- strengthen noTop sh -> bindA bot (inject (Backpermute (arrayRshape repr) sz q top)) + _ -> bindA env (inject (Backpermute (arrayRshape repr) sh p (avarIn v))) | otherwise -> case ix of ZeroIdx - | LeftHandSideArray <- lhs + | LeftHandSideSingle ArrayR{} <- lhs , Just g <- strengthen noTop f , Just q <- strengthen noTop p - , Just sz <- strengthen noTop sh -> bindA bot (inject (Transform sz q g top)) - _ -> bindA env (inject (Transform sh p f (avarIn v))) + , Just sz <- strengthen noTop sh -> bindA bot (inject (Transform repr sz q g top)) + _ -> bindA env (inject (Transform repr sh p f (avarIn v))) where bindA :: Kit acc - => Extend acc aenv aenv' - -> acc aenv' a - -> acc aenv a + => Extend ArrayR acc aenv aenv' + -> acc aenv' a + -> acc aenv a bindA BaseEnv b = b - bindA (PushEnv env lhs a) b = + bindA (PushEnv env lhs a) b -- If the freshly bound value is directly, returned, we don't have to bind it in a -- let. We can do this if the left hand side does not contain wildcards (other than -- wildcards for unit / nil) and if the value contains the same variables. - case aletBodyIsTrivial lhs b of - Just Refl -> bindA env a - Nothing -> bindA env (inject (Alet lhs a b)) + | Just vars <- extractArrayVars b + , Just Refl <- bindingIsTrivial lhs vars = bindA env a + | otherwise = bindA env (inject (Alet lhs a b)) noTop :: (aenv, a) :?> aenv noTop ZeroIdx = Nothing @@ -996,124 +999,101 @@ computeAcc (Embed env@(PushEnv bot lhs top) cc) = -- compute :: Kit acc => Cunctation acc aenv arrs -> PreOpenAcc acc aenv arrs compute cc = case simplify cc of - Done ArrayVarsNil -> Anil - Done (ArrayVarsArray v@ArrayVar{}) -> Avar v - Done (ArrayVarsPair v1 v2) -> avarsIn v1 `Apair` avarsIn v2 - Yield sh f -> Generate sh f - Step sh p f v + Done VarsNil -> Anil + Done (VarsSingle v@(Var ArrayR{} _)) -> Avar v + Done (VarsPair v1 v2) -> avarsIn v1 `Apair` avarsIn v2 + Yield repr sh f -> Generate repr sh f + Step (ArrayR shr tp) sh p f v | Just Refl <- match sh (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) + , Just Refl <- isIdentity p -> Map tp f (avarIn v) + | Just Refl <- isIdentity f -> Backpermute shr sh p (avarIn v) + | otherwise -> Transform (ArrayR shr tp) sh p f (avarIn v) -- Representation of a generator as a delayed array -- -generateD :: (Shape sh, Elt e) - => PreExp acc aenv sh +generateD :: ArrayR (Array sh e) + -> PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> Embed acc aenv (Array sh e) -generateD sh f +generateD repr sh f = Stats.ruleFired "generateD" - $ Embed BaseEnv (Yield sh f) + $ Embed BaseEnv (Yield repr 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) +mapD :: Kit acc + => TupleType 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) +mapD tp f (unzipD tp f -> Just a) = a +mapD tp 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) + go (step -> Just (Step (ArrayR shr _) sh ix g v)) = Step (ArrayR shr tp) sh ix (sinkA env f `compose` g) v + go (yield -> Yield (ArrayR shr _) sh g) = Yield (ArrayR shr tp) sh (sinkA 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. +-- a backend will be able to execute this in constant time. -- unzipD - :: forall acc aenv sh a b. (Kit acc, Shape sh, Elt a, Elt b) - => PreFun acc aenv (a -> b) + :: Kit acc + => TupleType 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 @a - = Nothing - - | Lam (Body (Prj tix (Var ZeroIdx))) <- f - = Stats.ruleFired "unzipD" - $ let f' = Lam (Body (Prj tix (Var ZeroIdx))) - a' = avarsIn v - in - Just $ Embed (env `pushArrayEnv` inject (Map f' a')) doneZeroIdx - - | 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' = avarsIn v' - in - Just $ Embed (env' `pushArrayEnv` inject (Map f' a')) doneZeroIdx - -unzipD _ _ - = Nothing +unzipD tp f (Embed env cc@(Done v)) + | Lam lhs (Body a) <- f + , Just vars <- extractExpVars a + , ArrayR shr _ <- arrayRepr cc + , f' <- Lam lhs $ Body $ evars vars = Just $ Embed (env `pushArrayEnv` inject (Map tp f' $ avarsIn v)) $ doneZeroIdx $ ArrayR shr tp + | otherwise = 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' + :: Kit acc + => ShapeR 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 +backpermuteD shr' 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) + go (step -> Just (Step (ArrayR _ tp) _ q f v)) = Step (ArrayR shr' tp) sh' (q `compose` p) f v + go (yield -> Yield (ArrayR _ tp) _ g) = Yield (ArrayR shr' tp) 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' + :: Kit acc + => ArrayR (Array sh' 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 +transformD (ArrayR shr' tp) sh' p f = Stats.ruleFired "transformD" - . fuse (into2 backpermuteD sh' p) - . mapD f + . fuse (into2 (backpermuteD shr') sh' p) + . mapD tp f where - fuse :: (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs) + fuse :: (forall aenv'. Extend ArrayR 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) + => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b -> Extend ArrayR acc env env' -> c + into2 op a b env = op (sinkA env a) (sinkA env b) -- Replicate as a backwards permutation @@ -1123,27 +1103,27 @@ transformD sh' p f -- expensive and/or `sh` is large. -- replicateD - :: (Kit acc, Shape sh, Shape sl, Elt slix) - => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) + :: Kit acc + => SliceIndex slix sl co 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 + $ backpermuteD (sliceDomainR sliceIndex) (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) + :: Kit acc + => SliceIndex slix sl co 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 + $ backpermuteD (sliceShapeR sliceIndex) (IndexSlice sliceIndex slix (shape cc)) (restrict sliceIndex slix) cc -- Reshape an array @@ -1157,58 +1137,91 @@ sliceD sliceIndex slix cc -- 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) + :: Kit acc + => ShapeR sl + -> Embed acc aenv (Array sh e) -> PreExp acc aenv sl -> Embed acc aenv (Array sl e) -reshapeD (Embed env cc) (sink env -> sl) +reshapeD slr (Embed env cc) (sinkA env -> sl) | Done v <- cc - = Embed (env `pushArrayEnv` inject (Reshape sl (avarsIn v))) doneZeroIdx + = Embed (env `pushArrayEnv` inject (Reshape slr sl (avarsIn v))) $ doneZeroIdx repr | otherwise = Stats.ruleFired "reshapeD" - $ Embed env (backpermuteD sl (reindex (shape cc) sl) cc) + $ Embed env (backpermuteD slr sl (reindex (arrayRshape $ arrayRepr cc) (shape cc) slr sl) cc) + + where + ArrayR _ tp = arrayRepr cc + repr = ArrayR slr tp -- 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) +zipWithD :: Kit acc + => TupleType 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 +zipWithD tp 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 (Step (ArrayR shr _) 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 + $ Step (ArrayR shr tp) (mkIntersect shr sh1 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 + | Yield (ArrayR shr _) sh1 f1 <- yield cc1 + , Yield _ sh0 f0 <- yield cc0 = Stats.ruleFired "zipWithD" - $ Yield (sh1 `Intersect` sh0) (combine f f1 f0) + $ Yield (ArrayR shr tp) (mkIntersect shr sh1 sh0) (combine f f1 f0) where - combine :: forall acc aenv a b c e. (Kit acc, Elt a, Elt b, Elt c) + combine :: forall acc aenv a b c e. Kit acc => 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' - + | Lam lhs1 (Body ixa') <- ixa -- else the skolem 'e' will escape + , Lam lhs2 (Body ixb') <- ixb + -- The two LeftHandSides may differ in the use of wildcards. If they do not match, we must + -- combine them as done in `combineLhs`. As this will probably not occur often and requires + -- additional weakening, we do a quick check whether the left hand sides are equal. + -- + = case matchELeftHandSide lhs1 lhs2 of + Just Refl + | Lam lhsA (Lam lhsB (Body c')) <- weakenE (weakenWithLHS lhs1) c + -> Lam lhs1 $ Body $ Let lhsA ixa' $ Let lhsB (weakenE (weakenWithLHS lhsA) ixb') c' + Nothing + | CombinedLHS lhs k1 _ <- combineLhs lhs1 lhs2 + , Lam lhsA (Lam lhsB (Body c')) <- weakenE (weakenWithLHS lhs) c + , ixa'' <- weakenE k1 ixa' + -> Lam lhs $ Body $ Let lhsA ixa'' $ Let lhsB {-(weakenE (weakenWithLHS lhsA .> k2) ixb')-} undefined c' + +combineLhs :: LeftHandSide s t env env1' -> LeftHandSide s t env env2' -> CombinedLHS s t env1' env2' env +combineLhs = go weakenId weakenId + where + go :: env1 :> env -> env2 :> env -> LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> CombinedLHS s t env1' env2' env + go k1 k2 (LeftHandSideWildcard tp) (LeftHandSideWildcard _) = CombinedLHS (LeftHandSideWildcard tp) k1 k2 + go k1 k2 (LeftHandSideSingle tp) (LeftHandSideSingle _) = CombinedLHS (LeftHandSideSingle tp) (sink k1) (sink k2) + go k1 k2 (LeftHandSidePair l1 h1) (LeftHandSidePair l2 h2) + | CombinedLHS l k1' k2' <- go k1 k2 l1 l2 + , CombinedLHS h k1'' k2'' <- go k1' k2' h1 h2 = CombinedLHS (LeftHandSidePair l h) k1'' k2'' + go k1 k2 (LeftHandSideWildcard _) lhs + | Exists lhs' <- rebuildLHS lhs = CombinedLHS lhs' (weakenWithLHS lhs' .> k1) (sinkWithLHS lhs lhs' k2) + go k1 k2 lhs (LeftHandSideWildcard _) + | Exists lhs' <- rebuildLHS lhs = CombinedLHS lhs' (sinkWithLHS lhs lhs' k1) (weakenWithLHS lhs' .> k2) + +data CombinedLHS s t env1' env2' env where + CombinedLHS :: LeftHandSide s t env env' -> env1' :> env' -> env2' :> env' -> CombinedLHS s t env1' env2' env -- NOTE: [Sharing vs. Fusion] -- @@ -1293,7 +1306,7 @@ zipWithD f cc1 cc0 aletD :: Kit acc => EmbedAcc acc -> ElimAcc acc - -> LeftHandSide arrs aenv aenv' + -> ALeftHandSide arrs aenv aenv' -> acc aenv arrs -> acc aenv' brrs -> Embed acc aenv brrs @@ -1306,8 +1319,8 @@ aletD embedAcc elimAcc lhs (embedAcc -> Embed env1 cc1) acc0 -- body, instead of adding to the environments and creating an indirection -- that must be later eliminated by shrinking. -- - | LeftHandSideArray <- lhs - , Done (ArrayVarsArray v1@ArrayVar{}) <- cc1 + | LeftHandSideSingle _ <- lhs + , Done (VarsSingle v1@(Var ArrayR{} _)) <- cc1 , Embed env0 cc0 <- embedAcc $ rebuildA (subAtop (Avar v1) . sink1 env1) acc0 = Stats.ruleFired "aletD/float" $ Embed (env1 `append` env0) cc0 @@ -1321,11 +1334,11 @@ aletD embedAcc elimAcc lhs (embedAcc -> Embed env1 cc1) acc0 aletD' :: forall acc aenv aenv' arrs brrs. Kit acc => EmbedAcc acc -> ElimAcc acc - -> LeftHandSide arrs aenv aenv' + -> ALeftHandSide arrs aenv aenv' -> Embed acc aenv arrs -> Embed acc aenv' brrs -> Embed acc aenv brrs -aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) +aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed env0 cc0) -- let-binding -- ----------- @@ -1360,25 +1373,25 @@ aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) -- 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) - => Extend acc aenv aenv' - -> Cunctation acc aenv' (Array sh e) - -> acc (aenv', Array sh e) brrs - -> Embed acc aenv brrs + eliminate :: forall aenv aenv' sh e brrs. + Extend ArrayR 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 - , ArrayVarsArray v1' <- v1 = 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 + | Done v1 <- cc1 + , VarsSingle v1'@(Var r _) <- v1 = elim r (arrayShape v1') (indexArray v1') + | Step r sh1 p1 f1 v1 <- cc1 = elim r sh1 (f1 `compose` indexArray v1 `compose` p1) + | Yield r sh1 f1 <- cc1 = elim r 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' $ ArrayVar ZeroIdx) body + elim :: ArrayR (Array sh e) -> PreExp acc aenv' sh -> PreFun acc aenv' (sh -> e) -> Embed acc aenv brrs + elim r sh1 f1 + | sh1' <- weaken (weakenSucc' weakenId) sh1 + , f1' <- weaken (weakenSucc' weakenId) f1 + , Embed env0' cc0' <- embedAcc $ rebuildA (subAtop bnd) $ kmap (replaceA sh1' f1' $ Var r ZeroIdx) body = Embed (env1 `append` env0') cc0' -- As part of let-elimination, we need to replace uses of array variables in @@ -1394,32 +1407,26 @@ aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> ArrayVar aenv (Array sh e) -> PreOpenExp acc env aenv t -> PreOpenExp acc env aenv t - replaceE sh' f' avar exp = + replaceE sh' f' avar@(Var (ArrayR shr _) _) exp = case exp of - Let x y -> Let (cvtE x) (replaceE (weakenE SuccIdx sh') (weakenE SuccIdx f') avar y) - Var i -> Var i + Let lhs x y -> let k = weakenWithLHS lhs + in Let lhs (cvtE x) (replaceE (weakenE k sh') (weakenE k f') avar y) + Evar var -> Evar var 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 + Const tp c -> Const tp c + Undef tp -> Undef tp + Nil -> Nil + Pair e1 e2 -> Pair (cvtE e1) (cvtE e2) 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) + ToIndex shr' sh ix -> ToIndex shr' (cvtE sh) (cvtE ix) + FromIndex shr' sh i -> FromIndex shr' (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) + ShapeSize shr' sh -> ShapeSize shr' (cvtE sh) While p f x -> While (replaceF sh' f' avar p) (replaceF sh' f' avar f) (cvtE x) - Coerce e -> Coerce (cvtE e) + Coerce t1 t2 e -> Coerce t1 t2 (cvtE e) Shape a | Just Refl <- match a a' -> Stats.substitution "replaceE/shape" sh' @@ -1427,12 +1434,16 @@ aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) Index a sh | Just Refl <- match a a' - , Lam (Body b) <- f' -> Stats.substitution "replaceE/!" . cvtE $ Let sh b + , Lam lhs (Body b) <- f' -> Stats.substitution "replaceE/!" . cvtE $ Let lhs 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 + , Lam lhs (Body b) <- f' + -> Stats.substitution "replaceE/!!" . cvtE + $ Let lhs + (Let (LeftHandSideSingle scalarTypeInt) i $ FromIndex shr (weakenE (weakenSucc' weakenId) sh') $ Evar $ Var scalarTypeInt ZeroIdx) + b | otherwise -> LinearIndex a (cvtE i) where @@ -1442,10 +1453,6 @@ aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) 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. PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> ArrayVar aenv (Array sh e) -> PreOpenFun acc env aenv t @@ -1453,7 +1460,8 @@ aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) 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) + Lam lhs f -> let k = weakenWithLHS lhs + in Lam lhs (replaceF (weakenE k sh') (weakenE k f') avar f) replaceA :: forall aenv sh e a. PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> ArrayVar aenv (Array sh e) @@ -1473,26 +1481,26 @@ aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) in Alet lhs (cvtA bnd) (kmap (replaceA sh'' f'' (weaken w avar)) body) - Use arrs -> Use arrs - Unit e -> Unit (cvtE e) + Use repr arrs -> Use repr arrs + Unit tp e -> Unit tp (cvtE e) Acond p at ae -> Acond (cvtE p) (cvtA at) (cvtA ae) Anil -> Anil Apair a1 a2 -> Apair (cvtA a1) (cvtA a2) Awhile p f a -> Awhile (cvtAF p) (cvtAF f) (cvtA a) - Apply f a -> Apply (cvtAF f) (cvtA a) + Apply repr f a -> Apply repr (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) + Generate repr sh f -> Generate repr (cvtE sh) (cvtF f) + Map tp f a -> Map tp (cvtF f) (cvtA a) + ZipWith tp f a b -> ZipWith tp (cvtF f) (cvtA a) (cvtA b) + Backpermute shr sh p a -> Backpermute shr (cvtE sh) (cvtF p) (cvtA a) + Transform repr sh p f a -> Transform repr (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) + Reshape shr sl a -> Reshape shr (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) + FoldSeg i f z a s -> FoldSeg i (cvtF f) (cvtE z) (cvtA a) (cvtA s) + Fold1Seg i f a s -> Fold1Seg i (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) @@ -1500,8 +1508,9 @@ aletD' embedAcc elimAcc LeftHandSideArray (Embed env1 cc1) (Embed env0 cc0) 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) + Stencil s t f x a -> Stencil s t (cvtF f) (cvtB x) (cvtA a) + Stencil2 s1 s2 t f x a y b + -> Stencil2 s1 s2 t (cvtF f) (cvtB x) (cvtA a) (cvtB y) (cvtA b) -- Collect seq -> Collect (cvtSeq seq) where @@ -1594,8 +1603,8 @@ acondD :: Kit acc -> 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 + | 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)) @@ -1604,46 +1613,53 @@ acondD embedAcc p t e -- 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)) +identity :: TupleType a -> PreOpenFun acc env aenv (a -> a) +identity tp + | DeclareVars lhs _ value <- declareVars tp + = Lam lhs $ Body $ evars $ value weakenId -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))) +toIndex :: Kit acc => ShapeR sh -> PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> Int) +toIndex shr sh + | DeclareVars lhs k value <- declareVars $ shapeType shr + = Lam lhs $ Body $ ToIndex shr (weakenE k sh) $ evars $ value weakenId -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))) +fromIndex :: Kit acc => ShapeR sh -> PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (Int -> sh) +fromIndex shr sh = Lam (LeftHandSideSingle scalarTypeInt) $ Body $ FromIndex shr (weakenE (weakenSucc' weakenId) sh) $ Evar $ Var scalarTypeInt ZeroIdx -reindex :: (Kit acc, Shape sh, Shape sh') - => PreOpenExp acc env aenv sh' +reindex :: Kit acc + => ShapeR sh' + -> PreOpenExp acc env aenv sh' + -> ShapeR 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 +reindex shr' sh' shr sh + | Just Refl <- match sh sh' = identity (shapeType shr') + | otherwise = fromIndex shr' sh' `compose` toIndex shr sh -extend :: (Kit acc, Shape sh, Shape sl, Elt slix) - => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) +extend :: Kit acc + => SliceIndex slix sl co sh -> PreExp acc aenv slix -> PreFun acc aenv (sh -> sl) -extend sliceIndex slix = Lam (Body (IndexSlice sliceIndex (weakenE SuccIdx slix) (Var ZeroIdx))) +extend sliceIndex slix + | DeclareVars lhs k value <- declareVars $ shapeType $ sliceDomainR sliceIndex + = Lam lhs $ Body $ IndexSlice sliceIndex (weakenE k slix) $ evars $ value weakenId -restrict :: (Kit acc, Shape sh, Shape sl, Elt slix) - => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh) +restrict :: Kit acc + => SliceIndex slix sl co sh -> PreExp acc aenv slix -> PreFun acc aenv (sl -> sh) -restrict sliceIndex slix = Lam (Body (IndexFull sliceIndex (weakenE SuccIdx slix) (Var ZeroIdx))) +restrict sliceIndex slix + | DeclareVars lhs k value <- declareVars $ shapeType $ sliceShapeR sliceIndex + = Lam lhs $ Body $ IndexFull sliceIndex (weakenE k slix) $ evars $ value weakenId -arrayShape :: (Kit acc) => ArrayVar aenv (Array sh e) -> PreExp acc aenv sh -arrayShape v@ArrayVar{} = simplify $ Shape $ avarIn v +arrayShape :: Kit acc => ArrayVar aenv (Array sh e) -> PreExp acc aenv sh +arrayShape = simplify . Shape . avarIn -indexArray :: (Kit acc) => ArrayVar aenv (Array sh e) -> PreFun acc aenv (sh -> e) -indexArray v@ArrayVar{} = Lam (Body (Index (avarIn v) (Var ZeroIdx))) +indexArray :: Kit acc => ArrayVar aenv (Array sh e) -> PreFun acc aenv (sh -> e) +indexArray v@(Var (ArrayR shr _) _) + | DeclareVars lhs _ value <- declareVars $ shapeType shr + = Lam lhs $ Body $ Index (avarIn v) $ evars $ value weakenId -linearIndex :: (Kit acc) => ArrayVar aenv (Array sh e) -> PreFun acc aenv (Int -> e) -linearIndex v@ArrayVar{} = Lam (Body (LinearIndex (avarIn v) (Var ZeroIdx))) +linearIndex :: Kit acc => ArrayVar aenv (Array sh e) -> PreFun acc aenv (Int -> e) +linearIndex v = Lam (LeftHandSideSingle scalarTypeInt) $ Body $ LinearIndex (avarIn v) $ Evar $ Var scalarTypeInt ZeroIdx diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index d0819cb05..5bb465318 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -36,7 +36,7 @@ module Data.Array.Accelerate.Trafo.Sharing ( Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr, convertAfun, convertAfunWith, - Function, FunctionR, + Function, FunctionR, EltReprFunctionR, FunctionRepr(..), functionRepr, convertExp, convertExpWith, convertFun, convertFunWith, @@ -143,10 +143,10 @@ sizeLayout (PushLayout lyt _ _) = 1 + sizeLayout lyt -- | Convert a closed array expression to de Bruijn form while also incorporating sharing -- information. -- -convertAcc :: Arrays arrs => Acc arrs -> AST.Acc (ArrRepr arrs) +convertAcc :: Acc arrs -> AST.Acc (ArrRepr arrs) convertAcc = convertAccWith defaultOptions -convertAccWith :: Arrays arrs => Config -> Acc arrs -> AST.Acc (ArrRepr arrs) +convertAccWith :: Config -> Acc arrs -> AST.Acc (ArrRepr arrs) convertAccWith config (Acc acc) = convertOpenAcc config EmptyLayout acc @@ -294,13 +294,13 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) -> let AST.OpenAcc a = avarsIn $ prjIdx ("de Bruijn conversion tag " ++ show i) showArraysR repr i alyt in a - Pipe reprA reprB _ (afun1 :: SmartAcc as -> ScopedAcc bs) (afun2 :: SmartAcc bs -> ScopedAcc cs) acc + Pipe reprA reprB reprC (afun1 :: SmartAcc as -> ScopedAcc bs) (afun2 :: SmartAcc bs -> ScopedAcc cs) acc | DeclareVars lhs k value <- declareVars reprB -> let noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ()) - boundAcc = AST.Apply (cvtAfun1 reprA afun1) (cvtA acc) + boundAcc = AST.Apply reprB (cvtAfun1 reprA afun1) (cvtA acc) alyt' = PushLayout (incLayout k alyt) lhs (value weakenId) - bodyAcc = AST.Apply + bodyAcc = AST.Apply reprC (convertSharingAfun1 config alyt' (noStableSharing : aenv') reprB afun2) (avarsIn $ value weakenId) in AST.Alet lhs (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) @@ -315,7 +315,7 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) Aprj ix a -> let AST.OpenAcc a' = cvtAprj ix a in a' Use repr array -> AST.Use repr array - Unit _ e -> AST.Unit (cvtE e) + Unit tp e -> AST.Unit tp (cvtE e) Generate repr@(ArrayR shr _) sh f -> AST.Generate repr (cvtE sh) (cvtF1 (shapeType shr) f) Reshape shr e acc -> AST.Reshape shr (cvtE e) (cvtA acc) @@ -613,13 +613,13 @@ instance Elt b => Function (Exp b) where -- | Convert a closed scalar expression to de Bruijn form while incorporating -- sharing information. -- -convertExp :: SmartExp e -> AST.Exp () e +convertExp :: Exp e -> AST.Exp () (EltRepr e) convertExp = convertExpWith $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing, float_out_acc] } -convertExpWith :: Config -> SmartExp e -> AST.Exp () e -convertExpWith config = convertOpenExp config EmptyLayout +convertExpWith :: Config -> Exp e -> AST.Exp () (EltRepr e) +convertExpWith config (Exp e) = convertOpenExp config EmptyLayout e convertOpenExp :: Config diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index c98525aed..173711068 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -401,12 +401,12 @@ usesOfPreAcc withShape countAcc idx = count Alet lhs bnd body -> countA bnd + countAcc withShape (weakenWithLHS lhs >:> idx) body Apair a1 a2 -> countA a1 + countA a2 Anil -> 0 - Apply _ a -> countA a + 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 + 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 diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index b9d1d2f7b..df82888a1 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -35,10 +35,11 @@ module Data.Array.Accelerate.Trafo.Substitution ( -- ** Rebuilding terms RebuildAcc, Rebuildable(..), RebuildableAcc, - RebuildableExp(..), rebuildWeakenVar, + RebuildableExp(..), rebuildWeakenVar, rebuildLHS, -- ** Checks - isIdentity, isIdentityIndexing + isIdentity, isIdentityIndexing, extractExpVars, + bindingIsTrivial, ) where @@ -215,7 +216,7 @@ compose f@(Lam lhsB (Body c)) g@(Lam lhsA (Body b)) | Just Refl <- isIdentity g = f | Exists lhsB' <- rebuildLHS lhsB - = Lam lhsA $ Body $ Let lhsB' b (weakenE (shiftWithLHS lhsB lhsB' $ weakenWithLHS lhsA) c) + = Lam lhsA $ Body $ Let lhsB' b (weakenE (sinkWithLHS lhsB lhsB' $ weakenWithLHS lhsA) c) -- = Stats.substitution "compose" . Lam lhs2 . Body $ substitute' f g compose _ _ = error "compose: impossible evaluation" @@ -630,10 +631,10 @@ rebuildPreOpenAcc k av acc = Avar ix -> accOut <$> av ix Apair as bs -> Apair <$> k av as <*> k av bs Anil -> pure Anil - Apply f a -> Apply <$> rebuildAfun k av f <*> k av a + Apply repr f a -> Apply repr <$> 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 + Unit tp e -> Unit tp <$> rebuildPreOpenExp k (pure . IE) av e Reshape shr e a -> Reshape shr <$> rebuildPreOpenExp k (pure . IE) av e <*> k av a Generate repr e f -> Generate repr <$> rebuildPreOpenExp k (pure . IE) av e <*> rebuildFun k (pure . IE) av f Transform repr sh ix f a -> Transform repr <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av ix <*> rebuildFun k (pure . IE) av f <*> k av a From 56249332069db5001b986d264d8dc92ef665df5c Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 18 Mar 2020 15:28:53 +0100 Subject: [PATCH 162/316] Remove old unused code --- .../Array/Accelerate/Array/Remote/Table.hs | 63 +------------------ 1 file changed, 2 insertions(+), 61 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Remote/Table.hs b/src/Data/Array/Accelerate/Array/Remote/Table.hs index c90b4c751..d3f91493d 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Table.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Table.hs @@ -37,7 +37,6 @@ module Data.Array.Accelerate.Array.Remote.Table ( -- Internals StableArray, makeStableArray, makeWeakArrayData, - -- AsSingleType(..), toSingleType ) where @@ -362,29 +361,6 @@ makeStableArray -> m StableArray makeStableArray !tp !ad | (_, ScalarDict) <- scalarDict tp = return $! StableArray (uniqueArrayId 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 ArrayEltRhalf (AD_Half ua) = uniqueArrayId ua - id ArrayEltRfloat (AD_Float ua) = uniqueArrayId ua - id ArrayEltRdouble (AD_Double ua) = uniqueArrayId ua - id ArrayEltRbool (AD_Bool ua) = uniqueArrayId ua - id ArrayEltRchar (AD_Char ua) = uniqueArrayId ua - id (ArrayEltRvec r) (AD_Vec _ 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 @@ -407,35 +383,7 @@ makeWeakArrayData !tp !ad !c !mf Nothing -> return () Just f -> addFinalizer uad f mkWeak uad c - {- - - 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 ArrayEltRhalf (AD_Half ua) = mkWeak' ua - mw ArrayEltRfloat (AD_Float ua) = mkWeak' ua - mw ArrayEltRdouble (AD_Double ua) = mkWeak' ua - mw ArrayEltRbool (AD_Bool ua) = mkWeak' ua - mw ArrayEltRchar (AD_Char ua) = mkWeak' ua - mw (ArrayEltRvec r) (AD_Vec _ 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 = --} + -- Debug -- ----- @@ -475,11 +423,4 @@ management msg nrs next = do else next -{- -data AsSingleType tp where - AsSingleType :: ScalarDataRepr tp ~ ScalarDataRepr tp' => SingleType tp' -> AsSingleType tp - -toSingleType :: ScalarType tp -> AsSingleType tp -toSingleType (SingleScalarType tp) = AsSingleType tp -toSingleType (VectorScalarType (VectorType _ tp)) = AsSingleType tp --} + From 24087b37c177f77afae0a720d2858e14c8f7d17d Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 20 Mar 2020 21:48:41 +0100 Subject: [PATCH 163/316] Add Vec(Un)Pack; ShapeRcons -> ShapeRsnoc --- src/Data/Array/Accelerate/AST.hs | 86 ++++++++++++------- src/Data/Array/Accelerate/Analysis/Hash.hs | 2 + src/Data/Array/Accelerate/Analysis/Match.hs | 2 +- src/Data/Array/Accelerate/Analysis/Stencil.hs | 2 +- .../Array/Accelerate/Array/Representation.hs | 64 +++++++------- src/Data/Array/Accelerate/Array/Sugar.hs | 6 +- src/Data/Array/Accelerate/Interpreter.hs | 34 ++++---- src/Data/Array/Accelerate/Language.hs | 4 +- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 2 + src/Data/Array/Accelerate/Pretty/Print.hs | 2 + src/Data/Array/Accelerate/Smart.hs | 57 ++++++++++-- src/Data/Array/Accelerate/Trafo/Base.hs | 2 +- src/Data/Array/Accelerate/Trafo/Shrink.hs | 6 ++ src/Data/Array/Accelerate/Trafo/Simplify.hs | 4 + .../Array/Accelerate/Trafo/Substitution.hs | 37 ++++---- src/Data/Array/Accelerate/Type.hs | 5 ++ 16 files changed, 200 insertions(+), 115 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 7ce9683c0..f832cdbb1 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -93,7 +94,7 @@ module Data.Array.Accelerate.AST ( PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc, PreBoundary(..), Boundary, StencilR(..), HasArraysRepr(..), arrayRepr, lhsToTupR, - ArrayR(..), ArraysR, ShapeR(..), SliceIndex(..), + ArrayR(..), ArraysR, ShapeR(..), SliceIndex(..), VecR(..), vecRvector, vecRtuple, -- * Accelerated sequences -- PreOpenSeq(..), Seq, @@ -146,6 +147,7 @@ import GHC.Int ( Int(..) ) import GHC.Prim ( (<#), (+#), indexWord8Array#, sizeofByteArray# ) import GHC.Ptr ( Ptr(..) ) import GHC.Word ( Word8(..) ) +import GHC.TypeNats -- friends import Data.Array.Accelerate.Array.Data @@ -800,18 +802,18 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where in arraysRarray sh tp arraysRepr (ZipWith tp _ a _) = let TupRsingle (ArrayR sh _) = arraysRepr a in arraysRarray sh tp - arraysRepr (Fold _ _ a) = let TupRsingle (ArrayR (ShapeRcons sh) tp) = arraysRepr a + arraysRepr (Fold _ _ a) = let TupRsingle (ArrayR (ShapeRsnoc sh) tp) = arraysRepr a in arraysRarray sh tp - arraysRepr (Fold1 _ a) = let TupRsingle (ArrayR (ShapeRcons sh) tp) = arraysRepr a + arraysRepr (Fold1 _ a) = let TupRsingle (ArrayR (ShapeRsnoc sh) tp) = arraysRepr a in arraysRarray sh tp arraysRepr (FoldSeg _ _ _ a _) = arraysRepr a arraysRepr (Fold1Seg _ _ a _) = arraysRepr a arraysRepr (Scanl _ _ a) = arraysRepr a - arraysRepr (Scanl' _ _ a) = let TupRsingle repr@(ArrayR (ShapeRcons sh) tp) = arraysRepr a + arraysRepr (Scanl' _ _ a) = let TupRsingle repr@(ArrayR (ShapeRsnoc sh) tp) = arraysRepr a in arraysRtuple2 repr $ ArrayR sh tp arraysRepr (Scanl1 _ a) = arraysRepr a arraysRepr (Scanr _ _ a) = arraysRepr a - arraysRepr (Scanr' _ _ a) = let TupRsingle repr@(ArrayR (ShapeRcons sh) tp) = arraysRepr a + arraysRepr (Scanr' _ _ a) = let TupRsingle repr@(ArrayR (ShapeRsnoc sh) tp) = arraysRepr a in arraysRtuple2 repr $ ArrayR sh tp arraysRepr (Scanr1 _ a) = arraysRepr a arraysRepr (Permute _ a _ _) = arraysRepr a @@ -890,20 +892,17 @@ data PreOpenExp acc env aenv t where Nil :: PreOpenExp acc env aenv () -- SIMD vectors - {- VecPrj :: VecIdx n - -> PreOpenExp (Vec n e) - -> PreOpenExp acc exp e + VecPack :: KnownNat n + => VecR n s tup + -> PreOpenExp acc env aenv tup + -> PreOpenExp acc env aenv (Vec n s) - Evec :: VecE n (exp e) - -> PreOpenExp acc exp (Vec n e) -} + VecUnpack :: KnownNat n + => VecR n s tup + -> PreOpenExp acc env aenv (Vec n s) + -> PreOpenExp acc env aenv tup -- Array indices & shapes - -- TODO: IndexIgnore? - -- IndexAny :: PreOpenExp acc aenv env () - - -- Evec :: PreOpenExp ?? - -- -> PreOpenExp (Vec n e) - IndexSlice :: SliceIndex slix sl co sh -> PreOpenExp acc env aenv slix -> PreOpenExp acc env aenv sh @@ -982,6 +981,27 @@ data PreOpenExp acc env aenv t where -> PreOpenExp acc env aenv a -> PreOpenExp acc env aenv b +data VecR (n :: Nat) single tuple where + VecRnil :: SingleType s -> VecR 0 s () + VecRsucc :: VecR n s t -> VecR (n + 1) s (t, s) + +vecRvector :: KnownNat n => VecR n s tuple -> VectorType (Vec n s) +vecRvector = uncurry VectorType . go + where + go :: VecR n s tuple -> (Int, SingleType s) + go (VecRnil tp) = (0, tp) + go (VecRsucc vec) = (n + 1, tp) + where (n, tp) = go vec + +vecRtuple :: VecR n s tuple -> TupleType tuple +vecRtuple = snd . go + where + go :: VecR n s tuple -> (SingleType s, TupleType tuple) + go (VecRnil tp) = (tp, TupRunit) + go (VecRsucc vec) + | (tp, tuple) <- go vec = (tp, TupRpair tuple $ TupRsingle $ SingleScalarType tp) + + expType :: HasArraysRepr acc => PreOpenExp acc aenv env t -> TupleType t expType expr = case expr of Let _ _ body -> expType body @@ -990,6 +1010,8 @@ expType expr = case expr of Foreign _ _ _ -> error "Though you ride on the wheels of tomorrow, you still wander the fields of your sorrow." Pair e1 e2 -> TupRpair (expType e1) (expType e2) Nil -> TupRunit + VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR + VecUnpack vecR _ -> vecRtuple vecR IndexSlice si _ _ -> shapeType $ sliceShapeR si IndexFull si _ _ -> shapeType $ sliceDomainR si ToIndex _ _ _ -> TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType $ TypeInt @@ -1007,20 +1029,6 @@ expType expr = case expr of Undef tp -> TupRsingle tp Coerce _ tp _ -> TupRsingle tp -{- data VecE (n :: Nat) a where - VecNil :: VecE 0 a - VecCons :: a -> VecE n a -> VecE (1 + n) a - --- Or have a VecE constructor which converts a tuple expression to a vector, and the other way around? - -instance Functor (VecE n) where - fmap _ VecNil = VecNil - fmap f (VecCons a as) = VecCons (f a) (fmap f as) - -data VecIdx n where - VecIdxZero :: VecIdx n - VecIdxSucc :: VecIdx n -> VecIdx (1 + n) -} - -- |Primitive constant values -- data PrimConst ty where @@ -1393,7 +1401,7 @@ rnfArrays (TupRpair ar1 ar2) (a1,a2) = rnfArrays ar1 a1 `seq` rnfArrays ar2 a2 rnfShapeR :: ShapeR sh -> () rnfShapeR ShapeRz = () -rnfShapeR (ShapeRcons shr) = rnfShapeR shr +rnfShapeR (ShapeRsnoc shr) = rnfShapeR shr rnfStencilR :: StencilR sh e pat -> () rnfStencilR (StencilRunit3 tp) = rnfTupleType tp @@ -1511,6 +1519,8 @@ rnfPreOpenExp rnfA topExp = Undef tp -> rnfScalarType tp Pair a b -> rnfE a `seq` rnfE b Nil -> () + VecPack vecr e -> rnfVecR vecr `seq` rnfE e + VecUnpack vecr e -> rnfVecR vecr `seq` rnfE e 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 shr sh ix -> rnfShapeR shr `seq` rnfE sh `seq` rnfE ix @@ -1650,6 +1660,9 @@ rnfFloatingType TypeHalf = () rnfFloatingType TypeFloat = () rnfFloatingType TypeDouble = () +rnfVecR :: VecR n single tuple -> () +rnfVecR (VecRnil tp) = rnfSingleType tp +rnfVecR (VecRsucc vec) = rnfVecR vec -- Template Haskell -- ================ @@ -1744,7 +1757,7 @@ liftELhs (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftELhs a) $$(li liftShapeR :: ShapeR sh -> Q (TExp (ShapeR sh)) liftShapeR ShapeRz = [|| ShapeRz ||] -liftShapeR (ShapeRcons sh) = [|| ShapeRcons $$(liftShapeR sh) ||] +liftShapeR (ShapeRsnoc sh) = [|| ShapeRsnoc $$(liftShapeR sh) ||] liftArrayR :: ArrayR a -> Q (TExp (ArrayR a)) liftArrayR (ArrayR shr tp) = [|| ArrayR $$(liftShapeR shr) $$(liftTupleType tp) ||] @@ -1798,6 +1811,8 @@ liftPreOpenExp liftA pexp = Undef tp -> [|| Undef $$(liftScalarType tp) ||] Pair a b -> [|| Pair $$(liftE a) $$(liftE b) ||] Nil -> [|| Nil ||] + VecPack vecr e -> [|| VecPack $$(liftVecR vecr) $$(liftE e) ||] + VecUnpack vecr e -> [|| VecUnpack $$(liftVecR vecr) $$(liftE e) ||] IndexSlice slice slix sh -> [|| IndexSlice $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sh) ||] IndexFull slice slix sl -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||] ToIndex shr sh ix -> [|| ToIndex $$(liftShapeR shr) $$(liftE sh) $$(liftE ix) ||] @@ -2027,6 +2042,10 @@ liftSingle (NonNumSingleType t) x = liftNonNum t x liftVector :: VectorType t -> t -> Q (TExp t) liftVector VectorType{} x = liftVec x +liftVecR :: VecR n single tuple -> Q (TExp (VecR n single tuple)) +liftVecR (VecRnil tp) = [|| VecRnil $$(liftSingleType tp) ||] +liftVecR (VecRsucc vec) = [|| VecRsucc $$(liftVecR vec) ||] + -- O(n) at runtime to copy from the Addr# to the ByteArray#. We should be able -- to do this without copying, but I don't think the definition of ByteArray# is -- exported (or it is deeply magical). @@ -2182,7 +2201,8 @@ showPreExpOp Undef{} = "Undef" showPreExpOp Foreign{} = "Foreign" showPreExpOp Pair{} = "Pair" showPreExpOp Nil{} = "Nil" --- showPreExpOp VecPrj{} = "VecPrj" +showPreExpOp VecPack{} = "VecPack" +showPreExpOp VecUnpack{} = "VecUnpack" showPreExpOp IndexSlice{} = "IndexSlice" showPreExpOp IndexFull{} = "IndexFull" showPreExpOp ToIndex{} = "ToIndex" diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 00600896a..1f516d504 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -330,6 +330,8 @@ encodePreOpenExp options encodeAcc exp = Evar (Var tp ix) -> intHost $(hashQ "Evar") <> encodeScalarType tp <> encodeIdx ix Nil -> intHost $(hashQ "Nil") Pair e1 e2 -> intHost $(hashQ "Pair") <> travE e1 <> travE e2 + VecPack _ e -> intHost $(hashQ "VecPack") <> travE e + VecUnpack _ e -> intHost $(hashQ "VecUnpack") <> travE e Const tp c -> intHost $(hashQ "Const") <> encodeScalarConst tp c Undef tp -> intHost $(hashQ "Undef") <> encodeScalarType tp IndexSlice spec ix sh -> intHost $(hashQ "IndexSlice") <> travE ix <> travE sh <> encodeSliceIndex spec diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index 485511503..0643c625c 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -848,7 +848,7 @@ matchShapeType {-# INLINEABLE matchShapeR #-} matchShapeR :: forall s t. ShapeR s -> ShapeR t -> Maybe (s :~: t) matchShapeR ShapeRz ShapeRz = Just Refl -matchShapeR (ShapeRcons shr1) (ShapeRcons shr2) +matchShapeR (ShapeRsnoc shr1) (ShapeRsnoc shr2) | Just Refl <- matchShapeR shr1 shr2 = Just Refl matchShapeR _ _ = Nothing diff --git a/src/Data/Array/Accelerate/Analysis/Stencil.hs b/src/Data/Array/Accelerate/Analysis/Stencil.hs index 5de30afab..cf465f565 100644 --- a/src/Data/Array/Accelerate/Analysis/Stencil.hs +++ b/src/Data/Array/Accelerate/Analysis/Stencil.hs @@ -74,7 +74,7 @@ positionsR (StencilRtup9 i h g f e d c b a) = concat -- Inject a dimension component inner-most -- innermost :: ShapeR sh -> (sh -> (sh, Int)) -> sh -> (sh, Int) -innermost shr f = invertShape (ShapeRcons shr) . f . invertShape shr +innermost shr f = invertShape (ShapeRsnoc shr) . f . invertShape shr invertShape :: ShapeR sh -> sh -> sh invertShape shr = listToShape shr . reverse . shapeToList shr diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index a8a5bc270..0dc742079 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -114,7 +114,7 @@ fromFunctionM (ArrayR shr tp) sh f = do concatVectors :: TupleType e -> [Vector e] -> Vector e concatVectors tp vs = adata `seq` Array ((), len) adata where - dim1 = ShapeRcons ShapeRz + dim1 = ShapeRsnoc ShapeRz offsets = scanl (+) 0 (map (size dim1 . shape) vs) len = last offsets (adata, _) = runArrayData $ do @@ -202,29 +202,29 @@ type DIM2 = (((), Int), Int) data ShapeR sh where ShapeRz :: ShapeR () - ShapeRcons :: ShapeR sh -> ShapeR (sh, Int) + ShapeRsnoc :: ShapeR sh -> ShapeR (sh, Int) rank :: ShapeR sh -> Int rank ShapeRz = 0 -rank (ShapeRcons shr) = rank shr + 1 +rank (ShapeRsnoc shr) = rank shr + 1 size :: ShapeR sh -> sh -> Int size ShapeRz () = 1 -size (ShapeRcons shr) (sh, sz) +size (ShapeRsnoc shr) (sh, sz) | sz <= 0 = 0 | otherwise = size shr sh * sz empty :: ShapeR sh -> sh empty ShapeRz = () -empty (ShapeRcons shr) = (empty shr, 0) +empty (ShapeRsnoc shr) = (empty shr, 0) ignore :: ShapeR sh -> sh ignore ShapeRz = () -ignore (ShapeRcons shr) = (ignore shr, -1) +ignore (ShapeRsnoc shr) = (ignore shr, -1) shapeZip :: (Int -> Int -> Int) -> ShapeR sh -> sh -> sh -> sh shapeZip _ ShapeRz () () = () -shapeZip f (ShapeRcons shr) (as, a) (bs, b) = (shapeZip f shr as bs, f a b) +shapeZip f (ShapeRsnoc shr) (as, a) (bs, b) = (shapeZip f shr as bs, f a b) intersect, union :: ShapeR sh -> sh -> sh -> sh intersect = shapeZip min @@ -232,13 +232,13 @@ union = shapeZip max toIndex :: ShapeR sh -> sh -> sh -> Int toIndex ShapeRz () () = 0 -toIndex (ShapeRcons shr) (sh, sz) (ix, i) +toIndex (ShapeRsnoc shr) (sh, sz) (ix, i) = $indexCheck "toIndex" i sz $ toIndex shr sh ix * sz + i fromIndex :: ShapeR sh -> sh -> Int -> sh fromIndex ShapeRz () _ = () -fromIndex (ShapeRcons shr) (sh, sz) i +fromIndex (ShapeRsnoc shr) (sh, sz) i = (fromIndex shr 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. @@ -250,7 +250,7 @@ fromIndex (ShapeRcons shr) (sh, sz) i shapeEq :: ShapeR sh -> sh -> sh -> Bool shapeEq ShapeRz () () = True -shapeEq (ShapeRcons shr) (sh, i) (sh', i') = i == i' && shapeEq shr sh sh' +shapeEq (ShapeRsnoc shr) (sh, i) (sh', i') = i == i' && shapeEq shr sh sh' -- iterate through the entire shape, applying the function in the -- second argument; third argument combines results and fourth is an @@ -258,7 +258,7 @@ shapeEq (ShapeRcons shr) (sh, i) (sh', i') = i == i' && shapeEq shr sh sh' -- is traversed in row-major order iter :: ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a -> a iter ShapeRz () f _ _ = f () -iter (ShapeRcons shr) (sh, sz) f c r = iter shr sh (\ix -> iter' (ix,0)) c r +iter (ShapeRsnoc shr) (sh, sz) f c r = iter shr sh (\ix -> iter' (ix,0)) c r where iter' (ix,i) | i >= sz = r | otherwise = f (ix,i) `c` iter' (ix,i+1) @@ -266,8 +266,8 @@ iter (ShapeRcons shr) (sh, sz) f c r = iter shr sh (\ix -> iter' (ix,0)) c r -- variant of 'iter' without an initial value iter1 :: ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a iter1 ShapeRz () f _ = f () -iter1 (ShapeRcons _ ) (_, 0) _ _ = $boundsError "iter1" "empty iteration space" -iter1 (ShapeRcons shr) (sh, sz) f c = iter1 shr sh (\ix -> iter1' (ix,0)) c +iter1 (ShapeRsnoc _ ) (_, 0) _ _ = $boundsError "iter1" "empty iteration space" +iter1 (ShapeRsnoc shr) (sh, sz) f c = iter1 shr 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) @@ -277,19 +277,19 @@ iter1 (ShapeRcons shr) (sh, sz) f c = iter1 shr sh (\ix -> iter1' (ix,0)) c -- convert a minpoint-maxpoint index into a shape rangeToShape :: ShapeR sh -> (sh, sh) -> sh rangeToShape ShapeRz ((), ()) = () -rangeToShape (ShapeRcons shr) ((sh1, sz1), (sh2, sz2)) = (rangeToShape shr (sh1, sh2), sz2 - sz1 + 1) +rangeToShape (ShapeRsnoc shr) ((sh1, sz1), (sh2, sz2)) = (rangeToShape shr (sh1, sh2), sz2 - sz1 + 1) -- the converse shapeToRange :: ShapeR sh -> sh -> (sh, sh) shapeToRange ShapeRz () = ((), ()) -shapeToRange (ShapeRcons shr) (sh, sz) = let (low, high) = shapeToRange shr sh in ((low, 0), (high, sz - 1)) +shapeToRange (ShapeRsnoc shr) (sh, sz) = let (low, high) = shapeToRange shr sh in ((low, 0), (high, sz - 1)) -- Other conversions -- Convert a shape into its list of dimensions shapeToList :: ShapeR sh -> sh -> [Int] shapeToList ShapeRz () = [] -shapeToList (ShapeRcons shr) (sh,sz) = sz : shapeToList shr sh +shapeToList (ShapeRsnoc shr) (sh,sz) = sz : shapeToList shr sh -- Convert a list of dimensions into a shape listToShape :: ShapeR sh -> [Int] -> sh @@ -300,12 +300,12 @@ listToShape shr ds = case listToShape' shr ds of -- Attempt to convert a list of dimensions into a shape listToShape' :: ShapeR sh -> [Int] -> Maybe sh listToShape' ShapeRz [] = Just () -listToShape' (ShapeRcons shr) (x:xs) = (, x) <$> listToShape' shr xs +listToShape' (ShapeRsnoc shr) (x:xs) = (, x) <$> listToShape' shr xs listToShape' _ _ = Nothing shapeType :: ShapeR sh -> TupleType sh shapeType ShapeRz = TupRunit -shapeType (ShapeRcons shr) = shapeType shr `TupRpair` (TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType TypeInt) +shapeType (ShapeRsnoc shr) = shapeType shr `TupRpair` (TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType TypeInt) -- |Slice representation -- @@ -364,13 +364,13 @@ sliceShape (SliceFixed sl) (sh, _) = sliceShape sl sh sliceShapeR :: SliceIndex slix sl co dim -> ShapeR sl sliceShapeR SliceNil = ShapeRz -sliceShapeR (SliceAll sl) = ShapeRcons $ sliceShapeR sl +sliceShapeR (SliceAll sl) = ShapeRsnoc $ sliceShapeR sl sliceShapeR (SliceFixed sl) = sliceShapeR sl sliceDomainR :: SliceIndex slix sl co dim -> ShapeR dim sliceDomainR SliceNil = ShapeRz -sliceDomainR (SliceAll sl) = ShapeRcons $ sliceDomainR sl -sliceDomainR (SliceFixed sl) = ShapeRcons $ sliceDomainR sl +sliceDomainR (SliceAll sl) = ShapeRsnoc $ sliceDomainR sl +sliceDomainR (SliceFixed sl) = ShapeRsnoc $ sliceDomainR sl -- | Enumerate all slices within a given bound. The innermost dimension changes -- most rapidly. @@ -437,14 +437,14 @@ stencilElt (StencilRtup7 sr _ _ _ _ _ _) = stencilElt sr stencilElt (StencilRtup9 sr _ _ _ _ _ _ _ _) = stencilElt sr stencilShape :: StencilR sh e pat -> ShapeR sh -stencilShape (StencilRunit3 _) = ShapeRcons ShapeRz -stencilShape (StencilRunit5 _) = ShapeRcons ShapeRz -stencilShape (StencilRunit7 _) = ShapeRcons ShapeRz -stencilShape (StencilRunit9 _) = ShapeRcons ShapeRz -stencilShape (StencilRtup3 sr _ _) = ShapeRcons $ stencilShape sr -stencilShape (StencilRtup5 sr _ _ _ _) = ShapeRcons $ stencilShape sr -stencilShape (StencilRtup7 sr _ _ _ _ _ _) = ShapeRcons $ stencilShape sr -stencilShape (StencilRtup9 sr _ _ _ _ _ _ _ _) = ShapeRcons $ stencilShape sr +stencilShape (StencilRunit3 _) = ShapeRsnoc ShapeRz +stencilShape (StencilRunit5 _) = ShapeRsnoc ShapeRz +stencilShape (StencilRunit7 _) = ShapeRsnoc ShapeRz +stencilShape (StencilRunit9 _) = ShapeRsnoc ShapeRz +stencilShape (StencilRtup3 sr _ _) = ShapeRsnoc $ stencilShape sr +stencilShape (StencilRtup5 sr _ _ _ _) = ShapeRsnoc $ stencilShape sr +stencilShape (StencilRtup7 sr _ _ _ _ _ _) = ShapeRsnoc $ stencilShape sr +stencilShape (StencilRtup9 sr _ _ _ _ _ _ _ _) = ShapeRsnoc $ stencilShape sr stencilType :: StencilR sh e pat -> TupleType pat stencilType (StencilRunit3 tp) = tupR3 tp tp tp @@ -469,7 +469,7 @@ rnfArray (ArrayR shr tp) (Array sh ad) = rnfShape shr sh `seq` rnfArrayData tp a rnfShape :: ShapeR sh -> sh -> () rnfShape ShapeRz () = () -rnfShape (ShapeRcons shr) (sh, s) = s `seq` rnfShape shr sh +rnfShape (ShapeRsnoc shr) (sh, s) = s `seq` rnfShape shr sh -- | Nicely format a shape as a string -- @@ -528,8 +528,8 @@ showArray repr@(ArrayR _ tp) = showArray' (showString . showElement tp) repr showArray' :: (e -> ShowS) -> ArrayR (Array sh e) -> Array sh e -> String showArray' f repr@(ArrayR shr tp) arr@(Array sh _) = case shr of ShapeRz -> "Scalar Z " ++ list - ShapeRcons ShapeRz -> "Vector (" ++ shapeString ++ ") " ++ list - ShapeRcons (ShapeRcons ShapeRz) -> "Matrix (" ++ shapeString ++ ") " ++ showMatrix f tp arr + ShapeRsnoc ShapeRz -> "Vector (" ++ shapeString ++ ") " ++ list + ShapeRsnoc (ShapeRsnoc ShapeRz) -> "Matrix (" ++ shapeString ++ ") " ++ showMatrix f tp arr _ -> "Array (" ++ shapeString ++ ") " ++ list where shapeString = showShape shr sh diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 73d10f914..320ecbb02 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -357,12 +357,12 @@ instance Shape sh => Elt (Any sh) where where go :: Repr.ShapeR sh' -> TupleType (AnyRepr sh') go Repr.ShapeRz = TupRunit - go (Repr.ShapeRcons shr) = TupRpair (go shr) TupRunit + go (Repr.ShapeRsnoc shr) = TupRpair (go shr) TupRunit fromElt _ = go $ shapeR @sh where go :: Repr.ShapeR sh' -> AnyRepr sh' go Repr.ShapeRz = () - go (Repr.ShapeRcons shr) = (go shr, ()) + go (Repr.ShapeRsnoc shr) = (go shr, ()) toElt _ = Any instance (Elt a, Elt b) => Elt (a, b) @@ -840,7 +840,7 @@ instance Shape Z where sliceNoneIndex = Repr.SliceNil instance Shape sh => Shape (sh:.Int) where - shapeR = Repr.ShapeRcons (shapeR @sh) + shapeR = Repr.ShapeRsnoc (shapeR @sh) sliceAnyIndex = Repr.SliceAll (sliceAnyIndex @sh) sliceNoneIndex = Repr.SliceFixed (sliceNoneIndex @sh) diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 135f2c24f..1d2bf758c 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -381,17 +381,17 @@ foldOp -> e -> Delayed (Array (sh, Int) e) -> WithReprs (Array sh e) -foldOp f z (Delayed (ArrayR (ShapeRcons shr) tp) (sh, n) arr _) - = fromFunction' (ArrayR shr tp) sh (\ix -> iter (ShapeRcons ShapeRz) ((), n) (\((), i) -> arr (ix, i)) f z) +foldOp f z (Delayed (ArrayR (ShapeRsnoc shr) tp) (sh, n) arr _) + = fromFunction' (ArrayR shr tp) sh (\ix -> iter (ShapeRsnoc ShapeRz) ((), n) (\((), i) -> arr (ix, i)) f z) fold1Op :: (e -> e -> e) -> Delayed (Array (sh, Int) e) -> WithReprs (Array sh e) -fold1Op f (Delayed (ArrayR (ShapeRcons shr) tp) (sh, n) arr _) +fold1Op f (Delayed (ArrayR (ShapeRsnoc shr) tp) (sh, n) arr _) = $boundsCheck "fold1" "empty array" (n > 0) - $ fromFunction' (ArrayR shr tp) sh (\ix -> iter1 (ShapeRcons ShapeRz) ((), n) (\((), i) -> arr (ix, i)) f) + $ fromFunction' (ArrayR shr tp) sh (\ix -> iter1 (ShapeRsnoc ShapeRz) ((), n) (\((), i) -> arr (ix, i)) f) foldSegOp @@ -409,7 +409,7 @@ foldSegOp itp f z (Delayed repr (sh, _) arr _) (Delayed _ ((), n) _ seg) end = fromIntegral $ seg (ix+1) in $boundsCheck "foldSeg" "empty segment" (end >= start) - $ iter (ShapeRcons ShapeRz) ((), end-start) (\((), i) -> arr (sz, start+i)) f z + $ iter (ShapeRsnoc ShapeRz) ((), end-start) (\((), i) -> arr (sz, start+i)) f z fold1SegOp @@ -426,7 +426,7 @@ fold1SegOp itp f (Delayed repr (sh, _) arr _) (Delayed _ ((), n) _ seg) end = fromIntegral $ seg (ix+1) in $boundsCheck "fold1Seg" "empty segment" (end > start) - $ iter1 (ShapeRcons ShapeRz) ((), end-start) (\((), i) -> arr (sz, start+i)) f + $ iter1 (ShapeRsnoc ShapeRz) ((), end-start) (\((), i) -> arr (sz, start+i)) f scanl1Op @@ -483,7 +483,7 @@ scanl'Op -> e -> Delayed (Array (sh, Int) e) -> WithReprs (((), Array (sh, Int) e), Array sh e) -scanl'Op f z (Delayed (ArrayR shr@(ShapeRcons shr') tp) (sh, n) ain _) +scanl'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) = ( TupRunit `TupRpair` TupRsingle (ArrayR shr tp) `TupRpair` TupRsingle (ArrayR shr' tp) , aout `seq` asum `seq` ( ( (), Array (sh, n) aout ) , Array sh asum ) @@ -560,7 +560,7 @@ scanr'Op -> e -> Delayed (Array (sh, Int) e) -> WithReprs (((), Array (sh, Int) e), Array sh e) -scanr'Op f z (Delayed (ArrayR shr@(ShapeRcons shr') tp) (sh, n) ain _) +scanr'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) = ( TupRunit `TupRpair` TupRsingle (ArrayR shr tp) `TupRpair` TupRsingle (ArrayR shr' tp) , aout `seq` asum `seq` ( ((), Array (sh, n) aout ) , Array sh asum ) @@ -599,7 +599,7 @@ permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR ignore' :: ShapeR sh -> sh ignore' ShapeRz = () - ignore' (ShapeRcons shr) = (ignore' shr, 0) + ignore' (ShapeRsnoc shr) = (ignore' shr, 0) ignore = ignore' shr' -- @@ -736,7 +736,7 @@ stencilAccess stencil = goR (stencilShape stencil) stencil -- when we recurse on the stencil structure we must manipulate the -- _left-most_ index component. -- - goR (ShapeRcons shr) (StencilRtup3 s1 s2 s3) rf ix = + goR (ShapeRsnoc shr) (StencilRtup3 s1 s2 s3) rf ix = let (i, ix') = uncons shr ix rf' d ds = rf (cons shr (i+d) ds) in @@ -745,7 +745,7 @@ stencilAccess stencil = goR (stencilShape stencil) stencil , goR shr s2 (rf' 0) ix') , goR shr s3 (rf' 1) ix') - goR (ShapeRcons shr) (StencilRtup5 s1 s2 s3 s4 s5) rf ix = + goR (ShapeRsnoc shr) (StencilRtup5 s1 s2 s3 s4 s5) rf ix = let (i, ix') = uncons shr ix rf' d ds = rf (cons shr (i+d) ds) in @@ -756,7 +756,7 @@ stencilAccess stencil = goR (stencilShape stencil) stencil , goR shr s4 (rf' 1) ix') , goR shr s5 (rf' 2) ix') - goR (ShapeRcons shr) (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) rf ix = + goR (ShapeRsnoc shr) (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) rf ix = let (i, ix') = uncons shr ix rf' d ds = rf (cons shr (i+d) ds) in @@ -769,7 +769,7 @@ stencilAccess stencil = goR (stencilShape stencil) stencil , goR shr s6 (rf' 2) ix') , goR shr s7 (rf' 3) ix') - goR (ShapeRcons shr) (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) rf ix = + goR (ShapeRsnoc shr) (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) rf ix = let (i, ix') = uncons shr ix rf' d ds = rf (cons shr (i+d) ds) in @@ -788,13 +788,13 @@ stencilAccess stencil = goR (stencilShape stencil) stencil -- cons :: ShapeR sh -> Int -> sh -> (sh, Int) cons ShapeRz ix () = ((), ix) - cons (ShapeRcons shr) ix (sh, sz) = (cons shr ix sh, sz) + cons (ShapeRsnoc shr) ix (sh, sz) = (cons shr ix sh, sz) -- Remove the left-most index of an index, and return the remainder -- uncons :: ShapeR sh -> (sh, Int) -> (Int, sh) uncons ShapeRz ((), v) = (v, ()) - uncons (ShapeRcons shr) (v1, v2) = let (i, v1') = uncons shr v1 + uncons (ShapeRsnoc shr) (v1, v2) = let (i, v1') = uncons shr v1 in (i, (v1', v2)) @@ -819,14 +819,14 @@ bounded shr bnd (Delayed _ sh f _) ix = -- inside :: ShapeR sh -> sh -> sh -> Bool inside ShapeRz () () = True - inside (ShapeRcons shr) (sh, sz) (ih, iz) = iz >= 0 && iz < sz && inside shr sh ih + inside (ShapeRsnoc shr) (sh, sz) (ih, iz) = iz >= 0 && iz < sz && inside shr sh ih -- Return the index (second argument), updated to obey the given boundary -- conditions when outside the bounds of the given shape (first argument) -- bound :: ShapeR sh -> sh -> sh -> sh bound ShapeRz () () = () - bound (ShapeRcons shr) (sh, sz) (ih, iz) = (bound shr sh ih, ih') + bound (ShapeRsnoc shr) (sh, sz) (ih, iz) = (bound shr sh ih, ih') where ih' | iz < 0 = case bnd of diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 12c4bc11f..d2fe5e164 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1305,7 +1305,7 @@ intersect (Exp x) (Exp y) = Exp $ intersect' (shapeR @sh) x y intersect' :: Repr.ShapeR sh -> SmartExp sh -> SmartExp sh -> SmartExp sh intersect' Repr.ShapeRz _ _ = SmartExp Nil -intersect' (Repr.ShapeRcons shr) (unPair -> (xs, x)) (unPair -> (ys, y)) +intersect' (Repr.ShapeRsnoc shr) (unPair -> (xs, x)) (unPair -> (ys, y)) = SmartExp $ intersect' shr xs ys `Pair` SmartExp (PrimApp (PrimMax singleType) $ SmartExp $ Pair x y) @@ -1318,7 +1318,7 @@ union (Exp x) (Exp y) = Exp $ union' (shapeR @sh) x y union' :: Repr.ShapeR sh -> SmartExp sh -> SmartExp sh -> SmartExp sh union' Repr.ShapeRz _ _ = SmartExp Nil -union' (Repr.ShapeRcons shr) (unPair -> (xs, x)) (unPair -> (ys, y)) +union' (Repr.ShapeRsnoc shr) (unPair -> (xs, x)) (unPair -> (ys, y)) = SmartExp $ union' shr xs ys `Pair` SmartExp (PrimApp (PrimMin singleType) $ SmartExp $ Pair x y) diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 282377d13..2b092a7ff 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -575,6 +575,8 @@ fvPreOpenExp fvA env aenv = fv fv (PrimApp _ x) = fv x fv (Pair e1 e2) = concat [ fv e1, fv e2] fv Nil = [] + fv (VecPack _ e) = fv e + fv (VecUnpack _ e) = fv e 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 ] diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index f5476ef5c..569433e15 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -341,6 +341,8 @@ prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = Const tp c -> prettyConst (TupRsingle tp) c Pair{} -> prettyTuple prettyAcc extractAcc env aenv exp Nil -> "()" + VecPack _ e -> ppF1 "vecPack" (ppE e) + VecUnpack _ e -> ppF1 "vecUnpack" (ppE e) Cond p t e -> flatAlt multi single where p' = ppE p context0 diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index c01c5c1c8..5c391f5d5 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -67,6 +68,7 @@ module Data.Array.Accelerate.Smart ( -- * Auxiliary functions ($$), ($$$), ($$$$), ($$$$$), unAcc, unAccFunction, ApplyAcc(..), exp, unPair, HasExpType(..), HasArraysRepr(..), + vecR2, vecR3, vecR4, vecR5, vecR6, vecR7, vecR8, vecR9, vecR16, -- Debugging showPreAccOp, showPreExpOp, @@ -87,6 +89,8 @@ import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), Open , PreOpenExp(..), OpenExp, PreExp, Exp , PreBoundary(..), Boundary, HasArraysRepr(..), expType , showPreAccOp, showPreExpOp ) +import GHC.TypeNats + -- Array computations -- ------------------ @@ -497,18 +501,18 @@ instance HasArraysRepr acc => HasArraysRepr (PreSmartAcc acc exp) where in TupRsingle $ ArrayR shr tp ZipWith _ _ tp _ a _ -> let TupRsingle (ArrayR shr _) = arraysRepr a in TupRsingle $ ArrayR shr tp - Fold _ _ _ a -> let TupRsingle (ArrayR (ShapeRcons shr) tp) = arraysRepr a + Fold _ _ _ a -> let TupRsingle (ArrayR (ShapeRsnoc shr) tp) = arraysRepr a in TupRsingle (ArrayR shr tp) - Fold1 _ _ a -> let TupRsingle (ArrayR (ShapeRcons shr) tp) = arraysRepr a + Fold1 _ _ a -> let TupRsingle (ArrayR (ShapeRsnoc shr) tp) = arraysRepr a in TupRsingle (ArrayR shr tp) FoldSeg _ _ _ _ a _ -> arraysRepr a Fold1Seg _ _ _ a _ -> arraysRepr a Scanl _ _ _ a -> arraysRepr a - Scanl' _ _ _ a -> let r@(TupRsingle (ArrayR (ShapeRcons shr) tp)) = arraysRepr a + Scanl' _ _ _ a -> let r@(TupRsingle (ArrayR (ShapeRsnoc shr) tp)) = arraysRepr a in r `pair` TupRsingle (ArrayR shr tp) Scanl1 _ _ a -> arraysRepr a Scanr _ _ _ a -> arraysRepr a - Scanr' _ _ _ a -> let r@(TupRsingle (ArrayR (ShapeRcons shr) tp)) = arraysRepr a + Scanr' _ _ _ a -> let r@(TupRsingle (ArrayR (ShapeRsnoc shr) tp)) = arraysRepr a in r `pair` TupRsingle (ArrayR shr tp) Scanr1 _ _ a -> arraysRepr a Permute _ _ a _ _ -> arraysRepr a @@ -678,11 +682,16 @@ data PreSmartExp acc exp t where -> exp (t1, t2) -> PreSmartExp acc exp t - {- Vec :: + -- SIMD vectors + VecPack :: KnownNat n + => VecR n s tup + -> exp tup + -> PreSmartExp acc exp (Vec n s) - VecPrj :: (KnownNat n, KnownNat k, k <= y) - => exp (Vec n e) - -> PreSmartExp acc exp e -} + VecUnpack :: KnownNat n + => VecR n s tup + -> exp (Vec n s) + -> PreSmartExp acc exp tup ToIndex :: ShapeR sh -> exp sh @@ -757,6 +766,8 @@ instance HasExpType exp => HasExpType (PreSmartExp acc exp) where Prj idx e -> let TupRpair t1 t2 = expType e in case idx of PairIdxLeft -> t1 PairIdxRight -> t2 + VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR + VecUnpack vecR _ -> vecRtuple vecR ToIndex _ _ _ -> TupRsingle $ scalarTypeInt FromIndex shr _ _ -> shapeType shr Cond _ e _ -> expType e @@ -2610,7 +2621,8 @@ showPreExpOp (Undef _) = "Undef" showPreExpOp Nil{} = "Nil" showPreExpOp Pair{} = "Pair" showPreExpOp Prj{} = "Prj" --- showPreExpOp VecPrj{} = "VecPrj" +showPreExpOp VecPack{} = "VecPack" +showPreExpOp VecUnpack{} = "VecUnpack" showPreExpOp ToIndex{} = "ToIndex" showPreExpOp FromIndex{} = "FromIndex" showPreExpOp Cond{} = "Cond" @@ -2624,3 +2636,30 @@ showPreExpOp ShapeSize{} = "ShapeSize" showPreExpOp Foreign{} = "Foreign" showPreExpOp Coerce{} = "Coerce" +vecR2 :: SingleType s -> VecR 2 s (Tup2 s s) +vecR2 s = VecRsucc $ VecRsucc $ VecRnil s + +vecR3 :: SingleType s -> VecR 3 s (Tup3 s s s) +vecR3 = VecRsucc . vecR2 + +vecR4 :: SingleType s -> VecR 4 s (Tup4 s s s s) +vecR4 = VecRsucc . vecR3 + +vecR5 :: SingleType s -> VecR 5 s (Tup5 s s s s s) +vecR5 = VecRsucc . vecR4 + +vecR6 :: SingleType s -> VecR 6 s (Tup6 s s s s s s) +vecR6 = VecRsucc . vecR5 + +vecR7 :: SingleType s -> VecR 7 s (Tup7 s s s s s s s) +vecR7 = VecRsucc . vecR6 + +vecR8 :: SingleType s -> VecR 8 s (Tup8 s s s s s s s s) +vecR8 = VecRsucc . vecR7 + +vecR9 :: SingleType s -> VecR 9 s (Tup9 s s s s s s s s s) +vecR9 = VecRsucc . vecR8 + +vecR16 :: SingleType s -> VecR 16 s (Tup16 s s s s s s s s s s s s s s s s) +vecR16 = VecRsucc . VecRsucc . VecRsucc . VecRsucc . VecRsucc . VecRsucc . VecRsucc . vecR9 + diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index 27e083da5..a0b7d66c0 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -459,7 +459,7 @@ mkShapeBinary :: (HasArraysRepr acc, RebuildableAcc acc) -> PreOpenExp acc env aenv sh -> PreOpenExp acc env aenv sh mkShapeBinary _ ShapeRz _ _ = Nil -mkShapeBinary f (ShapeRcons shr) (Pair as a) (Pair bs b) = mkShapeBinary f shr as bs `Pair` f a b +mkShapeBinary f (ShapeRsnoc shr) (Pair as a) (Pair bs b) = mkShapeBinary f shr as bs `Pair` f a b mkShapeBinary f shr (Let lhs bnd a) b = Let lhs bnd $ mkShapeBinary f shr a (weakenE (weakenWithLHS lhs) b) mkShapeBinary f shr a (Let lhs bnd b) = Let lhs bnd $ mkShapeBinary f shr (weakenE (weakenWithLHS lhs) a) b mkShapeBinary f shr a b@Pair{} -- `a` is not Pair diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 173711068..7d20298c5 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -178,6 +178,8 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE Undef t -> pure (Undef t) Nil -> pure Nil Pair x y -> Pair <$> shrinkE x <*> shrinkE y + VecPack vec e -> VecPack vec <$> shrinkE e + VecUnpack vec e -> VecUnpack vec <$> shrinkE e IndexSlice x ix sh -> IndexSlice x <$> shrinkE ix <*> shrinkE sh IndexFull x ix sl -> IndexFull x <$> shrinkE ix <*> shrinkE sl ToIndex shr sh ix -> ToIndex shr <$> shrinkE sh <*> shrinkE ix @@ -355,6 +357,8 @@ usesOfExp range = countE Undef _ -> Finite 0 Nil -> Finite 0 Pair e1 e2 -> countE e1 <> countE e2 + VecPack _ e -> countE e + VecUnpack _ e -> countE e IndexSlice _ ix sh -> countE ix <> countE sh IndexFull _ ix sl -> countE ix <> countE sl FromIndex _ sh i -> countE sh <> countE i @@ -438,6 +442,8 @@ usesOfPreAcc withShape countAcc idx = count Undef _ -> 0 Nil -> 0 Pair x y -> countE x + countE y + VecPack _ e -> countE e + VecUnpack _ e -> countE e IndexSlice _ ix sh -> countE ix + countE sh IndexFull _ ix sl -> countE ix + countE sl ToIndex _ sh ix -> countE sh + countE ix diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index 5c808f27a..5099f4201 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -231,6 +231,8 @@ simplifyOpenExp env = first getAny . cvtE Undef tp -> pure $ Undef tp Nil -> pure Nil Pair e1 e2 -> Pair <$> cvtE e1 <*> cvtE e2 + VecPack vec e -> VecPack vec <$> cvtE e + VecUnpack vec e -> VecUnpack vec <$> cvtE e IndexSlice x ix sh -> IndexSlice x <$> cvtE ix <*> cvtE sh IndexFull x ix sl -> IndexFull x <$> cvtE ix <*> cvtE sl ToIndex shr sh ix -> toIndex shr (cvtE sh) (cvtE ix) @@ -494,6 +496,8 @@ summariseOpenExp = (terms +~ 1) . goE Undef _ -> zero Nil -> zero & terms +~ 1 Pair e1 e2 -> travE e1 +++ travE e2 & terms +~ 1 + VecPack _ e -> travE e + VecUnpack _ e -> travE e 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 diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index df82888a1..44c5ebea0 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -139,26 +139,29 @@ inlineVars lhsBound expr bound | Just Refl <- matchVars vars vars' = Just $ weakenE k2 bound substitute k1 k2 vars e = case e of Let lhs e1 e2 - | Exists lhs' <- rebuildLHS lhs -> Let lhs' <$> travE e1 <*> substitute (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weaken` vars) e2 - Evar (Var t ix) -> Evar . Var t <$> k1 ix - Foreign asm f e1 -> Foreign asm f <$> travE e1 - Pair e1 e2 -> Pair <$> travE e1 <*> travE e2 - Nil -> Just Nil + | Exists lhs' <- rebuildLHS lhs + -> Let lhs' <$> travE e1 <*> substitute (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weaken` vars) e2 + Evar (Var t ix) -> Evar . Var t <$> k1 ix + Foreign asm f e1 -> Foreign asm f <$> travE e1 + Pair e1 e2 -> Pair <$> travE e1 <*> travE e2 + Nil -> Just Nil + VecPack vec e1 -> VecPack vec <$> travE e1 + VecUnpack vec e1 -> VecUnpack vec <$> travE e1 IndexSlice si e1 e2 -> IndexSlice si <$> travE e1 <*> travE e2 IndexFull si e1 e2 -> IndexFull si <$> travE e1 <*> travE e2 ToIndex shr e1 e2 -> ToIndex shr <$> travE e1 <*> travE e2 FromIndex shr e1 e2 -> FromIndex shr <$> travE e1 <*> travE e2 - Cond e1 e2 e3 -> Cond <$> travE e1 <*> travE e2 <*> travE e3 - While f1 f2 e1 -> While <$> travF f1 <*> travF f2 <*> travE e1 - Const t c -> Just $ Const t c - PrimConst c -> Just $ PrimConst c - PrimApp p e1 -> PrimApp p <$> travE e1 - Index a e1 -> Index a <$> travE e1 - LinearIndex a e1 -> LinearIndex a <$> travE e1 - Shape a -> Just $ Shape a - ShapeSize shr e1 -> ShapeSize shr <$> travE e1 - Undef t -> Just $ Undef t - Coerce t1 t2 e1 -> Coerce t1 t2 <$> travE e1 + Cond e1 e2 e3 -> Cond <$> travE e1 <*> travE e2 <*> travE e3 + While f1 f2 e1 -> While <$> travF f1 <*> travF f2 <*> travE e1 + Const t c -> Just $ Const t c + PrimConst c -> Just $ PrimConst c + PrimApp p e1 -> PrimApp p <$> travE e1 + Index a e1 -> Index a <$> travE e1 + LinearIndex a e1 -> LinearIndex a <$> travE e1 + Shape a -> Just $ Shape a + ShapeSize shr e1 -> ShapeSize shr <$> travE e1 + Undef t -> Just $ Undef t + Coerce t1 t2 e1 -> Coerce t1 t2 <$> travE e1 where travE :: PreOpenExp acc env1 aenv s -> Maybe (PreOpenExp acc env2 aenv s) @@ -526,6 +529,8 @@ rebuildPreOpenExp k v av exp = -> Let lhs' <$> rebuildPreOpenExp k v av a <*> rebuildPreOpenExp k (shiftE' lhs lhs' k v) av b Pair e1 e2 -> Pair <$> rebuildPreOpenExp k v av e1 <*> rebuildPreOpenExp k v av e2 Nil -> pure $ Nil + VecPack vec e -> VecPack vec <$> rebuildPreOpenExp k v av e + VecUnpack vec e -> VecUnpack vec <$> rebuildPreOpenExp k v av e 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 shr sh ix -> ToIndex shr <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av ix diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index 082d72375..f23686661 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -382,9 +382,14 @@ instance Show (TupR ScalarType a) where type Tup2 a b = (((), a), b) type Tup3 a b c = ((((), a), b), c) +type Tup4 a b c d = (((((), a), b), c), d) type Tup5 a b c d e = ((((((), a), b), c), d), e) +type Tup6 a b c d e f = (((((((), a), b), c), d), e), f) type Tup7 a b c d e f g = ((((((((), a), b), c), d), e), f), g) +type Tup8 a b c d e f g h = (((((((((), a), b), c), d), e), f), g), h) type Tup9 a b c d e f g h i = ((((((((((), a), b), c), d), e), f), g), h), i) +type Tup16 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)) tupR2 :: TupR s t1 -> TupR s t2 -> TupR s (Tup2 t1 t2) tupR2 t1 t2 = TupRunit `TupRpair` t1 `TupRpair` t2 From ec5299b330ee667b4941d1457208fa2eb25e0783 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 20 Mar 2020 21:48:51 +0100 Subject: [PATCH 164/316] Add IsPattern instances for Vec --- src/Data/Array/Accelerate/Pattern.hs | 58 ++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index ac40ac27d..266764ce3 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} #if __GLASGOW_HASKELL__ <= 800 {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} @@ -38,6 +40,7 @@ module Data.Array.Accelerate.Pattern ( import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Type import Language.Haskell.TH hiding ( Exp ) @@ -316,3 +319,58 @@ $(runQ $ do as <- mapM mkAccPattern [0..16] return $ concat (es ++ as) ) + +instance (Elt a, Elt (Vec 2 a), IsSingle (EltRepr a), EltRepr (Vec 2 a) ~ Vec 2 (EltRepr a)) => IsPattern Exp (Vec 2 a) (Exp a, Exp a) where + construct as = Exp $ SmartExp $ VecPack r tup + where + r = vecR2 $ singleType @(EltRepr a) + Exp tup = construct as :: Exp (a, a) + destruct e = destruct e' + where + e' :: Exp (a, a) + e' = Exp $ SmartExp $ VecUnpack r $ unExp e + r = vecR2 $ singleType @(EltRepr a) + +instance (Elt a, Elt (Vec 3 a), IsSingle (EltRepr a), EltRepr (Vec 3 a) ~ Vec 3 (EltRepr a)) => IsPattern Exp (Vec 3 a) (Exp a, Exp a, Exp a) where + construct as = Exp $ SmartExp $ VecPack r tup + where + r = vecR3 $ singleType @(EltRepr a) + Exp tup = construct as :: Exp (a, a, a) + destruct e = destruct e' + where + e' :: Exp (a, a, a) + e' = Exp $ SmartExp $ VecUnpack r $ unExp e + r = vecR3 $ singleType @(EltRepr a) + +instance (Elt a, Elt (Vec 4 a), IsSingle (EltRepr a), EltRepr (Vec 4 a) ~ Vec 4 (EltRepr a)) => IsPattern Exp (Vec 4 a) (Exp a, Exp a, Exp a, Exp a) where + construct as = Exp $ SmartExp $ VecPack r tup + where + r = vecR4 $ singleType @(EltRepr a) + Exp tup = construct as :: Exp (a, a, a, a) + destruct e = destruct e' + where + e' :: Exp (a, a, a, a) + e' = Exp $ SmartExp $ VecUnpack r $ unExp e + r = vecR4 $ singleType @(EltRepr a) + +instance (Elt a, Elt (Vec 8 a), IsSingle (EltRepr a), EltRepr (Vec 8 a) ~ Vec 8 (EltRepr a)) => IsPattern Exp (Vec 8 a) (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a) where + construct as = Exp $ SmartExp $ VecPack r tup + where + r = vecR8 $ singleType @(EltRepr a) + Exp tup = construct as :: Exp (a, a, a, a, a, a, a, a) + destruct e = destruct e' + where + e' :: Exp (a, a, a, a, a, a, a, a) + e' = Exp $ SmartExp $ VecUnpack r $ unExp e + r = vecR8 $ singleType @(EltRepr a) + +instance (Elt a, Elt (Vec 16 a), IsSingle (EltRepr a), EltRepr (Vec 16 a) ~ Vec 16 (EltRepr a)) => IsPattern Exp (Vec 16 a) (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a) where + construct as = Exp $ SmartExp $ VecPack r tup + where + r = vecR16 $ singleType @(EltRepr a) + Exp tup = construct as :: Exp (a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a) + destruct e = destruct e' + where + e' :: Exp (a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a) + e' = Exp $ SmartExp $ VecUnpack r $ unExp e + r = vecR16 $ singleType @(EltRepr a) From 62aa25068ddacae3a555609c1e7b76a14d3a5323 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 21 Mar 2020 15:06:19 +0100 Subject: [PATCH 165/316] update to ghc-8.8.3 --- .travis.yml | 2 +- stack-8.8.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 948582d3f..92b844851 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,7 +28,7 @@ addons: matrix: fast_finish: true include: - - env: GHC=8.8.2 + - env: GHC=8.8.3 compiler: "GHC 8.8" - env: GHC=8.6.5 diff --git a/stack-8.8.yaml b/stack-8.8.yaml index fe5ab32f3..7a07b5e36 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-15.2 +resolver: lts-15.4 packages: - . From 0f4a3264bef2b654b4f030fbdbca3b4aebaf624e Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Sun, 22 Mar 2020 21:20:07 +0100 Subject: [PATCH 166/316] Add code which was accidentally removed --- src/Data/Array/Accelerate/Smart.hs | 37 ++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 46aaf552a..6762f9698 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -743,6 +743,43 @@ data PreSmartExp acc exp t where Undef :: ScalarType t -> PreSmartExp acc exp t + Coerce :: (Typeable a, Typeable b, BitSizeEq a b) + => ScalarType a + -> ScalarType b + -> exp a + -> PreSmartExp acc exp b + +class HasExpType f where + expType :: f t -> TupleType t + +instance HasExpType exp => HasExpType (PreSmartExp acc exp) where + expType expr = case expr of + Tag tp _ -> tp + Const tp _ -> TupRsingle tp + Nil -> TupRunit + Pair e1 e2 -> expType e1 `TupRpair` expType e2 + Prj idx e -> let TupRpair t1 t2 = expType e in case idx of + PairIdxLeft -> t1 + PairIdxRight -> t2 + VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR + VecUnpack vecR _ -> vecRtuple vecR + ToIndex _ _ _ -> TupRsingle $ scalarTypeInt + FromIndex shr _ _ -> shapeType shr + Cond _ e _ -> expType e + While t _ _ _ -> t + PrimConst c -> primConstType c + PrimApp f _ -> snd $ primFunType f + Index tp _ _ -> tp + LinearIndex tp _ _ -> tp + Shape shr _ -> shapeType shr + ShapeSize _ _ -> TupRsingle $ scalarTypeInt + Foreign (_ :: asm (x -> y)) _ _ -> eltType @y + Undef tp -> TupRsingle tp + Coerce _ tp _ -> TupRsingle tp + +instance HasExpType SmartExp where + expType (SmartExp e) = expType e + -- Smart constructors for stencils -- ------------------------------- From bc5e43248a0d60f77d08a3a23d0b06b2da4e6048 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Tue, 24 Mar 2020 12:20:12 +0100 Subject: [PATCH 167/316] Add Vec patterns and evaluation, remove Typeable --- src/Data/Array/Accelerate.hs | 7 + src/Data/Array/Accelerate/AST.hs | 20 -- src/Data/Array/Accelerate/Analysis/Hash.hs | 2 +- src/Data/Array/Accelerate/Analysis/Match.hs | 10 +- .../Array/Accelerate/Array/Representation.hs | 72 +++++++- src/Data/Array/Accelerate/Array/Sugar.hs | 41 +++-- src/Data/Array/Accelerate/Classes/RealFrac.hs | 7 +- src/Data/Array/Accelerate/Data/Complex.hs | 172 +++++++++++------- src/Data/Array/Accelerate/Data/Monoid.hs | 2 +- src/Data/Array/Accelerate/Interpreter.hs | 2 + src/Data/Array/Accelerate/Pattern.hs | 69 ++++--- src/Data/Array/Accelerate/Smart.hs | 2 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 6 + 13 files changed, 273 insertions(+), 139 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 39da125b3..4064c6d3e 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -303,6 +303,9 @@ module Data.Array.Accelerate ( -- ** Scalar data types Exp, + -- ** SIMD vectors + Vec, VecElt, + -- ** Type classes -- *** Basic type classes Eq(..), @@ -342,6 +345,10 @@ module Data.Array.Accelerate ( pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, + pattern V2, pattern V2_, pattern V3, pattern V3_, + pattern V4, pattern V4_, pattern V8, pattern V8_, + pattern V16, pattern V16_, + pattern True_, pattern False_, -- ** Scalar operations diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 13212b766..6bddfe5fa 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -981,26 +981,6 @@ data PreOpenExp acc env aenv t where -> PreOpenExp acc env aenv a -> PreOpenExp acc env aenv b -data VecR (n :: Nat) single tuple where - VecRnil :: SingleType s -> VecR 0 s () - VecRsucc :: VecR n s t -> VecR (n + 1) s (t, s) - -vecRvector :: KnownNat n => VecR n s tuple -> VectorType (Vec n s) -vecRvector = uncurry VectorType . go - where - go :: VecR n s tuple -> (Int, SingleType s) - go (VecRnil tp) = (0, tp) - go (VecRsucc vec) = (n + 1, tp) - where (n, tp) = go vec - -vecRtuple :: VecR n s tuple -> TupleType tuple -vecRtuple = snd . go - where - go :: VecR n s tuple -> (SingleType s, TupleType tuple) - go (VecRnil tp) = (tp, TupRunit) - go (VecRsucc vec) - | (tp, tuple) <- go vec = (tp, TupRpair tuple $ TupRsingle $ SingleScalarType tp) - expType :: HasArraysRepr acc => PreOpenExp acc aenv env t -> TupleType t expType expr = case expr of diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 8935a9166..3a69de716 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -325,7 +325,7 @@ encodePreOpenExp options encodeAcc exp = -- -- TLM 2020-01-08 -- travA :: forall aenv' a. acc aenv' a -> Builder - travA a = encodeArraysType (arrayRepr a) <> encodeAcc (options {perfect=True}) a + travA a = encodeAcc (options {perfect=True}) a travE :: forall env' aenv' e. PreOpenExp acc env' aenv' e -> Builder travE e = encodePreOpenExp options encodeAcc e diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index 0643c625c..1f4e525e0 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -98,13 +98,14 @@ matchPreOpenAcc matchAcc encodeAcc = match , Just Refl <- matchAcc a1 a2 = Just Refl - match (Aforeign ff1 _ a1) (Aforeign ff2 _ a2) + match (Aforeign ff1 f1 a1) (Aforeign ff2 f2 a2) | Just Refl <- matchAcc a1 a2 , unsafePerformIO $ do sn1 <- makeStableName ff1 sn2 <- makeStableName ff2 return $! hashStableName sn1 == hashStableName sn2 - = gcast Refl + , Just Refl <- matchPreOpenAfun matchAcc f1 f2 + = Just Refl match (Acond p1 t1 e1) (Acond p2 t2 e2) | Just Refl <- matchExp p1 p2 @@ -464,13 +465,14 @@ matchPreOpenExp matchAcc encodeAcc = match match (Evar v1) (Evar v2) = matchVar v1 v2 - match (Foreign ff1 _ e1) (Foreign ff2 _ e2) + match (Foreign ff1 f1 e1) (Foreign ff2 f2 e2) | Just Refl <- match e1 e2 , unsafePerformIO $ do sn1 <- makeStableName ff1 sn2 <- makeStableName ff2 return $! hashStableName sn1 == hashStableName sn2 - = gcast Refl + , Just Refl <- matchPreOpenFun matchAcc encodeAcc f1 f2 + = Just Refl match (Const t1 c1) (Const t2 c2) | Just Refl <- matchScalarType t1 t2 diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index 0dc742079..c73284a20 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -1,8 +1,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -38,6 +40,9 @@ module Data.Array.Accelerate.Array.Representation ( -- * Slice shape functions sliceShape, sliceShapeR, sliceDomainR, enumSlices, + -- * Vec representation & utilities + VecR(..), vecRvector, vecRtuple, vecPack, vecUnpack, + -- * Stencils StencilR(..), stencilElt, stencilShape, stencilType, stencilArrayR, @@ -51,12 +56,16 @@ import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Data -- standard library -import GHC.Base ( quotInt, remInt ) +import GHC.Base ( quotInt, remInt, Int(..), Int#, (-#) ) +import GHC.TypeNats +import Data.Primitive.ByteArray +import Data.Primitive.Types import Prelude hiding ((!!)) import Data.List ( intercalate ) import Text.Show ( showListWith ) import System.IO.Unsafe ( unsafePerformIO ) import qualified Data.Vector.Unboxed as U +import Control.Monad.ST -- |Array data type, where the type arguments regard the representation types of the shape and elements. data Array sh e where @@ -471,6 +480,67 @@ rnfShape :: ShapeR sh -> sh -> () rnfShape ShapeRz () = () rnfShape (ShapeRsnoc shr) (sh, s) = s `seq` rnfShape shr sh +-- | SIMD Vectors (Vec n t) +-- + +-- Declares the size of a SIMD vector and the type of its elements. +-- This data type is used to denote the relation between a vector +-- type (Vec n single) with its tuple representation (tuple). +-- Conversions between those types are exposed through vecPack and +-- vecUnpack. +-- +data VecR (n :: Nat) single tuple where + VecRnil :: SingleType s -> VecR 0 s () + VecRsucc :: VecR n s t -> VecR (n + 1) s (t, s) + +vecRvector :: KnownNat n => VecR n s tuple -> VectorType (Vec n s) +vecRvector = uncurry VectorType . go + where + go :: VecR n s tuple -> (Int, SingleType s) + go (VecRnil tp) = (0, tp) + go (VecRsucc vec) = (n + 1, tp) + where (n, tp) = go vec + +vecRtuple :: VecR n s tuple -> TupleType tuple +vecRtuple = snd . go + where + go :: VecR n s tuple -> (SingleType s, TupleType tuple) + go (VecRnil tp) = (tp, TupRunit) + go (VecRsucc vec) + | (tp, tuple) <- go vec = (tp, TupRpair tuple $ TupRsingle $ SingleScalarType tp) + +vecPack :: forall n single tuple. KnownNat n => VecR n single tuple -> tuple -> Vec n single +vecPack vecR tuple + | IsPrim <- getPrim single = runST $ do + mba <- newByteArray (n * sizeOf (undefined :: single)) + go (n - 1) vecR tuple mba + ByteArray ba# <- unsafeFreezeByteArray mba + return $! Vec ba# + + where + VectorType n single = vecRvector vecR + + go :: Prim single => Int -> VecR n' single tuple' -> tuple' -> MutableByteArray s -> ST s () + go _ (VecRnil _) () _ = return () + go i (VecRsucc r) (xs, x) mba = do + writeByteArray mba i x + go (i - 1) r xs mba + +vecUnpack :: forall n single tuple. KnownNat n => VecR n single tuple -> Vec n single -> tuple +vecUnpack vecR (Vec ba#) + | IsPrim <- getPrim single + = go (n# -# 1#) vecR + where + VectorType n single = vecRvector vecR + !(I# n#) = n + + go :: Prim single => Int# -> VecR n' single tuple' -> tuple' + go _ (VecRnil _) = () + go i# (VecRsucc r) = x `seq` xs `seq` (xs, x) + where + xs = go (i# -# 1#) r + x = indexByteArray# ba# i# + -- | Nicely format a shape as a string -- showShape :: ShapeR sh -> sh -> String diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 3b2b361c0..f55f76442 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -59,7 +59,7 @@ module Data.Array.Accelerate.Array.Sugar ( Tuple(..), IsTuple, fromTuple, toTuple, -- * Miscellaneous - showShape, Foreign(..), sliceShape, enumSlices, + showShape, Foreign(..), sliceShape, enumSlices, VecElt, ) where @@ -67,6 +67,7 @@ module Data.Array.Accelerate.Array.Sugar ( import Control.DeepSeq import Data.Kind import Data.Typeable +import Data.Primitive.Types import System.IO.Unsafe ( unsafePerformIO ) import Language.Haskell.TH hiding ( Foreign, Type ) import Language.Haskell.TH.Extra @@ -210,7 +211,7 @@ data Divide sh = Divide -- > data Point = Point Int Float -- > deriving (Show, Generic, Elt) -- -class (Show a, Typeable a, Typeable (EltRepr a)) => Elt a where +class Show a => Elt a where -- | Type representation mapping, which explains how to convert a type from -- the surface type into the internal representation type consisting only of -- simple primitive types, unit '()', and pair '(,)'. @@ -460,7 +461,7 @@ toTuple = toProd @Elt -- 16-elements wide. Accelerate computations can thereby return multiple -- results. -- -class (Typeable a, Typeable (ArrRepr a)) => Arrays a where +class Arrays a where -- | Type representation mapping, which explains how to convert from the -- surface type into the internal representation type, which consists only of -- 'Array', and '()' and '(,)' as type-level nil and snoc. @@ -1000,6 +1001,22 @@ enumSlices :: forall slix co sl dim. (Elt slix, Elt dim) enumSlices slix = map toElt . Repr.enumSlices slix . fromElt +-- Vec +-- --- + +class (Elt a, IsSingle a, Prim a, a ~ EltRepr a) => VecElt a + +-- XXX: Should we fix this to known "good" vector sizes? +-- +instance (KnownNat n, VecElt a) => Elt (Vec n a) where + type EltRepr (Vec n a) = Vec n a + {-# INLINE eltType #-} + {-# INLINE [1] fromElt #-} + {-# INLINE [1] toElt #-} + eltType = TupRsingle $ VectorScalarType $ VectorType (fromIntegral $ natVal (undefined :: Proxy n)) $ singleType @a + fromElt = id + toElt = id + -- Instances -- --------- @@ -1065,21 +1082,11 @@ $(runQ $ do toElt = id |] - -- XXX: Should we fix this to known "good" vector sizes? - -- - mkVector :: Name -> Q [Dec] - mkVector name = + mkVecElt :: Name -> Q [Dec] + mkVecElt name = let t = conT name in - [d| instance KnownNat n => Elt (Vec n $t) where - type EltRepr (Vec n $t) = Vec n $t - {-# INLINE eltType #-} - {-# INLINE [1] fromElt #-} - {-# INLINE [1] toElt #-} - eltType = singletonScalarType - fromElt = id - toElt = id - |] + [d| instance VecElt $t |] -- ghci> $( stringE . show =<< reify ''CFloat ) -- TyConI (NewtypeD [] Foreign.C.Types.CFloat [] Nothing (NormalC Foreign.C.Types.CFloat [(Bang NoSourceUnpackedness NoSourceStrictness,ConT GHC.Types.Float)]) []) @@ -1102,7 +1109,7 @@ $(runQ $ do |] -- ss <- mapM mkSimple ( integralTypes ++ floatingTypes ++ nonNumTypes ) - vs <- mapM mkVector ( integralTypes ++ floatingTypes ++ tail nonNumTypes ) -- not Bool + vs <- mapM mkVecElt ( integralTypes ++ floatingTypes ++ tail nonNumTypes ) -- not Bool ns <- mapM mkNewtype newtypes return (concat ss ++ concat vs ++ concat ns) ) diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs b/src/Data/Array/Accelerate/Classes/RealFrac.hs index 16df98b3a..d2048e923 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs @@ -40,7 +40,6 @@ import Data.Array.Accelerate.Classes.Num import Data.Array.Accelerate.Classes.ToFloating import {-# SOURCE #-} Data.Array.Accelerate.Classes.RealFloat -- defaultProperFraction -import Data.Typeable import Data.Maybe import Text.Printf import Prelude ( ($), String, error, unlines, otherwise ) @@ -225,8 +224,7 @@ data IsIntegralDict a where isFloating :: forall a. Elt a => Maybe (IsFloatingDict (EltRepr a)) isFloating - | Just Refl <- eqT @a @(EltRepr a) - , TupRsingle t <- eltType @a + | TupRsingle t <- eltType @a , SingleScalarType s <- t , NumSingleType n <- s , FloatingNumType f <- n @@ -240,8 +238,7 @@ isFloating isIntegral :: forall a. Elt a => Maybe (IsIntegralDict (EltRepr a)) isIntegral - | Just Refl <- eqT @a @(EltRepr a) - , TupRsingle t <- eltType @a + | TupRsingle t <- eltType @a , SingleScalarType s <- t , NumSingleType n <- s , IntegralNumType i <- n diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index ed870490d..c10b923d9 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -2,6 +2,8 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RebindableSyntax #-} @@ -48,85 +50,119 @@ import Data.Array.Accelerate.Classes import Data.Array.Accelerate.Data.Functor import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Smart hiding (exp) import Data.Array.Accelerate.Type import Data.Complex ( Complex(..) ) import qualified Data.Complex as C +import Prelude (($)) import qualified Prelude as P - infix 6 ::+ -pattern (::+) :: (Elt a, Elt (Complex a)) => Exp a -> Exp a -> Exp (Complex a) -pattern r ::+ c = Pattern (r, c) +pattern (::+) :: Elt a => Exp a -> Exp a -> Exp (Complex a) +pattern r ::+ i <- (deconstructComplex -> (r, i)) + where (::+) = constructComplex {-# COMPLETE (::+) #-} --- 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. +-- Use an array-of-structs representation for complex numbers if possible. +-- This matches the standard C-style layout, but we can use this representation only at +-- specific types (not for any type 'a') as we can only have vectors of primitive type. +-- For other types, we use a structure-of-arrays representation. This is handled by the +-- ComplexRepr. We use the GADT ComplexR and function complexR to reconstruct +-- information on how the elements are represented. -- - -instance Elt (Complex Half) where - type EltRepr (Complex Half) = V2 Half - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = TupRsingle scalarType - toElt (V2 r i) = r :+ i - fromElt (r :+ i) = V2 r i - -instance Elt (Complex Float) where - type EltRepr (Complex Float) = V2 Float - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = TupRsingle scalarType - toElt (V2 r i) = r :+ i - fromElt (r :+ i) = V2 r i - -instance Elt (Complex Double) where - type EltRepr (Complex Double) = V2 Double +instance Elt a => Elt (Complex a) where + type EltRepr (Complex a) = ComplexRepr (EltRepr a) {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} - eltType = TupRsingle scalarType - toElt (V2 r i) = r :+ i - fromElt (r :+ i) = V2 r i - -instance Elt (Complex CFloat) where - type EltRepr (Complex CFloat) = V2 Float - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = TupRsingle scalarType - toElt (V2 r i) = CFloat r :+ CFloat i - fromElt (CFloat r :+ CFloat i) = V2 r i - -instance Elt (Complex CDouble) where - type EltRepr (Complex CDouble) = V2 Double - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = TupRsingle scalarType - toElt (V2 r i) = CDouble r :+ CDouble i - fromElt (CDouble r :+ CDouble i) = V2 r i - -instance (Lift Exp a, Elt (Plain a), Elt (Complex (Plain a))) => Lift Exp (Complex a) where + eltType = case complexR tp of + ComplexRvec s -> TupRsingle $ VectorScalarType $ VectorType 2 s + ComplexRtup -> TupRunit `TupRpair` tp `TupRpair` tp + where + tp = eltType @a + toElt = case complexR $ eltType @a of + ComplexRvec _ -> \(V2 r i) -> toElt r :+ toElt i + ComplexRtup -> \(((), r), i) -> toElt r :+ toElt i + fromElt (r :+ i) = case complexR $ eltType @a of + ComplexRvec _ -> V2 (fromElt r) (fromElt i) + ComplexRtup -> (((), fromElt r), fromElt i) + +type family ComplexRepr a where + ComplexRepr Half = V2 Half + ComplexRepr Float = V2 Float + ComplexRepr Double = V2 Double + ComplexRepr Int = V2 Int + ComplexRepr Int8 = V2 Int8 + ComplexRepr Int16 = V2 Int16 + ComplexRepr Int32 = V2 Int32 + ComplexRepr Int64 = V2 Int64 + ComplexRepr Word = V2 Word + ComplexRepr Word8 = V2 Word8 + ComplexRepr Word16 = V2 Word16 + ComplexRepr Word32 = V2 Word32 + ComplexRepr Word64 = V2 Word64 + ComplexRepr a = Tup2 a a + +data ComplexR a c where + ComplexRvec :: VecElt a => SingleType a -> ComplexR a (V2 a) + ComplexRtup :: ComplexR a (Tup2 a a) + +complexR :: TupleType a -> ComplexR a (ComplexRepr a) +complexR (TupRsingle (SingleScalarType (NumSingleType (FloatingNumType TypeHalf )))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (FloatingNumType TypeFloat )))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (FloatingNumType TypeDouble)))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt )))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt8 )))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt16 )))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt32 )))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt64 )))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord )))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord8 )))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord16)))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord32)))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord64)))) = ComplexRvec singleType +complexR (TupRsingle (SingleScalarType (NonNumSingleType TypeChar))) = ComplexRtup +complexR (TupRsingle (SingleScalarType (NonNumSingleType TypeBool))) = ComplexRtup +complexR (TupRsingle (VectorScalarType (_))) = ComplexRtup +complexR TupRunit = ComplexRtup +complexR TupRpair{} = ComplexRtup + +constructComplex :: forall a. Elt a => Exp a -> Exp a -> Exp (Complex a) +constructComplex r i = case complexR $ eltType @a of + ComplexRvec _ -> + let + r', i' :: Exp (EltRepr a) + r' = reExp @a @(EltRepr a) r + i' = reExp i + v :: Exp (V2 (EltRepr a)) + v = V2_ r' i' + in + reExp @(V2 (EltRepr a)) @(Complex a) $ v + ComplexRtup -> reExp $ T2 r i + +deconstructComplex :: forall a. Elt a => Exp (Complex a) -> (Exp a, Exp a) +deconstructComplex c = case complexR $ eltType @a of + ComplexRvec _ -> let V2_ r i = reExp @(Complex a) @(V2 (EltRepr a)) c in (reExp r, reExp i) + ComplexRtup -> let T2 r i = reExp c in (r, i) + +reExp :: EltRepr a ~ EltRepr b => Exp a -> Exp b +reExp (Exp e) = Exp e + +instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Complex a) where type Plain (Complex a) = Complex (Plain a) lift (r :+ i) = lift r ::+ lift i -instance (Elt a, Elt (Complex a)) => Unlift Exp (Complex (Exp a)) where +instance Elt a => Unlift Exp (Complex (Exp a)) where unlift (r ::+ i) = r :+ i -instance (Eq a, Elt (Complex a)) => Eq (Complex a) where +instance Eq a => Eq (Complex a) where r1 ::+ c1 == r2 ::+ c2 = r1 == r2 && c1 == c2 r1 ::+ c1 /= r2 ::+ c2 = r1 /= r2 || c1 /= c2 -instance (RealFloat a, Elt (Complex a)) => P.Num (Exp (Complex a)) where +instance 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)) @@ -139,7 +175,7 @@ instance (RealFloat a, Elt (Complex a)) => P.Num (Exp (Complex a)) where abs z = magnitude z ::+ 0 fromInteger n = fromInteger n ::+ 0 -instance (RealFloat a, Elt (Complex a)) => P.Fractional (Exp (Complex a)) where +instance RealFloat a => P.Fractional (Exp (Complex a)) where fromRational x = fromRational x ::+ 0 z / z' = (x*x''+y*y'') / d ::+ (y*x''-x*y'') / d where @@ -151,7 +187,7 @@ instance (RealFloat a, Elt (Complex a)) => P.Fractional (Exp (Complex a)) where k = - max (exponent x') (exponent y') d = x'*x'' + y'*y'' -instance (RealFloat a, Elt (Complex a)) => P.Floating (Exp (Complex a)) where +instance RealFloat a => P.Floating (Exp (Complex a)) where pi = pi ::+ 0 exp (x ::+ y) = let expx = exp x in expx * cos y ::+ expx * sin y @@ -228,7 +264,7 @@ instance Functor Complex where -- | The non-negative magnitude of a complex number -- -magnitude :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp a +magnitude :: RealFloat a => Exp (Complex a) -> Exp a magnitude (r ::+ i) = scaleFloat k (sqrt (sqr (scaleFloat mk r) + sqr (scaleFloat mk i))) where k = max (exponent r) (exponent i) @@ -240,13 +276,13 @@ magnitude (r ::+ i) = scaleFloat k (sqrt (sqr (scaleFloat mk r) + sqr (scaleFloa -- -- @since 1.3.0.0 -- -magnitude' :: (RealFloat a, Elt (Complex a)) => Exp (Complex a) -> Exp a +magnitude' :: RealFloat a => Exp (Complex a) -> Exp a magnitude' (r ::+ i) = 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, Elt (Complex a)) => Exp (Complex a) -> Exp a +phase :: RealFloat a => Exp (Complex a) -> Exp a phase z@(r ::+ i) = if z == 0 then 0 @@ -256,15 +292,15 @@ phase z@(r ::+ i) = -- 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 :: RealFloat a => Exp (Complex a) -> Exp (a,a) polar z = T2 (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) +mkPolar :: forall a. RealFloat a => Exp a -> Exp a -> Exp (Complex a) #else -mkPolar :: forall a. (Floating a, Elt (Complex a)) => Exp a -> Exp a -> Exp (Complex a) +mkPolar :: forall a. Floating a => Exp a -> Exp a -> Exp (Complex a) #endif mkPolar = lift2 (C.mkPolar :: Exp a -> Exp a -> Complex (Exp a)) @@ -272,26 +308,26 @@ mkPolar = lift2 (C.mkPolar :: Exp a -> Exp a -> Complex (Exp a)) -- @2*'pi'@). -- #if __GLASGOW_HASKELL__ <= 708 -cis :: forall a. (RealFloat a, Elt (Complex a)) => Exp a -> Exp (Complex a) +cis :: forall a. RealFloat a => Exp a -> Exp (Complex a) #else -cis :: forall a. (Floating a, Elt (Complex a)) => Exp a -> Exp (Complex a) +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, Elt (Complex a)) => Exp (Complex a) -> Exp a +real :: Elt a => Exp (Complex a) -> Exp a real (r ::+ _) = r -- | Return the imaginary part of a complex number -- -imag :: (Elt a, Elt (Complex a)) => Exp (Complex a) -> Exp a +imag :: Elt a => Exp (Complex a) -> Exp a imag (_ ::+ 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 :: Num a => Exp (Complex a) -> Exp (Complex a) conjugate z = real z ::+ (- imag z) diff --git a/src/Data/Array/Accelerate/Data/Monoid.hs b/src/Data/Array/Accelerate/Data/Monoid.hs index 57cc10e86..354e4bb60 100644 --- a/src/Data/Array/Accelerate/Data/Monoid.hs +++ b/src/Data/Array/Accelerate/Data/Monoid.hs @@ -42,7 +42,7 @@ 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.Pattern import Data.Array.Accelerate.Type #if __GLASGOW_HASKELL__ >= 800 import Data.Array.Accelerate.Data.Semigroup () diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 1d2bf758c..8784e58a7 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -939,6 +939,8 @@ evalPreOpenExp evalAcc pexp env aenv = Pair e1 e2 -> let !v1 = evalE e1 !v2 = evalE e2 in (v1, v2) + VecPack vecR e -> vecPack vecR $! evalE e + VecUnpack vecR e -> vecUnpack vecR $! evalE e IndexSlice slice slix sh -> restrict slice (evalE slix) (evalE sh) where diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index b9475db78..b2aec3891 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} #if __GLASGOW_HASKELL__ <= 800 {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} @@ -34,11 +36,13 @@ module Data.Array.Accelerate.Pattern ( pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, + pattern V2_, pattern V3_, pattern V4_, pattern V8_, pattern V16_, + ) where import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Type import Language.Haskell.TH hiding ( Exp ) import Language.Haskell.TH.Extra @@ -76,12 +80,12 @@ pattern a `Ix` b = a ::. b -- IsPattern instances for Shape nil and cons -- instance IsPattern Exp Z Z where - construct _ = Exp IndexNil + construct _ = constant Z destruct _ = Z instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where - construct (a :. b) = Exp (a `IndexCons` b) - destruct t = Exp (IndexTail t) :. Exp (IndexHead t) + construct (Exp a :. Exp b) = Exp $ SmartExp $ Pair a b + destruct (Exp t) = Exp (SmartExp $ Prj PairIdxLeft t) :. Exp (SmartExp $ Prj PairIdxRight t) -- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of the -- (unremarkable) boilerplate for us, but since the implementation is a little @@ -92,7 +96,6 @@ $(runQ $ do -- Generate instance declarations for IsPattern of the form: -- instance (Elt x, EltRepr x ~ (((), EltRepr a), EltRepr b), Elt a, Elt b,) => IsPattern Exp x (Exp a, Exp b) mkIsPattern :: Name -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] - mkIsPattern _ _ _ _ _ _ _ 1 = return [] mkIsPattern con cst repr smart prj nil pair n = do a <- newName "a" let @@ -189,59 +192,83 @@ $(runQ $ do return $ concat (ts ++ is) ) +-- Newtype to make difference between T and P instances clear +newtype VecPattern a = VecPattern a - -instance (Elt a, Elt (Vec 2 a), IsSingle (EltRepr a), EltRepr (Vec 2 a) ~ Vec 2 (EltRepr a)) => IsPattern Exp (Vec 2 a) (Exp a, Exp a) where - construct as = Exp $ SmartExp $ VecPack r tup +instance VecElt a => IsPattern Exp (Vec 2 a) (VecPattern (Exp a, Exp a)) where + construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup where r = vecR2 $ singleType @(EltRepr a) Exp tup = construct as :: Exp (a, a) - destruct e = destruct e' + destruct e = VecPattern $ destruct e' where e' :: Exp (a, a) e' = Exp $ SmartExp $ VecUnpack r $ unExp e r = vecR2 $ singleType @(EltRepr a) -instance (Elt a, Elt (Vec 3 a), IsSingle (EltRepr a), EltRepr (Vec 3 a) ~ Vec 3 (EltRepr a)) => IsPattern Exp (Vec 3 a) (Exp a, Exp a, Exp a) where - construct as = Exp $ SmartExp $ VecPack r tup +instance VecElt a => IsPattern Exp (Vec 3 a) (VecPattern (Exp a, Exp a, Exp a)) where + construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup where r = vecR3 $ singleType @(EltRepr a) Exp tup = construct as :: Exp (a, a, a) - destruct e = destruct e' + destruct e = VecPattern $ destruct e' where e' :: Exp (a, a, a) e' = Exp $ SmartExp $ VecUnpack r $ unExp e r = vecR3 $ singleType @(EltRepr a) -instance (Elt a, Elt (Vec 4 a), IsSingle (EltRepr a), EltRepr (Vec 4 a) ~ Vec 4 (EltRepr a)) => IsPattern Exp (Vec 4 a) (Exp a, Exp a, Exp a, Exp a) where - construct as = Exp $ SmartExp $ VecPack r tup +instance VecElt a => IsPattern Exp (Vec 4 a) (VecPattern (Exp a, Exp a, Exp a, Exp a)) where + construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup where r = vecR4 $ singleType @(EltRepr a) Exp tup = construct as :: Exp (a, a, a, a) - destruct e = destruct e' + destruct e = VecPattern $ destruct e' where e' :: Exp (a, a, a, a) e' = Exp $ SmartExp $ VecUnpack r $ unExp e r = vecR4 $ singleType @(EltRepr a) -instance (Elt a, Elt (Vec 8 a), IsSingle (EltRepr a), EltRepr (Vec 8 a) ~ Vec 8 (EltRepr a)) => IsPattern Exp (Vec 8 a) (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a) where - construct as = Exp $ SmartExp $ VecPack r tup +instance VecElt a => IsPattern Exp (Vec 8 a) (VecPattern (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)) where + construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup where r = vecR8 $ singleType @(EltRepr a) Exp tup = construct as :: Exp (a, a, a, a, a, a, a, a) - destruct e = destruct e' + destruct e = VecPattern $ destruct e' where e' :: Exp (a, a, a, a, a, a, a, a) e' = Exp $ SmartExp $ VecUnpack r $ unExp e r = vecR8 $ singleType @(EltRepr a) -instance (Elt a, Elt (Vec 16 a), IsSingle (EltRepr a), EltRepr (Vec 16 a) ~ Vec 16 (EltRepr a)) => IsPattern Exp (Vec 16 a) (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a) where - construct as = Exp $ SmartExp $ VecPack r tup +instance VecElt a => IsPattern Exp (Vec 16 a) (VecPattern (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)) where + construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup where r = vecR16 $ singleType @(EltRepr a) Exp tup = construct as :: Exp (a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a) - destruct e = destruct e' + destruct e = VecPattern $ destruct e' where e' :: Exp (a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a) e' = Exp $ SmartExp $ VecUnpack r $ unExp e r = vecR16 $ singleType @(EltRepr a) + +pattern V2_ :: VecElt a => Exp a -> Exp a -> Exp (Vec 2 a) +pattern V2_ a b = Pattern (VecPattern (a, b)) +{-# COMPLETE V2_ #-} + +pattern V3_ :: VecElt a => Exp a -> Exp a -> Exp a -> Exp (Vec 3 a) +pattern V3_ a b c = Pattern (VecPattern (a, b, c)) +{-# COMPLETE V3_ #-} + +pattern V4_ :: VecElt a => Exp a -> Exp a -> Exp a -> Exp a -> Exp (Vec 4 a) +pattern V4_ a b c d = Pattern (VecPattern (a, b, c, d)) +{-# COMPLETE V4_ #-} + +pattern V8_ :: VecElt a => Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp (Vec 8 a) +pattern V8_ a b c d e f g h = Pattern (VecPattern (a, b, c, d, e, f, g, h)) +{-# COMPLETE V8_ #-} + +pattern V16_ :: VecElt a + => Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> + Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp (Vec 16 a) +pattern V16_ a b c d e f g h + i j k l m n o p = Pattern (VecPattern (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) +{-# COMPLETE V16_ #-} diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 6762f9698..7885c1bcc 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -1147,7 +1147,7 @@ indexTail (Exp x) = exp $ Prj PairIdxLeft x nilTup :: SmartExp () nilTup = SmartExp Nil -snocTup :: (Typeable a, Elt b) => SmartExp a -> Exp b -> SmartExp (a, EltRepr b) +snocTup :: Elt b => SmartExp a -> Exp b -> SmartExp (a, EltRepr b) snocTup a (Exp b) = SmartExp $ Pair a b tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b) diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 5bb465318..6ffbccc24 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -718,6 +718,8 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp Prj idx e -> cvtPrj idx (cvt e) Nil -> AST.Nil Pair e1 e2 -> AST.Pair (cvt e1) (cvt e2) + VecPack vec e -> AST.VecPack vec (cvt e) + VecUnpack vec e -> AST.VecUnpack vec (cvt e) ToIndex shr sh ix -> AST.ToIndex shr (cvt sh) (cvt ix) FromIndex shr sh e -> AST.FromIndex shr (cvt sh) (cvt e) Cond e1 e2 e3 -> AST.Cond (cvt e1) (cvt e2) (cvt e3) @@ -1639,6 +1641,8 @@ makeOccMapSharingExp config accOccMap expOccMap = travE Nil -> return (Nil, 1) Pair e1 e2 -> travE2 Pair e1 e2 Prj i e -> travE1 (Prj i) e + VecPack vec e -> travE1 (VecPack vec) e + VecUnpack vec e -> travE1 (VecUnpack vec) e ToIndex shr sh ix -> travE2 (ToIndex shr) sh ix FromIndex shr sh e -> travE2 (FromIndex shr) sh e Cond e1 e2 e3 -> travE3 Cond e1 e2 e3 @@ -2482,6 +2486,8 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp Pair e1 e2 -> travE2 Pair e1 e2 Nil -> reconstruct Nil noNodeCounts Prj i e -> travE1 (Prj i) e + VecPack vec e -> travE1 (VecPack vec) e + VecUnpack vec e -> travE1 (VecUnpack vec) e ToIndex shr sh ix -> travE2 (ToIndex shr) sh ix FromIndex shr sh e -> travE2 (FromIndex shr) sh e Cond e1 e2 e3 -> travE3 Cond e1 e2 e3 From e79659931e817fb36a3c40923e84f4286e899fa7 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Tue, 24 Mar 2020 12:20:35 +0100 Subject: [PATCH 168/316] Add remark on counting in acc functions --- src/Data/Array/Accelerate/Trafo/Shrink.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 7d20298c5..a97773e3e 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -405,7 +405,7 @@ usesOfPreAcc withShape countAcc idx = count Alet lhs bnd body -> countA bnd + countAcc withShape (weakenWithLHS lhs >:> idx) body Apair a1 a2 -> countA a1 + countA a2 Anil -> 0 - Apply _ _ a -> countA a + Apply _ _ a -> countA a --- XXX: It is suspicious that we don't descend into the function here. Same for awhile. Aforeign _ _ a -> countA a Acond p t e -> countE p + countA t + countA e Awhile _ _ a -> countA a From e2a734c6d96dba6674e55c5bddbb11b8d0fcaf71 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Tue, 24 Mar 2020 12:21:25 +0100 Subject: [PATCH 169/316] Increase reduction depth for type checking tuples Fix true / false patterns --- src/Data/Array/Accelerate/Classes/Bounded.hs | 8 +++++++- src/Data/Array/Accelerate/Classes/Eq.hs | 12 +++++++++--- src/Data/Array/Accelerate/Classes/Ord.hs | 8 +++++++- 3 files changed, 23 insertions(+), 5 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/Bounded.hs b/src/Data/Array/Accelerate/Classes/Bounded.hs index 187cf0150..82c31b96a 100644 --- a/src/Data/Array/Accelerate/Classes/Bounded.hs +++ b/src/Data/Array/Accelerate/Classes/Bounded.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -freduction-depth=100 #-} -- | -- Module : Data.Array.Accelerate.Classes.Bounded -- Copyright : [2016..2019] The Accelerate Team @@ -135,6 +135,12 @@ instance P.Bounded (Exp CUChar) where minBound = mkBitcast (mkMinBound @Word8) maxBound = mkBitcast (mkMaxBound @Word8) +-- To support 16-tuples, we must set the maximum recursion depth of the type +-- checker higher. The default is 51, which appears to be a problem for +-- 16-tuples (15-tuples do work). Hence we set a compiler flag at the top +-- of this file: -freduction-depth=100 +-- + $(runQ $ do let mkInstance :: Int -> Q [Dec] diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index b19e8aa03..60fc32c94 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -freduction-depth=100 #-} -- | -- Module : Data.Array.Accelerate.Classes.Eq -- Copyright : [2016..2019] The Accelerate Team @@ -39,10 +39,10 @@ import qualified Prelude as P pattern True_ :: Exp Bool -pattern True_ = Exp (Const True) +pattern True_ = Exp (SmartExp (Const (SingleScalarType (NonNumSingleType TypeBool)) True)) pattern False_ :: Exp Bool -pattern False_ = Exp (Const False) +pattern False_ = Exp (SmartExp (Const (SingleScalarType (NonNumSingleType TypeBool)) False)) infix 4 == @@ -105,6 +105,12 @@ instance P.Eq (Exp a) where preludeError :: String -> String -> a preludeError x y = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x y) +-- To support 16-tuples, we must set the maximum recursion depth of the type +-- checker higher. The default is 51, which appears to be a problem for +-- 16-tuples (15-tuples do work). Hence we set a compiler flag at the top +-- of this file: -freduction-depth=100 +-- + $(runQ $ do let integralTypes :: [Name] diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 11b69f650..f64bbc698 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans -freduction-depth=100 #-} -- | -- Module : Data.Array.Accelerate.Classes.Ord -- Copyright : [2016..2019] The Accelerate Team @@ -149,6 +149,12 @@ preludeError x y , "hierarchy." ] +-- To support 16-tuples, we must set the maximum recursion depth of the type +-- checker higher. The default is 51, which appears to be a problem for +-- 16-tuples (15-tuples do work). Hence we set a compiler flag at the top +-- of this file: -freduction-depth=100 +-- + $(runQ $ do let integralTypes :: [Name] From 3814227fef578c8293e26bfc94288746b38cce89 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Tue, 24 Mar 2020 15:16:14 +0100 Subject: [PATCH 170/316] Remove Product --- accelerate.cabal | 1 - .../Array/Accelerate => icebox}/Product.hs | 0 src/Data/Array/Accelerate.hs | 3 +- src/Data/Array/Accelerate/AST.hs | 13 ++----- src/Data/Array/Accelerate/Array/Lifted.hs | 18 ---------- src/Data/Array/Accelerate/Array/Sugar.hs | 34 ------------------- src/Data/Array/Accelerate/Data/Either.hs | 2 +- src/Data/Array/Accelerate/Data/Maybe.hs | 2 +- src/Data/Array/Accelerate/Data/Ratio.hs | 2 -- .../Accelerate/Test/NoFib/Prelude/SIMD.hs | 1 - src/Data/Array/Accelerate/Trafo/Normalise.hs | 1 - src/Data/Array/Accelerate/Trafo/Vectorise.hs | 7 ---- 12 files changed, 5 insertions(+), 79 deletions(-) rename {src/Data/Array/Accelerate => icebox}/Product.hs (100%) diff --git a/accelerate.cabal b/accelerate.cabal index 64aec140c..d86e63cda 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -333,7 +333,6 @@ Library Data.Array.Accelerate.Error Data.Array.Accelerate.Lifetime Data.Array.Accelerate.Pretty - Data.Array.Accelerate.Product Data.Array.Accelerate.Smart Data.Array.Accelerate.Trafo Data.Array.Accelerate.Type diff --git a/src/Data/Array/Accelerate/Product.hs b/icebox/Product.hs similarity index 100% rename from src/Data/Array/Accelerate/Product.hs rename to icebox/Product.hs diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 4064c6d3e..fd6f728c8 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -336,7 +336,7 @@ module Data.Array.Accelerate ( -- ** Pattern synonyms -- $pattern_synonyms -- - pattern Pattern, IsProduct, IsTuple, + pattern Pattern, pattern T2, pattern T3, pattern T4, pattern T5, pattern T6, pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, @@ -424,7 +424,6 @@ import Data.Array.Accelerate.Classes import Data.Array.Accelerate.Language import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Pretty () -- show instances import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Array.Sugar as S diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 6bddfe5fa..89646f935 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -84,7 +84,7 @@ module Data.Array.Accelerate.AST ( -- * Typed de Bruijn indices - Idx(..), idxToInt, tupleIdxToInt, Var(..), Vars(..), ArrayVar, ArrayVars, ExpVar, ExpVars, + Idx(..), idxToInt, Var(..), Vars(..), ArrayVar, ArrayVars, ExpVar, ExpVars, evars, varsType, LeftHandSide(..), ALeftHandSide, ELeftHandSide, -- * Valuation environment @@ -111,7 +111,7 @@ module Data.Array.Accelerate.AST ( -- TemplateHaskell LiftAcc, - liftIdx, liftTupleIdx, + liftIdx, liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp, liftALhs, liftELhs, liftArray, liftArraysR, liftTupleType, @@ -154,7 +154,6 @@ import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Array.Representation import qualified Data.Array.Accelerate.Array.Sugar as Sugar 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 @@ -177,10 +176,6 @@ 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 -- ------------ @@ -1653,10 +1648,6 @@ 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 lhs f) = [|| Alam $$(liftALhs lhs) $$(liftPreOpenAfun liftA f) ||] diff --git a/src/Data/Array/Accelerate/Array/Lifted.hs b/src/Data/Array/Accelerate/Array/Lifted.hs index 4001ae5d8..5f3079fc1 100644 --- a/src/Data/Array/Accelerate/Array/Lifted.hs +++ b/src/Data/Array/Accelerate/Array/Lifted.hs @@ -38,7 +38,6 @@ 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 @@ -64,23 +63,6 @@ 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) - instance (Arrays t, Typeable (ArrRepr (Vector' t))) => Arrays (Vector' t) where type ArrRepr (Vector' t) = ArrRepr (TupleRepr (Vector' t)) arrays _ = arrs (prod (Proxy :: Proxy Arrays) (undefined :: Vector' t)) diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index f55f76442..5edeb5ca1 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -54,10 +54,6 @@ module Data.Array.Accelerate.Array.Sugar ( -- * Array shape query, indexing, and conversions shape, reshape, (!), (!!), allocateArray, fromFunction, fromFunctionM, fromList, toList, concatVectors, - -- * Tuples of expressions - TupleR, TupleRepr, tuple, - Tuple(..), IsTuple, fromTuple, toTuple, - -- * Miscellaneous showShape, Foreign(..), sliceShape, enumSlices, VecElt, @@ -82,7 +78,6 @@ import qualified GHC.Exts as GHC import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Error import Data.Array.Accelerate.Orphans () -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Array.Representation as Repr @@ -422,35 +417,6 @@ class Typeable asm => Foreign asm where liftForeign _ = $internalError "liftForeign" "not supported by this backend" --- Tuple representation --- -------------------- - --- |The tuple representation is equivalent to the product representation. --- -type TupleRepr a = ProdRepr a -type TupleR a = ProdR Elt a -type IsTuple = IsProduct Elt --- type IsAtuple = IsProduct Arrays - --- |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) - - --- |Tuple reification --- -tuple :: forall tup. IsTuple tup => TupleR (TupleRepr tup) -tuple = prod @Elt @tup - -fromTuple :: IsTuple tup => tup -> TupleRepr tup -fromTuple = fromProd @Elt - -toTuple :: IsTuple tup => TupleRepr tup -> tup -toTuple = toProd @Elt - - -- Arrays -- ------ diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index 2f124156f..a427ac858 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -151,7 +151,7 @@ tag x = t where T3 t _ _ = asTuple x instance (Elt a, Elt b) => Elt (Either a b) where - type EltRepr (Either a b) = TupleRepr (Word8, EltRepr a, EltRepr b) + type EltRepr (Either a b) = Tup3 Word8 (EltRepr a) (EltRepr b) {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index daa94072c..8ebf345c9 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -154,7 +154,7 @@ tag (Exp x) = Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxLeft x instance Elt a => Elt (Maybe a) where - type EltRepr (Maybe a) = TupleRepr (Word8, EltRepr a) + type EltRepr (Maybe a) = Tup2 Word8 (EltRepr a) {-# INLINE eltType #-} {-# INLINE [1] toElt #-} {-# INLINE [1] fromElt #-} diff --git a/src/Data/Array/Accelerate/Data/Ratio.hs b/src/Data/Array/Accelerate/Data/Ratio.hs index 10b8441a3..a7fbe7e88 100644 --- a/src/Data/Array/Accelerate/Data/Ratio.hs +++ b/src/Data/Array/Accelerate/Data/Ratio.hs @@ -34,7 +34,6 @@ import Data.Array.Accelerate.Language import Data.Array.Accelerate.Orphans () import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Enum @@ -55,7 +54,6 @@ import qualified Prelude as P instance Elt a => Elt (Ratio a) -instance Elt a => IsProduct Elt (Ratio a) pattern (:%) :: Elt a => Exp a -> Exp a -> Exp (Ratio a) pattern (:%) { numerator, denominator } = Pattern (numerator, denominator) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs index 485873ddd..7b506c7df 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs @@ -30,7 +30,6 @@ import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Type import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Product import Hedgehog import qualified Hedgehog.Gen as Gen diff --git a/src/Data/Array/Accelerate/Trafo/Normalise.hs b/src/Data/Array/Accelerate/Trafo/Normalise.hs index 69523917b..7124e9889 100644 --- a/src/Data/Array/Accelerate/Trafo/Normalise.hs +++ b/src/Data/Array/Accelerate/Trafo/Normalise.hs @@ -17,7 +17,6 @@ module Data.Array.Accelerate.Trafo.Normalise ( import Prelude hiding ( exp ) import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Trafo.Substitution diff --git a/src/Data/Array/Accelerate/Trafo/Vectorise.hs b/src/Data/Array/Accelerate/Trafo/Vectorise.hs index 4333c1735..deb82471c 100644 --- a/src/Data/Array/Accelerate/Trafo/Vectorise.hs +++ b/src/Data/Array/Accelerate/Trafo/Vectorise.hs @@ -58,7 +58,6 @@ import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Trafo.Base import Data.Array.Accelerate.Pretty () import Data.Array.Accelerate.Trafo.Substitution -import Data.Array.Accelerate.Product import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Classes.Eq as S import qualified Data.Array.Accelerate.Language as S @@ -124,12 +123,6 @@ instance Shape sh => Slice (None sh) where type FullShape (None sh) = sh sliceIndex _ = sliceNoneIndex (undefined :: sh) -instance Shape sh => IsProduct Elt (None sh) where - type ProdRepr (None sh) = ((),sh) - fromProd _ (None sh) = ((),sh) - toProd _ ((),sh) = None sh - prod _ _ = ProdRsnoc ProdRunit - -- Lifting terms -- ------------- From 48a944894cd20d25379270c70e3168e60a950b0a Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Tue, 24 Mar 2020 16:41:13 +0100 Subject: [PATCH 171/316] Remove Typeable --- src/Data/Array/Accelerate/AST.hs | 6 --- src/Data/Array/Accelerate/Array/Data.hs | 4 +- src/Data/Array/Accelerate/Array/Lifted.hs | 5 +-- src/Data/Array/Accelerate/Array/Sugar.hs | 13 +++---- src/Data/Array/Accelerate/Language.hs | 22 +++-------- src/Data/Array/Accelerate/Smart.hs | 38 ++++++++----------- src/Data/Array/Accelerate/Trafo/Simplify.hs | 1 - src/Data/Array/Accelerate/Trafo/Vectorise.hs | 4 +- src/Data/Array/Accelerate/Type.hs | 39 +------------------- 9 files changed, 30 insertions(+), 102 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 89646f935..9b53eb9c8 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -128,7 +127,6 @@ module Data.Array.Accelerate.AST ( --standard library import Control.DeepSeq import Control.Monad.ST -import Data.Typeable import Data.List ( intercalate ) import Foreign.ForeignPtr import Foreign.Marshal @@ -185,7 +183,6 @@ idxToInt (SuccIdx idx) = 1 + idxToInt idx data Val env where Empty :: Val () Push :: Val env -> t -> Val (env, t) -deriving instance Typeable Val push :: Val env -> (LeftHandSide s arrs env env', arrs) -> Val env' push env (LeftHandSideWildcard _, _ ) = env @@ -230,9 +227,6 @@ newtype OpenAcc aenv t = OpenAcc (PreOpenAcc OpenAcc aenv t) -- type Acc = OpenAcc () -deriving instance Typeable PreOpenAcc -deriving instance Typeable OpenAcc - type ALeftHandSide = LeftHandSide ArrayR type ELeftHandSide = LeftHandSide ScalarType diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index fe5f393ab..a354ea084 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -63,7 +62,6 @@ import Control.DeepSeq import Data.Bits import Data.IORef import Data.Primitive ( sizeOf# ) -import Data.Typeable ( Typeable ) import Foreign.ForeignPtr import Foreign.Storable import Language.Haskell.TH hiding ( Type ) @@ -154,7 +152,7 @@ type family ScalarDataRepr tp where -- Utilities for working with the type families & type class instances data ScalarDict e where - ScalarDict :: (Typeable e, Typeable (ScalarDataRepr e), Storable (ScalarDataRepr e), Prim (ScalarDataRepr e), ArrayData e ~ ScalarData e) => ScalarDict e + ScalarDict :: (Storable (ScalarDataRepr e), Prim (ScalarDataRepr e), ArrayData e ~ ScalarData e) => ScalarDict e {-# INLINE scalarDict #-} scalarDict :: ScalarType e -> (Int, ScalarDict e) diff --git a/src/Data/Array/Accelerate/Array/Lifted.hs b/src/Data/Array/Accelerate/Array/Lifted.hs index 5f3079fc1..957e4695b 100644 --- a/src/Data/Array/Accelerate/Array/Lifted.hs +++ b/src/Data/Array/Accelerate/Array/Lifted.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} @@ -35,7 +34,6 @@ module Data.Array.Accelerate.Array.Lifted ( ) where import Prelude hiding ( concat ) -import Data.Typeable -- friends import Data.Array.Accelerate.Array.Sugar @@ -50,7 +48,6 @@ import qualified Data.Array.Accelerate.Array.Representation as Repr -- 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) @@ -63,7 +60,7 @@ type instance LiftedTupleRepr (b, a) = (LiftedTupleRepr b, Vector' a) type LiftedArray sh e = Vector' (Array sh e) -instance (Arrays t, Typeable (ArrRepr (Vector' t))) => Arrays (Vector' t) where +instance Arrays t => Arrays (Vector' t) where type ArrRepr (Vector' t) = ArrRepr (TupleRepr (Vector' t)) arrays _ = arrs (prod (Proxy :: Proxy Arrays) (undefined :: Vector' t)) where diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 5edeb5ca1..754e619e3 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -3,7 +3,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -96,14 +95,14 @@ import qualified Data.Array.Accelerate.Array.Representation as Repr -- | Rank-0 index -- data Z = Z - deriving (Typeable, Show, Eq) + deriving (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) + deriving 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.: @@ -137,7 +136,7 @@ instance (Show sh, Show sz) => Show (sh :. sz) where -- 'Data.Array.Accelerate.Language.replicate' for examples. -- data All = All - deriving (Typeable, Show, Eq) + deriving (Show, Eq) -- | Marker for arbitrary dimensions in 'Data.Array.Accelerate.Language.slice' -- and 'Data.Array.Accelerate.Language.replicate' descriptors. @@ -149,7 +148,7 @@ data All = All -- 'Data.Array.Accelerate.Language.replicate' for examples. -- data Any sh = Any - deriving (Typeable, Show, Eq) + deriving (Show, Eq) -- | Marker for splitting along an entire dimension in division descriptors. -- @@ -158,7 +157,7 @@ data Any sh = Any -- divided along this dimension forming the elements of the output sequence. -- data Split = Split - deriving (Typeable, Show, Eq) + deriving (Show, Eq) -- | Marker for arbitrary shapes in slices descriptors, where it is desired to -- split along an unknown number of dimensions. @@ -170,7 +169,7 @@ data Split = Split -- > vectors = toSeq (Divide :. All) -- data Divide sh = Divide - deriving (Typeable, Show, Eq) + deriving (Show, Eq) -- Scalar elements -- --------------- diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 0b323ad3b..d2c49de9f 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -125,7 +125,6 @@ import Data.Array.Accelerate.Classes.Ord -- standard libraries import Prelude ( ($), (.) ) -import Data.Typeable -- $setup -- >>> :seti -XFlexibleContexts @@ -168,23 +167,12 @@ import Data.Typeable -- >>> let tup = use (vec, mat) :: Acc (Vector Int, Matrix Int) -- use :: forall arrays. Arrays arrays => arrays -> Acc arrays -use arrs = Acc acc +use = Acc . use' (arrays @arrays) . fromArr where - HasTypeable acc = use' (arrays @arrays) $ fromArr arrs - - use' :: ArraysR a -> a -> HasTypeable a - use' TupRunit () = HasTypeable $ SmartAcc $ Anil - use' (TupRsingle repr@(ArrayR shr t)) a - | TypeableDict <- typeableDict $ Repr.shapeType shr - , TypeableDict <- typeableDict t = HasTypeable $ SmartAcc $ Use repr a - use' (TupRpair r1 r2) (a1, a2) - | HasTypeable acc1 <- use' r1 a1 - , HasTypeable acc2 <- use' r2 a2 = HasTypeable $ SmartAcc $ acc1 `Apair` acc2 - --- Internal data type for 'use' to capture the 'Typeable' type class -data HasTypeable a where - HasTypeable :: Typeable a => SmartAcc a -> HasTypeable a - + use' :: ArraysR a -> a -> SmartAcc a + use' TupRunit () = SmartAcc $ Anil + use' (TupRsingle repr@ArrayR{}) a = SmartAcc $ Use repr a + use' (TupRpair r1 r2) (a1, a2) = SmartAcc $ use' r1 a1 `Apair` use' r2 a2 -- | Construct a singleton (one element) array from a scalar value (or tuple of -- scalar values). diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 7885c1bcc..5f68aff64 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -73,7 +72,6 @@ module Data.Array.Accelerate.Smart ( -- standard library import Prelude hiding ( exp ) import Data.Kind -import Data.Typeable -- friends import Data.Array.Accelerate.Type @@ -275,7 +273,6 @@ import GHC.TypeNats newtype Acc a = Acc (SmartAcc (ArrRepr a)) newtype SmartAcc a = SmartAcc (PreSmartAcc SmartAcc SmartExp a) -deriving instance Typeable Acc -- The level of lambda-bound variables. The root has level 0; then it increases with each bound @@ -651,7 +648,6 @@ deriving instance Typeable Seq -- newtype Exp t = Exp (SmartExp (EltRepr t)) newtype SmartExp t = SmartExp (PreSmartExp SmartAcc SmartExp t) -deriving instance Typeable Exp -- | Scalar expressions to parametrise collective array operations, themselves parameterised over -- the type of collective array operations. @@ -743,11 +739,11 @@ data PreSmartExp acc exp t where Undef :: ScalarType t -> PreSmartExp acc exp t - Coerce :: (Typeable a, Typeable b, BitSizeEq a b) - => ScalarType a - -> ScalarType b - -> exp a - -> PreSmartExp acc exp b + Coerce :: BitSizeEq a b + => ScalarType a + -> ScalarType b + -> exp a + -> PreSmartExp acc exp b class HasExpType f where expType :: f t -> TupleType t @@ -1082,14 +1078,12 @@ prj15 = prj14 . prjTail -- change without the need to generate fresh code. -- constant :: forall e. Elt e => e -> Exp e -constant = Exp . snd . go (eltType @e) . fromElt +constant = Exp . go (eltType @e) . fromElt where - go :: TupleType t -> t -> (TypeableDict t, SmartExp t) - go TupRunit () = (TypeableDict, SmartExp $ Nil) - go (TupRsingle tp) c = (scalarTypeableDict tp, SmartExp $ Const tp c) - go (TupRpair t1 t2) (c1, c2) - | (TypeableDict, e1) <- go t1 c1 - , (TypeableDict, e2) <- go t2 c2 = (TypeableDict, SmartExp $ e1 `Pair` e2) + go :: TupleType t -> t -> SmartExp t + go TupRunit () = SmartExp $ Nil + go (TupRsingle tp) c = SmartExp $ Const tp c + go (TupRpair t1 t2) (c1, c2) = SmartExp $ go t1 c1 `Pair` go t2 c2 -- | 'undef' can be used anywhere a constant is expected, and indicates that the -- consumer of the value can receive an unspecified bit pattern. @@ -1115,14 +1109,12 @@ constant = Exp . snd . go (eltType @e) . fromElt -- @since 1.2.0.0 -- undef :: forall e. Elt e => Exp e -undef = Exp $ snd $ go $ eltType @e +undef = Exp $ go $ eltType @e where - go :: TupleType t -> (TypeableDict t, SmartExp t) - go TupRunit = (TypeableDict, SmartExp $ Nil) - go (TupRsingle t) = (scalarTypeableDict t, SmartExp $ Undef t) - go (TupRpair t1 t2) - | (TypeableDict, e1) <- go t1 - , (TypeableDict, e2) <- go t2 = (TypeableDict, SmartExp $ Pair e1 e2) + go :: TupleType t -> SmartExp t + go TupRunit = SmartExp $ Nil + go (TupRsingle t) = SmartExp $ Undef t + go (TupRpair t1 t2) = SmartExp $ go t1 `Pair` go t2 -- | Get the innermost dimension of a shape. -- diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index 5099f4201..f43aeb437 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -33,7 +33,6 @@ import Control.Applicative hiding ( Const ) import Control.Lens hiding ( Const, ix ) import Data.Maybe import Data.Monoid -import Data.Typeable import Text.Printf import Prelude hiding ( exp, iterate ) diff --git a/src/Data/Array/Accelerate/Trafo/Vectorise.hs b/src/Data/Array/Accelerate/Trafo/Vectorise.hs index deb82471c..b61d5b7d2 100644 --- a/src/Data/Array/Accelerate/Trafo/Vectorise.hs +++ b/src/Data/Array/Accelerate/Trafo/Vectorise.hs @@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -45,7 +44,6 @@ module Data.Array.Accelerate.Trafo.Vectorise ( import Prelude hiding ( exp, replicate, concat ) import qualified Prelude as P -import Data.Typeable import Control.Applicative hiding ( Const ) import Data.Maybe @@ -108,7 +106,7 @@ type VectoriseAcc acc = forall aenv aenv' t. -> LiftedAcc acc aenv' t data None sh = None sh - deriving (Typeable, Show, Eq) + deriving (Show, Eq) type instance EltRepr (None sh) = EltRepr sh diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index 11bb0cda8..4e3b4cb52 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} @@ -83,7 +82,6 @@ import Data.Primitive.ByteArray import Data.Primitive.Types import Data.Text.Prettyprint.Doc import Data.Type.Equality -import Data.Typeable import Data.Word import Foreign.C.Types import Foreign.Storable ( Storable ) @@ -118,9 +116,6 @@ data NonNumDict a where NonNumDict :: ( Bounded a, Eq a, Ord a, Show a, Storable a ) => NonNumDict a -data TypeableDict a where - TypeableDict :: Typeable a => TypeableDict a - -- Scalar type representation -- @@ -255,7 +250,7 @@ class IsScalar a => IsSingle a where -- | All scalar types -- -class Typeable a => IsScalar a where +class IsScalar a where scalarType :: ScalarType a @@ -283,37 +278,6 @@ nonNumDict :: NonNumType a -> NonNumDict a nonNumDict TypeBool = NonNumDict nonNumDict TypeChar = NonNumDict -typeableDict :: TupleType tp -> TypeableDict tp -typeableDict TupRunit = TypeableDict -typeableDict (TupRpair t1 t2) - | TypeableDict <- typeableDict t1 - , TypeableDict <- typeableDict t2 = TypeableDict -typeableDict (TupRsingle tp) = scalarTypeableDict tp - -scalarTypeableDict :: ScalarType tp -> TypeableDict tp -scalarTypeableDict (SingleScalarType tp) = singleTypeableDict tp -scalarTypeableDict (VectorScalarType (VectorType _ tp)) - | TypeableDict <- singleTypeableDict tp = TypeableDict - -singleTypeableDict :: SingleType tp -> TypeableDict tp -singleTypeableDict (NumSingleType (IntegralNumType tp)) = case tp of - TypeInt -> TypeableDict - TypeInt8 -> TypeableDict - TypeInt16 -> TypeableDict - TypeInt32 -> TypeableDict - TypeInt64 -> TypeableDict - TypeWord -> TypeableDict - TypeWord8 -> TypeableDict - TypeWord16 -> TypeableDict - TypeWord32 -> TypeableDict - TypeWord64 -> TypeableDict -singleTypeableDict (NumSingleType (FloatingNumType tp)) = case tp of - TypeHalf -> TypeableDict - TypeFloat -> TypeableDict - TypeDouble -> TypeableDict -singleTypeableDict (NonNumSingleType TypeChar) = TypeableDict -singleTypeableDict (NonNumSingleType TypeBool) = TypeableDict - showType :: TupleType tp -> ShowS showType TupRunit = showString "()" showType (TupRsingle tp) = showString $ showScalarType tp @@ -452,7 +416,6 @@ type family BitSize a :: Nat -- which redundant for our use case (derivable from type level information). -- data Vec (n::Nat) a = Vec ByteArray# - deriving Typeable type role Vec nominal representational From b896c9af6d5b45ca1bb83b4c2ce4c680f1561fcf Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 25 Mar 2020 16:29:12 +0100 Subject: [PATCH 172/316] Fix value of ignore It accidentally consisted of zeros instead of -1 --- src/Data/Array/Accelerate/Interpreter.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 8784e58a7..c3cc9af6e 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -597,11 +597,7 @@ permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR sh' = shape def n' = size shr' sh' - ignore' :: ShapeR sh -> sh - ignore' ShapeRz = () - ignore' (ShapeRsnoc shr) = (ignore' shr, 0) - - ignore = ignore' shr' + ignore' = ignore shr' -- (adata, _) = runArrayData $ do aout <- newArrayData tp n' @@ -620,7 +616,7 @@ permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR i = toIndex shr sh src j = toIndex shr' sh' dst in - unless (shapeEq shr' dst ignore) $ do + unless (shapeEq shr' dst ignore') $ do let x = ain i y <- unsafeReadArrayData tp aout j unsafeWriteArrayData tp aout j (f x y) From fd3f121e8c4d8acd0ece83a049f6ccd44f8b2709 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 25 Mar 2020 16:29:29 +0100 Subject: [PATCH 173/316] Fix intersect and union --- src/Data/Array/Accelerate/Language.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index d2c49de9f..9e4672935 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1297,7 +1297,7 @@ intersect' Repr.ShapeRz _ _ = SmartExp Nil intersect' (Repr.ShapeRsnoc shr) (unPair -> (xs, x)) (unPair -> (ys, y)) = SmartExp $ intersect' shr xs ys `Pair` - SmartExp (PrimApp (PrimMax singleType) $ SmartExp $ Pair x y) + SmartExp (PrimApp (PrimMin singleType) $ SmartExp $ Pair x y) -- | Union of two shapes @@ -1310,7 +1310,7 @@ union' Repr.ShapeRz _ _ = SmartExp Nil union' (Repr.ShapeRsnoc shr) (unPair -> (xs, x)) (unPair -> (ys, y)) = SmartExp $ union' shr xs ys `Pair` - SmartExp (PrimApp (PrimMin singleType) $ SmartExp $ Pair x y) + SmartExp (PrimApp (PrimMax singleType) $ SmartExp $ Pair x y) -- Flow-control From 6c1d464162cbc3ec793802b8ab2ffdecd3eee5f1 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 25 Mar 2020 16:29:52 +0100 Subject: [PATCH 174/316] Make pretty printing tuples more clear --- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 6 +- src/Data/Array/Accelerate/Pretty/Print.hs | 124 +++++++++++++------ 2 files changed, 86 insertions(+), 44 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 2b092a7ff..3b78e8bfb 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -506,7 +506,7 @@ prettyDelayedOpenFun env0 aenv = next "\\\\" env0 nest shiftwidth (sep [ vs <> "→" , prettyDelayedOpenExp context0 env aenv body ]) next vs env (Lam lhs lam) = - let (env', arg) = prettyLHS env lhs + let (env', arg) = prettyELhs env lhs in next (vs <> arg <> space) env' lam prettyDelayedOpenExp @@ -546,7 +546,7 @@ fvPreOpenFun fvPreOpenFun fvA env aenv (Body b) = fvPreOpenExp fvA env aenv b fvPreOpenFun fvA env aenv (Lam lhs f) = fvPreOpenFun fvA env' aenv f where - (env', _) = prettyLHS env lhs + (env', _) = prettyELhs env lhs fvPreOpenExp :: forall acc env aenv exp. @@ -567,7 +567,7 @@ fvPreOpenExp fvA env aenv = fv -- fv (Let lhs e1 e2) = concat [ fv e1, fvPreOpenExp fvA env' aenv e2 ] where - (env', _) = prettyLHS env lhs + (env', _) = prettyELhs env lhs fv Evar{} = [] fv Undef{} = [] fv Const{} = [] diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 569433e15..35634e67a 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -29,7 +29,8 @@ module Data.Array.Accelerate.Pretty.Print ( prettyPreOpenFun, prettyArray, prettyConst, - prettyLHS, + prettyELhs, + prettyALhs, -- ** Internals Adoc, @@ -113,7 +114,7 @@ prettyPreOpenAfun prettyAcc aenv0 = next (pretty '\\') aenv0 next :: Adoc -> Val aenv' -> PreOpenAfun acc aenv' f' -> Adoc next vs aenv (Abody body) = hang shiftwidth (sep [vs <> "->", prettyAcc context0 aenv body]) next vs aenv (Alam lhs lam) = - let (aenv', lhs') = prettyLHS aenv lhs + let (aenv', lhs') = prettyALhs aenv lhs in next (vs <> lhs' <> space) aenv' lam prettyPreOpenAcc @@ -219,7 +220,7 @@ prettyAlet ctx prettyAcc extractAcc aenv0 collect aenv = \case Alet lhs a1 a2 -> - let (aenv', v) = prettyLHS aenv lhs + let (aenv', v) = prettyALhs aenv lhs a1' = ppA aenv a1 bnd | isAlet a1 = nest shiftwidth (vsep [v <+> equals, a1']) | otherwise = v <+> align (equals <+> a1') @@ -253,36 +254,50 @@ prettyAtuple -> Val aenv -> PreOpenAcc acc aenv arrs -> Adoc -prettyAtuple prettyAcc extractAcc aenv0 - = align . wrap . collect aenv0 +prettyAtuple prettyAcc extractAcc aenv0 acc = case collect acc of + Just tup -> align $ "T" <> pretty (length tup) <+> sep tup + Nothing -> align $ ppPair acc where - wrap [x] = x - wrap xs = tupled xs + ppPair :: PreOpenAcc acc aenv arrs' -> Adoc + ppPair (Apair a1 a2) = "(" <> ppPair (extractAcc a1) <> "," <+> prettyAcc context0 aenv0 a2 <> ")" + ppPair a = prettyPreOpenAcc context0 prettyAcc extractAcc aenv0 a - collect :: Val aenv' -> PreOpenAcc acc aenv' a -> [Adoc] - collect aenv = - \case - Anil -> [] - Apair a1 a2 -> collect aenv (extractAcc a1) ++ [prettyAcc context0 aenv a2] - next -> [prettyPreOpenAcc context0 prettyAcc extractAcc aenv next] + collect :: PreOpenAcc acc aenv arrs' -> Maybe [Adoc] + collect Anil = Just [] + collect (Apair a1 a2) + | Just tup <- collect $ extractAcc a1 + = Just $ tup ++ [prettyAcc app aenv0 a2] + collect _ = Nothing -- TODO: Should we also print the types of the declared variables? And the types of wildcards? -prettyLHS :: Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) -prettyLHS env0 = fmap wrap . go env0 - where - wrap [x] = x - wrap xs = tupled xs +prettyALhs :: Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) +prettyALhs = prettyLhs False 'a' + +prettyELhs :: Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) +prettyELhs = prettyLhs False 'x' - go :: Val env -> LeftHandSide s arrs env env' -> (Val env', [Adoc]) - go env (LeftHandSideWildcard TupRunit) = (env, ["()"]) - go env (LeftHandSideWildcard _) = (env, ["_"]) - go env (LeftHandSideSingle _) = (env `Push` v, [v]) +prettyLhs :: forall s env env' arrs. Bool -> Char -> Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) +prettyLhs requiresParens x env0 lhs = case collect lhs of + Just (env1, tup) -> (env1, parensIf requiresParens (pretty 'T' <> pretty (length tup) <+> sep tup)) + Nothing -> ppPair lhs + where + ppPair :: LeftHandSide s arrs' env env'' -> (Val env'', Adoc) + ppPair (LeftHandSideWildcard TupRunit) = (env0, "()") + ppPair (LeftHandSideWildcard _) = (env0, "_") + ppPair (LeftHandSideSingle _) = (env0 `Push` v, v) where - v = pretty 'a' <> pretty (sizeEnv env) - go env (LeftHandSidePair a b) = (env2, doc1 ++ [doc2]) + v = pretty x <> pretty (sizeEnv env0) + ppPair (LeftHandSidePair a b) = (env2, tupled [doc1, doc2]) where - (env1, doc1) = go env a - (env2, doc2) = prettyLHS env1 b + (env1, doc1) = ppPair a + (env2, doc2) = prettyLhs False x env1 b + + collect :: LeftHandSide s arrs' env env'' -> Maybe (Val env'', [Adoc]) + collect (LeftHandSidePair l1 l2) + | Just (env1, tup ) <- collect l1 + , (env2, doc2) <- prettyLhs True x env1 l2 = Just (env2, tup ++ [doc2]) + collect (LeftHandSideWildcard TupRunit) = Just (env0, []) + collect _ = Nothing prettyArray :: ArrayR (Array sh e) -> Array sh e -> Adoc prettyArray repr = parens . fromString . showArray repr @@ -314,7 +329,7 @@ prettyPreOpenFun prettyAcc extractAcc env0 aenv = next (pretty '\\') env0 = hang shiftwidth (sep [ vs <> "->" , prettyPreOpenExp context0 prettyAcc extractAcc env aenv body]) next vs env (Lam lhs lam) = - let (env', lhs') = prettyLHS env lhs + let (env', lhs') = prettyELhs env lhs in next (vs <> lhs' <> space) env' lam prettyPreOpenExp @@ -328,11 +343,11 @@ prettyPreOpenExp -> Adoc prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = case exp of - Evar (Var _ idx) -> prj idx env - Let{} -> prettyLet ctx prettyAcc extractAcc env aenv exp + Evar (Var _ idx) -> prj idx env + Let{} -> prettyLet ctx prettyAcc extractAcc env aenv exp PrimApp f x - | Nil `Pair` a `Pair` b <- x -> ppF2 op (ppE a) (ppE b) - | otherwise -> ppF1 op' (ppE x) + | a `Pair` b <- x -> ppF2 op (ppE a) (ppE b) + | otherwise -> ppF1 op' (ppE x) where op = primOperator f op' = isInfix op ? (Operator (parens (opName op)) App L 10, op) @@ -421,7 +436,7 @@ prettyLet ctx prettyAcc extractAcc env0 aenv collect env = \case Let lhs e1 e2 -> - let (env', v) = prettyLHS env lhs + let (env', v) = prettyELhs env lhs e1' = ppE env e1 bnd | isLet e1 = nest shiftwidth (vsep [v <+> equals, e1']) | otherwise = v <+> align (equals <+> e1') @@ -456,18 +471,45 @@ prettyTuple -> Val aenv -> PreOpenExp acc env aenv t -> Adoc -prettyTuple prettyAcc extractAcc env aenv = wrap . collect [] +prettyTuple prettyAcc extractAcc env aenv exp = case collect exp of + Just tup -> align $ "T" <> pretty (length tup) <+> sep tup + Nothing -> align $ ppPair exp where - wrap [x] = x - wrap xs = tupled xs + ppPair :: PreOpenExp acc env aenv t' -> Adoc + ppPair (Pair e1 e2) = "(" <> ppPair e1 <> "," <+> prettyPreOpenExp context0 prettyAcc extractAcc env aenv e2 <> ")" + ppPair e = prettyPreOpenExp context0 prettyAcc extractAcc env aenv e - collect :: [Adoc] -> PreOpenExp acc env aenv s -> [Adoc] - collect acc = - \case - Nil -> acc - Pair tup e -> collect (align (prettyPreOpenExp context0 prettyAcc extractAcc env aenv e) : acc) tup - next -> [prettyPreOpenExp context0 prettyAcc extractAcc env aenv next] + collect :: PreOpenExp acc env aenv t' -> Maybe [Adoc] + collect Nil = Just [] + collect (Pair e1 e2) + | Just tup <- collect e1 + = Just $ tup ++ [prettyPreOpenExp app prettyAcc extractAcc env aenv e2] + collect _ = Nothing + +{- +prettyAtuple + :: forall acc aenv arrs. + PrettyAcc acc + -> ExtractAcc acc + -> Val aenv + -> PreOpenAcc acc aenv arrs + -> Adoc +prettyAtuple prettyAcc extractAcc aenv0 acc = case collect acc of + Just tup -> align $ "T" <> pretty (length tup) <+> sep tup + Nothing -> align $ ppPair acc + where + ppPair :: PreOpenAcc acc aenv arrs' -> Adoc + ppPair (Apair a1 a2) = "(" <> ppPair (extractAcc a1) <> "," <+> prettyAcc context0 aenv0 a2 <> ")" + ppPair a = prettyPreOpenAcc context0 prettyAcc extractAcc aenv0 a + + collect :: PreOpenAcc acc aenv arrs' -> Maybe [Adoc] + collect Anil = Just [] + collect (Apair a1 a2) + | Just tup <- collect $ extractAcc a1 + = Just $ tup ++ [prettyAcc app aenv0 a2] + collect _ = Nothing +-} prettyConst :: TupleType e -> e -> Adoc prettyConst tp x = From 185887482090aeb9c17ba93137296cf7a9b06eb7 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 25 Mar 2020 19:09:30 +0100 Subject: [PATCH 175/316] Fix lazy evaluation of logical operators --- src/Data/Array/Accelerate/Interpreter.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index c3cc9af6e..358f58a48 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -932,9 +932,7 @@ evalPreOpenExp evalAcc pexp env aenv = PrimConst c -> evalPrimConst c PrimApp f x -> evalPrim f (evalE x) Nil -> () - Pair e1 e2 -> let !v1 = evalE e1 - !v2 = evalE e2 - in (v1, v2) + Pair e1 e2 -> (evalE e1, evalE e2) VecPack vecR e -> vecPack vecR $! evalE e VecUnpack vecR e -> vecUnpack vecR $! evalE e IndexSlice slice slix sh -> restrict slice (evalE slix) From 1d1cfd05653a1e51df8c46dc13f1d57be71e8dc9 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 25 Mar 2020 19:10:36 +0100 Subject: [PATCH 176/316] Fix missing patterns for Vec(Un)Pack --- src/Data/Array/Accelerate/Trafo/Fusion.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index cfda2b8fd..b82ba6fcc 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -281,6 +281,8 @@ convertOpenExp config exp = Undef tp -> Undef tp Nil -> Nil Pair e1 e2 -> Pair (cvtE e1) (cvtE e2) + VecPack vec e -> VecPack vec (cvtE e) + VecUnpack vec e -> VecUnpack vec (cvtE e) IndexSlice x ix sh -> IndexSlice x (cvtE ix) (cvtE sh) IndexFull x ix sl -> IndexFull x (cvtE ix) (cvtE sl) ToIndex shr sh ix -> ToIndex shr (cvtE sh) (cvtE ix) @@ -1052,8 +1054,9 @@ unzipD tp f (Embed env cc@(Done v)) , Just vars <- extractExpVars a , ArrayR shr _ <- arrayRepr cc , f' <- Lam lhs $ Body $ evars vars = Just $ Embed (env `pushArrayEnv` inject (Map tp f' $ avarsIn v)) $ doneZeroIdx $ ArrayR shr tp - | otherwise = Nothing +unzipD _ _ _ + = Nothing -- Fuse an index space transformation function that specifies where elements in -- the destination array read there data from in the source array. From cfd2f12575b89f3155b2f9d98b0aa75a890d3dab Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 25 Mar 2020 19:11:24 +0100 Subject: [PATCH 177/316] Remove Typeable in tests, update tests with tuples --- .../Accelerate/Test/NoFib/Imaginary/DotP.hs | 3 +- .../Accelerate/Test/NoFib/Imaginary/SASUM.hs | 3 +- .../Accelerate/Test/NoFib/Imaginary/SAXPY.hs | 3 +- .../Accelerate/Test/NoFib/Issues/Issue264.hs | 3 +- .../Accelerate/Test/NoFib/Issues/Issue364.hs | 3 +- .../Accelerate/Test/NoFib/Issues/Issue407.hs | 4 +- .../Accelerate/Test/NoFib/Issues/Issue409.hs | 4 +- .../Test/NoFib/Prelude/Backpermute.hs | 3 +- .../Accelerate/Test/NoFib/Prelude/Filter.hs | 5 +- .../Accelerate/Test/NoFib/Prelude/Fold.hs | 5 +- .../Accelerate/Test/NoFib/Prelude/Map.hs | 5 +- .../Accelerate/Test/NoFib/Prelude/Permute.hs | 15 ++-- .../Accelerate/Test/NoFib/Prelude/SIMD.hs | 70 ++++++------------- .../Accelerate/Test/NoFib/Prelude/Scan.hs | 25 ++++--- .../Accelerate/Test/NoFib/Prelude/Stencil.hs | 8 +-- .../Accelerate/Test/NoFib/Prelude/ZipWith.hs | 5 +- .../Test/NoFib/Spectral/BlackScholes.hs | 3 +- .../Test/NoFib/Spectral/RadixSort.hs | 5 +- .../Accelerate/Test/NoFib/Spectral/SMVM.hs | 3 +- 19 files changed, 69 insertions(+), 106 deletions(-) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs index 196541362..0c1bbd475 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs @@ -20,7 +20,6 @@ module Data.Array.Accelerate.Test.NoFib.Imaginary.DotP ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -57,7 +56,7 @@ test_dotp runN = => Gen a -> TestTree testElt e = - testProperty (show (typeOf (undefined :: a))) $ test_dotp' runN e + testProperty (show (eltType @a)) $ test_dotp' runN e test_dotp' diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs index f87b791be..b7b41eb61 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs @@ -20,7 +20,6 @@ module Data.Array.Accelerate.Test.NoFib.Imaginary.SASUM ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -57,7 +56,7 @@ test_sasum runN = => Gen a -> TestTree testElt e = - testProperty (show (typeOf (undefined :: a))) $ test_sasum' runN e + testProperty (show (eltType @a)) $ test_sasum' runN e test_sasum' diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs index e0dd2cadc..c0ba90e49 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs @@ -20,7 +20,6 @@ module Data.Array.Accelerate.Test.NoFib.Imaginary.SAXPY ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -57,7 +56,7 @@ test_saxpy runN = => Gen a -> TestTree testElt e = - testProperty (show (typeOf (undefined :: a))) $ test_saxpy' runN e + testProperty (show (eltType @a)) $ test_saxpy' runN e test_saxpy' diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs index b396f3a9e..267fc89ad 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs @@ -23,7 +23,6 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue264 ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -60,7 +59,7 @@ test_issue264 runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testProperty "neg.neg" $ test_neg_neg runN e ] diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs index e2481c69f..9c4042865 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs @@ -24,7 +24,6 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue364 ( ) where -import Data.Typeable import Prelude ( fromInteger, show ) import qualified Prelude as P #if __GLASGOW_HASKELL__ == 800 @@ -58,7 +57,7 @@ test_issue364 runN = => Gen e -> TestTree testElt _ = - testGroup (show (typeOf (undefined :: e))) + testGroup (show (eltType @e)) [ testCase "A" $ expectedArray @_ @e Z 64 @=? runN (scanl iappend one) (intervalArray Z 64) , testCase "B" $ expectedArray @_ @e Z 65 @=? runN (scanl iappend one) (intervalArray Z 65) -- failed for integral types ] diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs index e431981f1..d07bf63a8 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs @@ -24,10 +24,10 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue407 ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A +import Data.Array.Accelerate.Array.Sugar as A import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty @@ -45,7 +45,7 @@ test_issue407 runN = :: forall a. (P.Fractional a, A.RealFloat a) => TestTree testElt = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (A.eltType @a)) [ testCase "isNaN" $ eNaN @=? runN (A.map A.isNaN) xs , testCase "isInfinite" $ eInf @=? runN (A.map A.isInfinite) xs ] diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs index 385e126fa..7b3c9b122 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs @@ -22,10 +22,10 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue409 ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A +import Data.Array.Accelerate.Array.Sugar as A import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty @@ -43,7 +43,7 @@ test_issue409 runN = :: forall a. (P.Floating a, P.Eq a, A.Floating a) => TestTree testElt = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (A.eltType @a)) [ testCase "A" $ e1 @=? indexArray (runN (A.map f) t1) Z ] where diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs index 561d6553d..e7909667e 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs @@ -21,7 +21,6 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -59,7 +58,7 @@ test_backpermute runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs index 81c2fdc99..deabe823a 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs @@ -23,7 +23,6 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Filter ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -59,7 +58,7 @@ test_filter runN = => Gen a -> TestTree testIntegralElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -79,7 +78,7 @@ test_filter runN = => Gen a -> TestTree testFloatingElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs index d44c840cb..285e88e66 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs @@ -22,7 +22,6 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Fold ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -61,7 +60,7 @@ test_fold runN = -> Gen a -> TestTree testElt e small = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -101,7 +100,7 @@ test_foldSeg runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs index 747ffcafc..3e1ebcd15 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs @@ -24,7 +24,6 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Map ( ) where import Data.Bits as P -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -65,7 +64,7 @@ test_map runN = => Gen a -> TestTree testIntegralElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim0 , testDim dim1 , testDim dim2 @@ -97,7 +96,7 @@ test_map runN = => (Range a -> Gen a) -> TestTree testFloatingElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim0 , testDim dim1 , testDim dim2 diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs index 31bf21931..bbbc395d5 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs @@ -22,13 +22,13 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Permute ( ) where import Control.Monad -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 qualified Data.Array.Accelerate.Array.Representation as R import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config @@ -63,7 +63,7 @@ test_permute runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -144,15 +144,16 @@ test_accumulate runN dim dim' e = permuteRef - :: (Shape sh, Shape sh', P.Eq sh', Elt e) + :: forall sh sh' e. (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) = +permuteRef f def@(Array (R.Array _ aold)) p arr@(Array (R.Array _ anew)) = unsafePerformIO $ do let + tp = S.eltType @e sh = S.shape arr sh' = S.shape def n = S.size sh @@ -165,9 +166,9 @@ permuteRef f def@(Array _ aold) p arr@(Array _ anew) = -- 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')) + x <- toElt <$> unsafeReadArrayData tp anew i + x' <- toElt <$> unsafeReadArrayData tp aold i' + unsafeWriteArrayData tp aold i' (fromElt (f x x')) -- go (i+1) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs index 7b506c7df..ba1c3a41e 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs @@ -19,8 +19,6 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.SIMD ( ) where -import Data.Typeable -import Data.Primitive.Types import Control.Lens ( view, _1, _2, _3, _4 ) import Prelude as P @@ -29,7 +27,6 @@ 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.Type -import Data.Array.Accelerate.Smart import Hedgehog import qualified Hedgehog.Gen as Gen @@ -54,16 +51,16 @@ test_simd runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall e. (Prim e, P.Eq e, Elt e, Elt (V2 e), Elt (V3 e), Elt (V4 e)) + testElt :: forall e. (VecElt e, P.Eq e) => Gen e -> TestTree testElt e = - testGroup (show (typeOf (undefined::e))) + testGroup (show (eltType @e)) [ testExtract e , testInject e ] - testExtract :: forall e. (Prim e, P.Eq e, Elt e, Elt (V2 e), Elt (V3 e), Elt (V4 e)) + testExtract :: forall e. (VecElt e, P.Eq e) => Gen e -> TestTree testExtract e = @@ -73,7 +70,7 @@ test_simd runN = , testProperty "V4" $ test_extract_v4 runN dim1 e ] - testInject :: forall e. (Prim e, P.Eq e, Elt e, Elt (V2 e), Elt (V3 e), Elt (V4 e)) + testInject :: forall e. (VecElt e, P.Eq e) => Gen e -> TestTree testInject e = @@ -85,7 +82,7 @@ test_simd runN = test_extract_v2 - :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V2 e)) + :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -98,7 +95,7 @@ test_extract_v2 runN dim e = let !go = runN (A.map (view _m . unpackV2')) in go xs === mapRef (view _l . unpackV2) xs test_extract_v3 - :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V3 e)) + :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -111,7 +108,7 @@ test_extract_v3 runN dim e = let !go = runN (A.map (view _m . unpackV3')) in go xs === mapRef (view _l . unpackV3) xs test_extract_v4 - :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V4 e)) + :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -124,7 +121,7 @@ test_extract_v4 runN dim e = let !go = runN (A.map (view _m . unpackV4')) in go xs === mapRef (view _l . unpackV4) xs test_inject_v2 - :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V2 e)) + :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -135,10 +132,10 @@ test_inject_v2 runN dim e = sh2 <- forAll dim xs <- forAll (array sh1 e) ys <- forAll (array sh2 e) - let !go = runN (A.zipWith packV2') in go xs ys === zipWithRef V2 xs ys + let !go = runN (A.zipWith A.V2_) in go xs ys === zipWithRef V2 xs ys test_inject_v3 - :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V3 e)) + :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -151,10 +148,10 @@ test_inject_v3 runN dim e = xs <- forAll (array sh1 e) ys <- forAll (array sh2 e) zs <- forAll (array sh3 e) - let !go = runN (A.zipWith3 packV3') in go xs ys zs === zipWith3Ref V3 xs ys zs + let !go = runN (A.zipWith3 A.V3_) in go xs ys zs === zipWith3Ref V3 xs ys zs test_inject_v4 - :: (Shape sh, Prim e, P.Eq e, P.Eq sh, Elt e, Elt (V4 e)) + :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -169,38 +166,17 @@ test_inject_v4 runN dim e = ys <- forAll (array sh2 e) zs <- forAll (array sh3 e) ws <- forAll (array sh4 e) - let !go = runN (A.zipWith4 packV4') in go xs ys zs ws === zipWith4Ref V4 xs ys zs ws - - -unpackV2' :: (Prim e, Elt e, Elt (V2 e)) => Exp (V2 e) -> (Exp e, Exp e) -unpackV2' e = - ( Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e - ) - -unpackV3' :: (Prim e, Elt e, Elt (V3 e)) => Exp (V3 e) -> (Exp e, Exp e, Exp e) -unpackV3' e = - ( Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e - ) - -unpackV4' :: (Prim e, Elt e, Elt (V4 e)) => Exp (V4 e) -> (Exp e, Exp e, Exp e, Exp e) -unpackV4' e = - ( Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` e - , Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` e - , Exp $ SuccTupIdx ZeroTupIdx `Prj` e - , Exp $ ZeroTupIdx `Prj` e - ) - -packV2' :: (Prim e, Elt e, Elt (V2 e)) => Exp e -> Exp e -> Exp (V2 e) -packV2' x y = Exp . Tuple $ NilTup `SnocTup` x `SnocTup` y - -packV3' :: (Prim e, Elt e, Elt (V3 e)) => Exp e -> Exp e -> Exp e -> Exp (V3 e) -packV3' x y z = Exp . Tuple $ NilTup `SnocTup` x `SnocTup` y `SnocTup` z - -packV4' :: (Prim e, Elt e, Elt (V4 e)) => Exp e -> Exp e -> Exp e -> Exp e -> Exp (V4 e) -packV4' x y z w = Exp . Tuple $ NilTup `SnocTup` x `SnocTup` y `SnocTup` z `SnocTup` w + let !go = runN (A.zipWith4 A.V4_) in go xs ys zs ws === zipWith4Ref V4 xs ys zs ws + + +unpackV2' :: VecElt e => Exp (V2 e) -> (Exp e, Exp e) +unpackV2' (A.V2_ a b) = (a, b) + +unpackV3' :: VecElt e => Exp (V3 e) -> (Exp e, Exp e, Exp e) +unpackV3' (A.V3_ a b c) = (a, b, c) + +unpackV4' :: VecElt e => Exp (V4 e) -> (Exp e, Exp e, Exp e, Exp e) +unpackV4' (A.V4_ a b c d) = (a, b, c, d) -- Reference Implementation diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs index 22c06786d..a327b050a 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs @@ -27,7 +27,6 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Scan ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -65,7 +64,7 @@ test_scanl runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -101,7 +100,7 @@ test_scanl1 runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -136,7 +135,7 @@ test_scanl' runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -172,7 +171,7 @@ test_scanr runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -208,7 +207,7 @@ test_scanr1 runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -243,7 +242,7 @@ test_scanr' runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -279,7 +278,7 @@ test_scanlSeg runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -314,7 +313,7 @@ test_scanl1Seg runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -348,7 +347,7 @@ test_scanl'Seg runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -383,7 +382,7 @@ test_scanrSeg runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -418,7 +417,7 @@ test_scanr1Seg runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 @@ -452,7 +451,7 @@ test_scanr'Seg runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim1 , testDim dim2 , testDim dim3 diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs index 465fba69c..e7c4eaefb 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs @@ -64,7 +64,7 @@ test_stencil runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim1 , testDim2 , testDim3 @@ -630,9 +630,9 @@ bound bnd sh0 ix0 = 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 + go TupRunit () () = Right () + go (TupRpair tsh tsz) (sh,sz) (ih,iz) = go tsh sh ih `addDim` go tsz sz iz + go (TupRsingle t) sh i | Just Refl <- matchScalarType t (scalarType :: ScalarType Int) = if i P.< 0 then case bnd of diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs index 26b2b1455..d5324b1c0 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs @@ -23,7 +23,6 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.ZipWith ( ) where import Data.Bits as P -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -65,7 +64,7 @@ test_zipWith runN = => Gen a -> TestTree testIntegralElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim0 , testDim dim1 , testDim dim2 @@ -115,7 +114,7 @@ test_zipWith runN = => (Range a -> Gen a) -> TestTree testFloatingElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testDim dim0 , testDim dim1 , testDim dim2 diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs index adbfdaec5..34b4b8915 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs @@ -22,7 +22,6 @@ module Data.Array.Accelerate.Test.NoFib.Spectral.BlackScholes ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -52,7 +51,7 @@ test_blackscholes runN = => (Range a -> Gen a) -> TestTree testElt e = - testProperty (show (typeOf (undefined :: a))) $ test_blackscholes' runN e + testProperty (show (eltType @a)) $ test_blackscholes' runN e test_blackscholes' diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs index c8be0ff1e..1ec13bac3 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs @@ -22,7 +22,6 @@ module Data.Array.Accelerate.Test.NoFib.Spectral.RadixSort ( ) where -import Data.Typeable import Data.Function import Data.List import Prelude as P @@ -30,7 +29,7 @@ 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.Array.Sugar as S ( shape, eltType ) import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -62,7 +61,7 @@ test_radixsort runN = => Gen a -> TestTree testElt e = - testGroup (show (typeOf (undefined :: a))) + testGroup (show (eltType @a)) [ testProperty "ascending" $ test_sort_ascending runN e , testProperty "descending" $ test_sort_descending runN e , testProperty "key-value" $ test_sort_keyval runN e f32 diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs index b78714a01..31c1a8404 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs @@ -21,7 +21,6 @@ module Data.Array.Accelerate.Test.NoFib.Spectral.SMVM ( ) where -import Data.Typeable import Prelude as P import Data.Array.Accelerate as A @@ -50,7 +49,7 @@ test_smvm runN = => Gen a -> TestTree testElt e = - testProperty (show (typeOf (undefined :: a))) $ test_smvm' runN e + testProperty (show (eltType @a)) $ test_smvm' runN e test_smvm' :: (A.Num e, P.Num e, Similar e) => RunN -> Gen e -> Property From 4c22c297d7c75d69c29bdc4d05ca2540ebd7817b Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Thu, 26 Mar 2020 11:39:25 +0100 Subject: [PATCH 178/316] Remove injectivity annotation on GArrayData --- src/Data/Array/Accelerate/Array/Data.hs | 2 +- .../Array/Accelerate/Array/Representation.hs | 8 ++-- src/Data/Array/Accelerate/Interpreter.hs | 37 +++++++++++-------- 3 files changed, 27 insertions(+), 20 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index a354ea084..57a651fb8 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -123,7 +123,7 @@ type MutableArrayData e = GArrayData e -- In previous versions this was abstracted over by the mutable/immutable array -- representation, but this is now fixed to our UniqueArray type. -- -type family GArrayData a = r | r -> a where +type family GArrayData a where GArrayData () = () GArrayData (a, b) = (GArrayData a, GArrayData b) -- XXX: fields of tuple are non-strict, which enables lazy device-host copying GArrayData a = ScalarData a diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index c73284a20..e3c7babfd 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -120,13 +120,13 @@ fromFunctionM (ArrayR shr tp) sh f = do {-# INLINEABLE concatVectors #-} -concatVectors :: TupleType e -> [Vector e] -> Vector e +concatVectors :: forall e. TupleType e -> [Vector e] -> Vector e concatVectors tp vs = adata `seq` Array ((), len) adata where dim1 = ShapeRsnoc ShapeRz offsets = scanl (+) 0 (map (size dim1 . shape) vs) len = last offsets - (adata, _) = runArrayData $ do + (adata, _) = runArrayData @e $ do arr <- newArrayData tp len sequence_ [ unsafeWriteArrayData tp arr (i + k) (unsafeIndexArrayData tp ad i) | (Array ((), n) ad, k) <- vs `zip` offsets @@ -134,14 +134,14 @@ concatVectors tp vs = adata `seq` Array ((), len) adata return (arr, undefined) {-# INLINEABLE fromList #-} -fromList :: ArrayR (Array sh e) -> sh -> [e] -> Array sh e +fromList :: forall sh e. ArrayR (Array sh e) -> sh -> [e] -> Array sh e fromList (ArrayR shr tp) sh xs = adata `seq` Array 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 shr sh - (adata, _) = runArrayData $ do + (adata, _) = runArrayData @e $ do arr <- newArrayData tp n let go !i _ | i >= n = return () go !i (v:vs) = unsafeWriteArrayData tp arr i v >> go (i+1) vs diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 358f58a48..a99f19421 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -430,7 +430,8 @@ fold1SegOp itp f (Delayed repr (sh, _) arr _) (Delayed _ ((), n) _ seg) scanl1Op - :: (e -> e -> e) + :: forall sh e. + (e -> e -> e) -> Delayed (Array (sh, Int) e) -> WithReprs (Array (sh, Int) e) scanl1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) @@ -440,7 +441,7 @@ scanl1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) ) where -- - (adata, _) = runArrayData $ do + (adata, _) = runArrayData @e $ do aout <- newArrayData tp (size shr sh) let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh (sz, 0)) (ain (sz, 0)) @@ -454,7 +455,8 @@ scanl1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) scanlOp - :: (e -> e -> e) + :: forall sh e. + (e -> e -> e) -> e -> Delayed (Array (sh, Int) e) -> WithReprs (Array (sh, Int) e) @@ -465,7 +467,7 @@ scanlOp f z (Delayed (ArrayR shr tp) (sh, n) ain _) where sh' = (sh, n+1) -- - (adata, _) = runArrayData $ do + (adata, _) = runArrayData @e $ do aout <- newArrayData tp (size shr sh') let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh' (sz, 0)) z @@ -479,7 +481,8 @@ scanlOp f z (Delayed (ArrayR shr tp) (sh, n) ain _) scanl'Op - :: (e -> e -> e) + :: forall sh e. + (e -> e -> e) -> e -> Delayed (Array (sh, Int) e) -> WithReprs (((), Array (sh, Int) e), Array sh e) @@ -489,7 +492,7 @@ scanl'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) , Array sh asum ) ) where - ((aout, asum), _) = runArrayData $ do + ((aout, asum), _) = runArrayData @(e, e) $ do aout <- newArrayData tp (size shr (sh, n)) asum <- newArrayData tp (size shr' sh) @@ -508,7 +511,8 @@ scanl'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) scanrOp - :: (e -> e -> e) + :: forall sh e. + (e -> e -> e) -> e -> Delayed (Array (sh, Int) e) -> WithReprs (Array (sh, Int) e) @@ -519,7 +523,7 @@ scanrOp f z (Delayed (ArrayR shr tp) (sz, n) ain _) where sh' = (sz, n+1) -- - (adata, _) = runArrayData $ do + (adata, _) = runArrayData @e $ do aout <- newArrayData tp (size shr sh') let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh' (sz, n)) z @@ -533,7 +537,8 @@ scanrOp f z (Delayed (ArrayR shr tp) (sz, n) ain _) scanr1Op - :: (e -> e -> e) + :: forall sh e. + (e -> e -> e) -> Delayed (Array (sh, Int) e) -> WithReprs (Array (sh, Int) e) scanr1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) @@ -542,7 +547,7 @@ scanr1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) , adata `seq` Array sh adata ) where - (adata, _) = runArrayData $ do + (adata, _) = runArrayData @e $ do aout <- newArrayData tp (size shr sh) let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh (sz, n-1)) (ain (sz, n-1)) @@ -556,7 +561,8 @@ scanr1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) scanr'Op - :: (e -> e -> e) + :: forall sh e. + (e -> e -> e) -> e -> Delayed (Array (sh, Int) e) -> WithReprs (((), Array (sh, Int) e), Array sh e) @@ -566,7 +572,7 @@ scanr'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) , Array sh asum ) ) where - ((aout, asum), _) = runArrayData $ do + ((aout, asum), _) = runArrayData @(e, e) $ do aout <- newArrayData tp (size shr (sh, n)) asum <- newArrayData tp (size shr' sh) @@ -586,10 +592,11 @@ scanr'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) permuteOp - :: (e -> e -> e) + :: forall sh sh' e. + (e -> e -> e) -> WithReprs (Array sh' e) -> (sh -> sh') - -> Delayed (Array sh e) + -> Delayed (Array sh e) -> WithReprs (Array sh' e) permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR shr tp) sh _ ain) = (TupRsingle $ ArrayR shr' tp, adata `seq` Array sh' adata) @@ -599,7 +606,7 @@ permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR ignore' = ignore shr' -- - (adata, _) = runArrayData $ do + (adata, _) = runArrayData @e $ do aout <- newArrayData tp n' let -- initialise array with default values From 948b65c9da1d731cab01d02df515d4ba543dbce6 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Thu, 26 Mar 2020 12:21:16 +0100 Subject: [PATCH 179/316] Fix pattern matching on GADTs for GHC 8.4 --- src/Data/Array/Accelerate/Array/Representation.hs | 13 +++++-------- src/Data/Array/Accelerate/Smart.hs | 13 +++++++++++-- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index e3c7babfd..24c462b20 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -511,15 +511,13 @@ vecRtuple = snd . go vecPack :: forall n single tuple. KnownNat n => VecR n single tuple -> tuple -> Vec n single vecPack vecR tuple - | IsPrim <- getPrim single = runST $ do + | VectorType n single <- vecRvector vecR + , IsPrim <- getPrim single = runST $ do mba <- newByteArray (n * sizeOf (undefined :: single)) go (n - 1) vecR tuple mba ByteArray ba# <- unsafeFreezeByteArray mba return $! Vec ba# - where - VectorType n single = vecRvector vecR - go :: Prim single => Int -> VecR n' single tuple' -> tuple' -> MutableByteArray s -> ST s () go _ (VecRnil _) () _ = return () go i (VecRsucc r) (xs, x) mba = do @@ -528,12 +526,11 @@ vecPack vecR tuple vecUnpack :: forall n single tuple. KnownNat n => VecR n single tuple -> Vec n single -> tuple vecUnpack vecR (Vec ba#) - | IsPrim <- getPrim single + | VectorType n single <- vecRvector vecR + , !(I# n#) <- n + , IsPrim <- getPrim single = go (n# -# 1#) vecR where - VectorType n single = vecRvector vecR - !(I# n#) = n - go :: Prim single => Int# -> VecR n' single tuple' -> tuple' go _ (VecRnil _) = () go i# (VecRsucc r) = x `seq` xs `seq` (xs, x) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 5f68aff64..0d8c9b8bf 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -477,9 +478,13 @@ instance HasArraysRepr acc => HasArraysRepr (PreSmartAcc acc exp) where Awhile _ _ _ a -> arraysRepr a Anil -> TupRunit Apair a1 a2 -> arraysRepr a1 `TupRpair` arraysRepr a2 - Aprj idx a -> let TupRpair t1 t2 = arraysRepr a in case idx of + Aprj idx a | TupRpair t1 t2 <- arraysRepr a + -> case idx of PairIdxLeft -> t1 PairIdxRight -> t2 +#if __GLASGOW_HASKELL__ < 806 + Aprj _ _ -> error "Ejector seat? You're joking!" +#endif Use repr _ -> TupRsingle repr Unit tp _ -> TupRsingle $ ArrayR ShapeRz $ tp Generate repr _ _ -> TupRsingle repr @@ -754,9 +759,13 @@ instance HasExpType exp => HasExpType (PreSmartExp acc exp) where Const tp _ -> TupRsingle tp Nil -> TupRunit Pair e1 e2 -> expType e1 `TupRpair` expType e2 - Prj idx e -> let TupRpair t1 t2 = expType e in case idx of + Prj idx e | TupRpair t1 t2 <- expType e + -> case idx of PairIdxLeft -> t1 PairIdxRight -> t2 +#if __GLASGOW_HASKELL__ < 806 + Prj _ _ -> error "I never joke about my work" +#endif VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR VecUnpack vecR _ -> vecRtuple vecR ToIndex _ _ _ -> TupRsingle $ scalarTypeInt From e0b0d8533ee3fcbcbd8d6bb5801b6cd2def060d5 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Thu, 26 Mar 2020 13:50:28 +0100 Subject: [PATCH 180/316] Fixes for GHC 8.2 --- src/Data/Array/Accelerate/Language.hs | 15 ++++++++++++++- src/Data/Array/Accelerate/Trafo/Shrink.hs | 8 +++++++- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 9e4672935..5cf684356 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -1336,8 +1337,20 @@ while :: forall e. Elt e -> (Exp e -> Exp e) -- ^ function to apply -> Exp e -- ^ initial value -> Exp e +#if __GLASGOW_HASKELL__ < 804 +while c f (Exp e) = exp $ While @SmartAcc @SmartExp @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e +#else while c f (Exp e) = exp $ While @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e +#endif +{- + + While :: TupleType t + -> (SmartExp t -> exp Bool) + -> (SmartExp t -> exp t) + -> exp t + -> PreSmartExp acc exp t + -} -- Array operations with a scalar result -- ------------------------------------- diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index a97773e3e..dbed5e2ea 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -40,10 +41,15 @@ module Data.Array.Accelerate.Trafo.Shrink ( ) where -- standard library -import Data.Monoid import Control.Applicative hiding ( Const ) import Prelude hiding ( exp, seq ) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup +#else +import Data.Monoid +#endif + -- friends import Data.Array.Accelerate.AST import Data.Array.Accelerate.Array.Sugar hiding ( Any ) From 7f51c9160daf5297ac978514265e354dc7198ab9 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Thu, 26 Mar 2020 14:22:04 +0100 Subject: [PATCH 181/316] Fix GHC warnings --- src/Data/Array/Accelerate/AST.hs | 3 ++- src/Data/Array/Accelerate/Array/Remote/LRU.hs | 3 +++ src/Data/Array/Accelerate/Smart.hs | 4 ---- src/Data/Array/Accelerate/Trafo/Substitution.hs | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 9b53eb9c8..0b823317f 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -128,6 +128,7 @@ module Data.Array.Accelerate.AST ( import Control.DeepSeq import Control.Monad.ST import Data.List ( intercalate ) +import Data.Kind import Foreign.ForeignPtr import Foreign.Marshal import Foreign.Ptr @@ -231,7 +232,7 @@ type ALeftHandSide = LeftHandSide ArrayR type ELeftHandSide = LeftHandSide ScalarType -data LeftHandSide (s :: * -> *) v env env' where +data LeftHandSide (s :: Type -> Type) v env env' where LeftHandSideSingle :: s v -> LeftHandSide s v env (env, v) diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs index aedea5c1e..01f67025a 100644 --- a/src/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/src/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DoAndIfThenElse #-} @@ -41,7 +42,9 @@ import Control.Monad ( filterM ) import Control.Monad.Catch import Control.Monad.IO.Class ( MonadIO, liftIO ) import Data.Functor +#if __GLASGOW_HASKELL__ < 808 import Data.Int ( Int64 ) +#endif import Data.Maybe ( isNothing ) import System.CPUTime import System.Mem.Weak ( Weak, deRefWeak, finalize ) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 0d8c9b8bf..ffbe2de96 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -482,9 +482,7 @@ instance HasArraysRepr acc => HasArraysRepr (PreSmartAcc acc exp) where -> case idx of PairIdxLeft -> t1 PairIdxRight -> t2 -#if __GLASGOW_HASKELL__ < 806 Aprj _ _ -> error "Ejector seat? You're joking!" -#endif Use repr _ -> TupRsingle repr Unit tp _ -> TupRsingle $ ArrayR ShapeRz $ tp Generate repr _ _ -> TupRsingle repr @@ -763,9 +761,7 @@ instance HasExpType exp => HasExpType (PreSmartExp acc exp) where -> case idx of PairIdxLeft -> t1 PairIdxRight -> t2 -#if __GLASGOW_HASKELL__ < 806 Prj _ _ -> error "I never joke about my work" -#endif VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR VecUnpack vecR _ -> vecRtuple vecR ToIndex _ _ _ -> TupRsingle $ scalarTypeInt diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 1f99faf71..74bed7bfd 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -589,7 +589,7 @@ instance SyntacticAcc PreOpenAcc where type RebuildAvar f (fa :: (Type -> Type -> Type) -> Type -> Type -> Type) acc aenv aenv' = forall sh e. ArrayVar aenv (Array sh e) -> f (fa acc aenv' (Array sh e)) -type RebuildEvar f fe (acc :: * -> * -> *) env env' aenv' = +type RebuildEvar f fe (acc :: Type -> Type -> Type) env env' aenv' = forall t'. ExpVar env t' -> f (fe acc env' aenv' t') {-# INLINEABLE shiftA #-} From a2685d7c55ff2f36e7b63330da710f7497aa5ea3 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Mon, 30 Mar 2020 13:49:58 +0200 Subject: [PATCH 182/316] Scan' returns a pair instead of 2-tuple internally --- src/Data/Array/Accelerate/AST.hs | 32 ++++++++--------- src/Data/Array/Accelerate/Array/Data.hs | 7 ++-- src/Data/Array/Accelerate/Interpreter.hs | 14 ++++---- src/Data/Array/Accelerate/Language.hs | 4 +-- src/Data/Array/Accelerate/Smart.hs | 45 ++++++++++++++---------- 5 files changed, 56 insertions(+), 46 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 0b823317f..72dab7b4f 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -526,7 +526,7 @@ data PreOpenAcc acc aenv a where Scanl' :: 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) + -> PreOpenAcc acc aenv (Array (sh, Int) e, Array sh e) -- Haskell-style scan without an initial value -- @@ -546,7 +546,7 @@ data PreOpenAcc acc aenv a where Scanr' :: 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) + -> PreOpenAcc acc aenv (Array (sh, Int) e, Array sh e) -- Right-to-left version of 'Scanl1' -- @@ -780,38 +780,38 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr (Awhile _ _ _) = error "I want my, I want my MTV!" arraysRepr (Use repr _) = TupRsingle repr arraysRepr (Unit tp _) = arraysRarray ShapeRz tp - arraysRepr (Reshape sh _ a) = let TupRsingle (ArrayR _ tp) = arraysRepr a + arraysRepr (Reshape sh _ a) = let ArrayR _ tp = arrayRepr a in arraysRarray sh tp arraysRepr (Generate repr _ _) = TupRsingle repr arraysRepr (Transform repr _ _ _ _) = TupRsingle repr - arraysRepr (Replicate slice _ a) = let TupRsingle (ArrayR _ tp) = arraysRepr a + arraysRepr (Replicate slice _ a) = let ArrayR _ tp = arrayRepr a in arraysRarray (sliceDomainR slice) tp - arraysRepr (Slice slice a _) = let TupRsingle (ArrayR _ tp) = arraysRepr a + arraysRepr (Slice slice a _) = let ArrayR _ tp = arrayRepr a in arraysRarray (sliceShapeR slice) tp - arraysRepr (Map tp _ a) = let TupRsingle (ArrayR sh _) = arraysRepr a + arraysRepr (Map tp _ a) = let ArrayR sh _ = arrayRepr a in arraysRarray sh tp - arraysRepr (ZipWith tp _ a _) = let TupRsingle (ArrayR sh _) = arraysRepr a + arraysRepr (ZipWith tp _ a _) = let ArrayR sh _ = arrayRepr a in arraysRarray sh tp - arraysRepr (Fold _ _ a) = let TupRsingle (ArrayR (ShapeRsnoc sh) tp) = arraysRepr a + arraysRepr (Fold _ _ a) = let ArrayR (ShapeRsnoc sh) tp = arrayRepr a in arraysRarray sh tp - arraysRepr (Fold1 _ a) = let TupRsingle (ArrayR (ShapeRsnoc sh) tp) = arraysRepr a + arraysRepr (Fold1 _ a) = let ArrayR (ShapeRsnoc sh) tp = arrayRepr a in arraysRarray sh tp arraysRepr (FoldSeg _ _ _ a _) = arraysRepr a arraysRepr (Fold1Seg _ _ a _) = arraysRepr a arraysRepr (Scanl _ _ a) = arraysRepr a - arraysRepr (Scanl' _ _ a) = let TupRsingle repr@(ArrayR (ShapeRsnoc sh) tp) = arraysRepr a - in arraysRtuple2 repr $ ArrayR sh tp + arraysRepr (Scanl' _ _ a) = let repr@(ArrayR (ShapeRsnoc sh) tp) = arrayRepr a + in TupRsingle repr `TupRpair` TupRsingle (ArrayR sh tp) arraysRepr (Scanl1 _ a) = arraysRepr a arraysRepr (Scanr _ _ a) = arraysRepr a - arraysRepr (Scanr' _ _ a) = let TupRsingle repr@(ArrayR (ShapeRsnoc sh) tp) = arraysRepr a - in arraysRtuple2 repr $ ArrayR sh tp + arraysRepr (Scanr' _ _ a) = let repr@(ArrayR (ShapeRsnoc sh) tp) = arrayRepr a + in TupRsingle repr `TupRpair` TupRsingle (ArrayR sh tp) arraysRepr (Scanr1 _ a) = arraysRepr a arraysRepr (Permute _ a _ _) = arraysRepr a - arraysRepr (Backpermute sh _ _ a) = let TupRsingle (ArrayR _ tp) = arraysRepr a + arraysRepr (Backpermute sh _ _ a) = let ArrayR _ tp = arrayRepr a in arraysRarray sh tp - arraysRepr (Stencil _ tp _ _ a) = let TupRsingle (ArrayR sh _) = arraysRepr a + arraysRepr (Stencil _ tp _ _ a) = let ArrayR sh _ = arrayRepr a in arraysRarray sh tp - arraysRepr (Stencil2 _ _ tp _ _ a _ _) = let TupRsingle (ArrayR sh _) = arraysRepr a + arraysRepr (Stencil2 _ _ tp _ _ a _ _) = let ArrayR sh _ = arrayRepr a in arraysRarray sh tp instance HasArraysRepr OpenAcc where diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 57a651fb8..ba8bafdd0 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -41,7 +42,7 @@ module Data.Array.Accelerate.Array.Data ( registerForeignPtrAllocator, -- * Utilities for type classes - ScalarDict(..), scalarDict, singleDict + ScalarDict(..), scalarDict, singleDict, IsScalarData ) where @@ -152,7 +153,9 @@ type family ScalarDataRepr tp where -- Utilities for working with the type families & type class instances data ScalarDict e where - ScalarDict :: (Storable (ScalarDataRepr e), Prim (ScalarDataRepr e), ArrayData e ~ ScalarData e) => ScalarDict e + ScalarDict :: IsScalarData e => ScalarDict e + +type IsScalarData e = (Storable (ScalarDataRepr e), Prim (ScalarDataRepr e), ArrayData e ~ ScalarData e) {-# INLINE scalarDict #-} scalarDict :: ScalarType e -> (Int, ScalarDict e) diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index a99f19421..599c97d26 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -485,11 +485,10 @@ scanl'Op (e -> e -> e) -> e -> Delayed (Array (sh, Int) e) - -> WithReprs (((), Array (sh, Int) e), Array sh e) + -> WithReprs (Array (sh, Int) e, Array sh e) scanl'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) - = ( TupRunit `TupRpair` TupRsingle (ArrayR shr tp) `TupRpair` TupRsingle (ArrayR shr' tp) - , aout `seq` asum `seq` ( ( (), Array (sh, n) aout ) - , Array sh asum ) + = ( TupRsingle (ArrayR shr tp) `TupRpair` TupRsingle (ArrayR shr' tp) + , aout `seq` asum `seq` ( Array (sh, n) aout, Array sh asum ) ) where ((aout, asum), _) = runArrayData @(e, e) $ do @@ -565,11 +564,10 @@ scanr'Op (e -> e -> e) -> e -> Delayed (Array (sh, Int) e) - -> WithReprs (((), Array (sh, Int) e), Array sh e) + -> WithReprs (Array (sh, Int) e, Array sh e) scanr'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) - = ( TupRunit `TupRpair` TupRsingle (ArrayR shr tp) `TupRpair` TupRsingle (ArrayR shr' tp) - , aout `seq` asum `seq` ( ((), Array (sh, n) aout ) - , Array sh asum ) + = ( TupRsingle (ArrayR shr tp) `TupRpair` TupRsingle (ArrayR shr' tp) + , aout `seq` asum `seq` ( Array (sh, n) aout, Array sh asum ) ) where ((aout, asum), _) = runArrayData @(e, e) $ do diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 5cf684356..0de3f6355 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -645,7 +645,7 @@ scanl' :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a, Array sh a) -scanl' = Acc $$$ applyAcc (Scanl' $ eltType @a) +scanl' = Acc . mkPairToTuple $$$ applyAcc (Scanl' $ eltType @a) -- | 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 @@ -684,7 +684,7 @@ scanr' :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a, Array sh a) -scanr' = Acc $$$ applyAcc (Scanr' $ eltType @a) +scanr' = Acc . mkPairToTuple $$$ applyAcc (Scanr' $ eltType @a) -- | Right-to-left variant of 'scanl1'. -- diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index ffbe2de96..c0df7a140 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -62,7 +62,7 @@ module Data.Array.Accelerate.Smart ( mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkCoerce, Coerce, -- * Auxiliary functions - ($$), ($$$), ($$$$), ($$$$$), unAcc, unAccFunction, ApplyAcc(..), exp, unPair, HasExpType(..), HasArraysRepr(..), + ($$), ($$$), ($$$$), ($$$$$), unAcc, unAccFunction, ApplyAcc(..), exp, unPair, mkPairToTuple, HasExpType(..), HasArraysRepr(..), vecR2, vecR3, vecR4, vecR5, vecR6, vecR7, vecR8, vecR9, vecR16, -- Debugging @@ -81,7 +81,7 @@ import qualified Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.Array.Representation hiding (DIM1) import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc , PreOpenExp(..), OpenExp, PreExp, Exp - , PreBoundary(..), Boundary, HasArraysRepr(..), expType + , PreBoundary(..), Boundary, HasArraysRepr(..), arrayRepr, expType , showPreAccOp, showPreExpOp ) import GHC.TypeNats @@ -402,7 +402,7 @@ data PreSmartAcc acc exp as where -> (SmartExp e -> SmartExp e -> exp e) -> exp e -> acc (Array (sh, Int) e) - -> PreSmartAcc acc exp (((), Array (sh, Int) e), Array sh e) + -> PreSmartAcc acc exp (Array (sh, Int) e, Array sh e) Scanl1 :: TupleType e -> (SmartExp e -> SmartExp e -> exp e) @@ -419,7 +419,7 @@ data PreSmartAcc acc exp as where -> (SmartExp e -> SmartExp e -> exp e) -> exp e -> acc (Array (sh, Int) e) - -> PreSmartAcc acc exp (((), Array (sh, Int) e), Array sh e) + -> PreSmartAcc acc exp (Array (sh, Int) e, Array sh e) Scanr1 :: TupleType e -> (SmartExp e -> SmartExp e -> exp e) @@ -468,6 +468,10 @@ data PairIdx p a where class HasArraysRepr f where arraysRepr :: f a -> ArraysR a +arrayRepr :: HasArraysRepr f => f (Array sh e) -> ArrayR (Array sh e) +arrayRepr acc = case arraysRepr acc of + TupRsingle repr -> repr + instance HasArraysRepr acc => HasArraysRepr (PreSmartAcc acc exp) where arraysRepr acc = case acc of Atag repr _ -> repr @@ -486,37 +490,35 @@ instance HasArraysRepr acc => HasArraysRepr (PreSmartAcc acc exp) where Use repr _ -> TupRsingle repr Unit tp _ -> TupRsingle $ ArrayR ShapeRz $ tp Generate repr _ _ -> TupRsingle repr - Reshape shr _ a -> let TupRsingle (ArrayR _ tp) = arraysRepr a + Reshape shr _ a -> let ArrayR _ tp = arrayRepr a in TupRsingle $ ArrayR shr tp - Replicate si _ a -> let TupRsingle (ArrayR _ tp) = arraysRepr a + Replicate si _ a -> let ArrayR _ tp = arrayRepr a in TupRsingle $ ArrayR (sliceDomainR si) tp - Slice si a _ -> let TupRsingle (ArrayR _ tp) = arraysRepr a + Slice si a _ -> let ArrayR _ tp = arrayRepr a in TupRsingle $ ArrayR (sliceShapeR si) tp - Map _ tp _ a -> let TupRsingle (ArrayR shr _) = arraysRepr a + Map _ tp _ a -> let ArrayR shr _ = arrayRepr a in TupRsingle $ ArrayR shr tp - ZipWith _ _ tp _ a _ -> let TupRsingle (ArrayR shr _) = arraysRepr a + ZipWith _ _ tp _ a _ -> let ArrayR shr _ = arrayRepr a in TupRsingle $ ArrayR shr tp - Fold _ _ _ a -> let TupRsingle (ArrayR (ShapeRsnoc shr) tp) = arraysRepr a + Fold _ _ _ a -> let ArrayR (ShapeRsnoc shr) tp = arrayRepr a in TupRsingle (ArrayR shr tp) - Fold1 _ _ a -> let TupRsingle (ArrayR (ShapeRsnoc shr) tp) = arraysRepr a + Fold1 _ _ a -> let ArrayR (ShapeRsnoc shr) tp = arrayRepr a in TupRsingle (ArrayR shr tp) FoldSeg _ _ _ _ a _ -> arraysRepr a Fold1Seg _ _ _ a _ -> arraysRepr a Scanl _ _ _ a -> arraysRepr a - Scanl' _ _ _ a -> let r@(TupRsingle (ArrayR (ShapeRsnoc shr) tp)) = arraysRepr a - in r `pair` TupRsingle (ArrayR shr tp) + Scanl' _ _ _ a -> let repr@(ArrayR (ShapeRsnoc shr) tp) = arrayRepr a + in TupRsingle repr `TupRpair` TupRsingle (ArrayR shr tp) Scanl1 _ _ a -> arraysRepr a Scanr _ _ _ a -> arraysRepr a - Scanr' _ _ _ a -> let r@(TupRsingle (ArrayR (ShapeRsnoc shr) tp)) = arraysRepr a - in r `pair` TupRsingle (ArrayR shr tp) + Scanr' _ _ _ a -> let repr@(ArrayR (ShapeRsnoc shr) tp) = arrayRepr a + in TupRsingle repr `TupRpair` TupRsingle (ArrayR shr tp) Scanr1 _ _ a -> arraysRepr a Permute _ _ a _ _ -> arraysRepr a - Backpermute shr _ _ a -> let TupRsingle (ArrayR _ tp) = arraysRepr a + Backpermute shr _ _ a -> let ArrayR _ tp = arrayRepr a in TupRsingle (ArrayR shr tp) Stencil s tp _ _ _ -> TupRsingle $ ArrayR (stencilShape s) tp Stencil2 s _ tp _ _ _ _ _ -> TupRsingle $ ArrayR (stencilShape s) tp - where - pair a b = TupRpair TupRunit a `TupRpair` b instance HasArraysRepr SmartAcc where arraysRepr (SmartAcc e) = arraysRepr e @@ -1893,6 +1895,13 @@ mkPrimBinary prim (Exp a) (Exp b) = exp $ PrimApp prim (SmartExp $ Pair a b) unPair :: SmartExp (a, b) -> (SmartExp a, SmartExp b) unPair e = (SmartExp $ Prj PairIdxLeft e, SmartExp $ Prj PairIdxRight e) +mkPairToTuple :: SmartAcc (a, b) -> SmartAcc (((), a), b) +mkPairToTuple e = SmartAcc Anil `pair` a `pair` b + where + a = SmartAcc $ Aprj PairIdxLeft e + b = SmartAcc $ Aprj PairIdxRight e + pair x y = SmartAcc $ Apair x y + class ApplyAcc a where type FromApplyAcc a From 9d4e6f55f6f7ecb19c1c47e0987fc7c16891bde7 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Thu, 23 Apr 2020 10:32:42 +0200 Subject: [PATCH 183/316] Strictness of &&, ||; minor changes for acc-llvm && and || are now defined in terms of if-then-else &&! and ||! are strict variants of them, which do not short circuit --- src/Data/Array/Accelerate/AST.hs | 36 ++-- src/Data/Array/Accelerate/Analysis/Shape.hs | 1 - .../Array/Accelerate/Array/Representation.hs | 6 +- src/Data/Array/Accelerate/Classes/Eq.hs | 29 ++- src/Data/Array/Accelerate/Interpreter.hs | 6 +- src/Data/Array/Accelerate/Smart.hs | 78 +------- src/Data/Array/Accelerate/Trafo/Fusion.hs | 2 +- src/Data/Array/Accelerate/Trafo/Shrink.hs | 168 +++++++++++++----- .../Array/Accelerate/Trafo/Substitution.hs | 1 - src/Data/Array/Accelerate/Type.hs | 34 ++-- 10 files changed, 198 insertions(+), 163 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 72dab7b4f..8c0c50a97 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -83,7 +84,7 @@ module Data.Array.Accelerate.AST ( -- * Typed de Bruijn indices - Idx(..), idxToInt, Var(..), Vars(..), ArrayVar, ArrayVars, ExpVar, ExpVars, + Idx(..), idxToInt, Var(..), Vars(..), TupR(..), ArrayVar, ArrayVars, ExpVar, ExpVars, evars, varsType, LeftHandSide(..), ALeftHandSide, ELeftHandSide, -- * Valuation environment @@ -92,7 +93,7 @@ module Data.Array.Accelerate.AST ( -- * Accelerated array expressions PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc, PreBoundary(..), Boundary, StencilR(..), - HasArraysRepr(..), arrayRepr, lhsToTupR, + HasArraysRepr(..), arrayRepr, lhsToTupR, PairIdx(..), ArrayR(..), ArraysR, ShapeR(..), SliceIndex(..), VecR(..), vecRvector, vecRtuple, -- * Accelerated sequences @@ -113,10 +114,11 @@ module Data.Array.Accelerate.AST ( liftIdx, liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp, - liftALhs, liftELhs, liftArray, liftArraysR, liftTupleType, + liftALhs, liftELhs, liftArray, liftArraysR, liftTupleType, liftArrayR, + liftScalarType, liftShapeR, liftVecR, liftIntegralType, -- Utilities - Exists(..), weakenWithLHS, (:>), weakenId, weakenSucc, weakenSucc', (.>), (>:>), + Exists(..), weakenWithLHS, (:>), weakenId, weakenSucc, weakenSucc', weakenEmpty, (.>), (>:>), sink, sinkWithLHS, -- debugging @@ -270,6 +272,9 @@ weakenSucc' (Weaken f) = Weaken (SuccIdx . f) weakenSucc :: (env, t) :> env' -> env :> env' weakenSucc (Weaken f) = Weaken (f . SuccIdx) +weakenEmpty :: () :> env' +weakenEmpty = Weaken (\x -> case x of {}) + sink :: forall env env' t. env :> env' -> (env, t) :> (env', t) sink (Weaken f) = Weaken g where @@ -758,6 +763,9 @@ data PreBoundary acc aenv t where Function :: PreFun acc aenv (sh -> e) -> PreBoundary acc aenv (Array sh e) +data PairIdx p a where + PairIdxLeft :: PairIdx (a, b) a + PairIdxRight :: PairIdx (a, b) b class HasArraysRepr f where arraysRepr :: f aenv a -> ArraysR a @@ -990,7 +998,7 @@ expType expr = case expr of While _ (Lam lhs _) _ -> lhsToTupR lhs While _ _ _ -> error "What's the matter, you're running in the shadows" Const tp _ -> TupRsingle tp - PrimConst c -> primConstType c + PrimConst c -> TupRsingle $ SingleScalarType $ primConstType c PrimApp f _ -> snd $ primFunType f Index a _ -> arrayRtype $ arrayRepr a LinearIndex a _ -> arrayRtype $ arrayRepr a @@ -1089,6 +1097,12 @@ data PrimFun sig where PrimMin :: SingleType a -> PrimFun ((a, a) -> a ) -- logical operators + -- Note that these operators are strict in both arguments, + -- eg the second argument of PrimLAnd is always evaluated + -- even when the first argument is false. We thus define + -- (&&) and (||) using if-then-else to enable short-circuiting. + -- (&&!) and (||!) are strict versions of these operators, + -- which are defined using PrimLAnd and PrimLOr. PrimLAnd :: PrimFun ((Bool, Bool) -> Bool) PrimLOr :: PrimFun ((Bool, Bool) -> Bool) PrimLNot :: PrimFun (Bool -> Bool) @@ -1104,18 +1118,18 @@ data PrimFun sig where PrimFromIntegral :: IntegralType a -> NumType b -> PrimFun (a -> b) PrimToFloating :: NumType a -> FloatingType b -> PrimFun (a -> b) -primConstType :: PrimConst a -> TupleType a +primConstType :: PrimConst a -> SingleType a primConstType prim = case prim of PrimMinBound t -> boundedTp t PrimMaxBound t -> boundedTp t PrimPi t -> floatingTp t where - boundedTp :: BoundedType a -> TupleType a - boundedTp (IntegralBoundedType t) = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType t - boundedTp (NonNumBoundedType t) = TupRsingle $ SingleScalarType $ NonNumSingleType t + boundedTp :: BoundedType a -> SingleType a + boundedTp (IntegralBoundedType t) = NumSingleType $ IntegralNumType t + boundedTp (NonNumBoundedType t) = NonNumSingleType t - floatingTp :: FloatingType t -> TupleType t - floatingTp = TupRsingle . SingleScalarType . NumSingleType . FloatingNumType + floatingTp :: FloatingType t -> SingleType t + floatingTp = NumSingleType . FloatingNumType primFunType :: PrimFun (a -> b) -> (TupleType a, TupleType b) primFunType prim = case prim of diff --git a/src/Data/Array/Accelerate/Analysis/Shape.hs b/src/Data/Array/Accelerate/Analysis/Shape.hs index 188da0b8b..89884389a 100644 --- a/src/Data/Array/Accelerate/Analysis/Shape.hs +++ b/src/Data/Array/Accelerate/Analysis/Shape.hs @@ -23,7 +23,6 @@ module Data.Array.Accelerate.Analysis.Shape ( ) where import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Representation -- |Reify the dimensionality of the result type of an array computation diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index 24c462b20..191c275c2 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -512,7 +512,7 @@ vecRtuple = snd . go vecPack :: forall n single tuple. KnownNat n => VecR n single tuple -> tuple -> Vec n single vecPack vecR tuple | VectorType n single <- vecRvector vecR - , IsPrim <- getPrim single = runST $ do + , PrimDict <- getPrim single = runST $ do mba <- newByteArray (n * sizeOf (undefined :: single)) go (n - 1) vecR tuple mba ByteArray ba# <- unsafeFreezeByteArray mba @@ -528,7 +528,7 @@ vecUnpack :: forall n single tuple. KnownNat n => VecR n single tuple -> Vec n s vecUnpack vecR (Vec ba#) | VectorType n single <- vecRvector vecR , !(I# n#) <- n - , IsPrim <- getPrim single + , PrimDict <- getPrim single = go (n# -# 1#) vecR where go :: Prim single => Int# -> VecR n' single tuple' -> tuple' @@ -586,7 +586,7 @@ showElement tuple value = showElement' tuple value "" showVector :: VectorType (Vec n a) -> Vec n a -> String showVector (VectorType _ single) vec - | IsPrim <- getPrim single = "<" ++ (intercalate ", " $ showSingle single <$> vecToArray vec) ++ ">" + | PrimDict <- getPrim single = "<" ++ (intercalate ", " $ showSingle single <$> vecToArray vec) ++ ">" showArray :: ArrayR (Array sh e) -> Array sh e -> String showArray repr@(ArrayR _ tp) = showArray' (showString . showElement tp) repr diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 60fc32c94..4cc533f18 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -20,8 +20,8 @@ module Data.Array.Accelerate.Classes.Eq ( Bool(..), pattern True_, pattern False_, Eq(..), - (&&), - (||), + (&&), (&&!), + (||), (||!), not, ) where @@ -53,7 +53,14 @@ infix 4 /= -- infixr 3 && (&&) :: Exp Bool -> Exp Bool -> Exp Bool -(&&) = mkLAnd +(&&) x y = cond x y $ constant False + +-- | Conjunction: True if both arguments are true. This is a strict version of +-- '(&&)': it will always evaluate both arguments, even when the first is false. +-- +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 @@ -61,7 +68,14 @@ infixr 3 && -- infixr 2 || (||) :: Exp Bool -> Exp Bool -> Exp Bool -(||) = mkLOr +(||) x y = cond x (constant True) y + +-- | Disjunction: True if either argument is true. This is a strict version of +-- '(||)': it will always evaluate both arguments, even when the first is true. +-- +infixr 2 ||! +(||!) :: Exp Bool -> Exp Bool -> Exp Bool +(||!) = mkLOr -- | Logical negation -- @@ -105,6 +119,13 @@ instance P.Eq (Exp a) where preludeError :: String -> String -> a preludeError x y = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x y) +cond :: Elt t + => Exp Bool -- ^ condition + -> Exp t -- ^ then-expression + -> Exp t -- ^ else-expression + -> Exp t +cond (Exp c) (Exp x) (Exp y) = exp $ Cond c x y + -- To support 16-tuples, we must set the maximum recursion depth of the type -- checker higher. The default is 51, which appears to be a problem for -- 16-tuples (15-tuples do work). Hence we set a compiler flag at the top diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 599c97d26..30135452a 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -49,7 +49,7 @@ module Data.Array.Accelerate.Interpreter ( run, run1, runN, -- Internal (hidden) - evalPrim, evalPrimConst, evalUndef, evalCoerceScalar, + evalPrim, evalPrimConst, evalUndef, evalUndefScalar, evalCoerceScalar, ) where @@ -937,7 +937,9 @@ evalPreOpenExp evalAcc pexp env aenv = PrimConst c -> evalPrimConst c PrimApp f x -> evalPrim f (evalE x) Nil -> () - Pair e1 e2 -> (evalE e1, evalE e2) + Pair e1 e2 -> let !x1 = evalE e1 + !x2 = evalE e2 + in (x1, x2) VecPack vecR e -> vecPack vecR $! evalE e VecUnpack vecR e -> vecUnpack vecR $! evalE e IndexSlice slice slix sh -> restrict slice (evalE slix) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index c0df7a140..8b3120e59 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -460,11 +460,6 @@ data PreSmartAcc acc exp as where -- => seq arrs -- -> PreSmartAcc acc seq exp arrs -data PairIdx p a where - PairIdxLeft :: PairIdx (a, b) a - PairIdxRight :: PairIdx (a, b) b - - class HasArraysRepr f where arraysRepr :: f a -> ArraysR a @@ -770,7 +765,7 @@ instance HasExpType exp => HasExpType (PreSmartExp acc exp) where FromIndex shr _ _ -> shapeType shr Cond _ e _ -> expType e While t _ _ _ -> t - PrimConst c -> primConstType c + PrimConst c -> TupRsingle $ SingleScalarType $ primConstType c PrimApp f _ -> snd $ primFunType f Index tp _ _ -> tp LinearIndex tp _ _ -> tp @@ -947,75 +942,6 @@ instance (Stencil (sh:.Int) a row8, -- Auxiliary tuple index constants -- -{- -prjTail :: SmartExp (t, a) -> SmartExp t -prjTail = SmartExp . Prj PairIdxLeft - -prj0 :: ( Elt a) - => SmartExp (t, EltRepr a) -> Exp a -prj0 = exp . Prj PairIdxRight - -prj1 :: ( Elt a) - => SmartExp ((t, EltRepr a), s0) -> Exp a -prj1 = prj0 . prjTail - -prj2 :: ( Elt a) - => SmartExp (((t, EltRepr a), s1), s0) -> Exp a -prj2 = prj1 . prjTail - -prj3 :: ( Elt a) - => SmartExp ((((t, EltRepr a), s2), s1), s0) -> Exp a -prj3 = prj2 . prjTail - -prj4 :: ( Elt a) - => SmartExp (((((t, EltRepr a), s3), s2), s1), s0) -> Exp a -prj4 = prj3 . prjTail - -prj5 :: ( Elt a) - => SmartExp ((((((t, EltRepr a), s4), s3), s2), s1), s0) -> Exp a -prj5 = prj4 . prjTail - -prj6 :: ( Elt a) - => SmartExp (((((((t, EltRepr a), s5), s4), s3), s2), s1), s0) -> Exp a -prj6 = prj5 . prjTail - -prj7 :: ( Elt a) - => SmartExp ((((((((t, EltRepr a), s6), s5), s4), s3), s2), s1), s0) -> Exp a -prj7 = prj6 . prjTail - -prj8 :: ( Elt a) - => SmartExp (((((((((t, EltRepr a), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a -prj8 = prj7 . prjTail - -prj9 :: ( Elt a) - => SmartExp ((((((((((t, EltRepr a), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a -prj9 = prj8 . prjTail - -prj10 :: ( Elt a) - => SmartExp (((((((((((t, EltRepr a), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a -prj10 = prj9 . prjTail - -prj11 :: ( Elt a) - => SmartExp ((((((((((((t, EltRepr a), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a -prj11 = prj10 . prjTail - -prj12 :: ( Elt a) - => SmartExp (((((((((((((t, EltRepr a), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a -prj12 = prj11 . prjTail - -prj13 :: ( Elt a) - => SmartExp ((((((((((((((t, EltRepr a), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a -prj13 = prj12 . prjTail - -prj14 :: ( Elt a) - => SmartExp (((((((((((((((t, EltRepr a), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a -prj14 = prj13 . prjTail - -prj15 :: ( Elt a) - => SmartExp ((((((((((((((((t, EltRepr a), s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> Exp a -prj15 = prj14 . prjTail --} - prjTail :: SmartExp (t, a) -> SmartExp t prjTail = SmartExp . Prj PairIdxLeft @@ -1067,8 +993,6 @@ prj14 = prj13 . prjTail prj15 :: SmartExp ((((((((((((((((t, a), s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a prj15 = prj14 . prjTail - - -- Smart constructor for literals -- diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index b82ba6fcc..4f3549147 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -1221,7 +1221,7 @@ combineLhs = go weakenId weakenId go k1 k2 (LeftHandSideWildcard _) lhs | Exists lhs' <- rebuildLHS lhs = CombinedLHS lhs' (weakenWithLHS lhs' .> k1) (sinkWithLHS lhs lhs' k2) go k1 k2 lhs (LeftHandSideWildcard _) - | Exists lhs' <- rebuildLHS lhs = CombinedLHS lhs' (sinkWithLHS lhs lhs' k1) (weakenWithLHS lhs' .> k2) + | Exists lhs' <- rebuildLHS lhs = CombinedLHS lhs' (sinkWithLHS lhs lhs' k1) (weakenWithLHS lhs' .> k2) data CombinedLHS s t env1' env2' env where CombinedLHS :: LeftHandSide s t env env' -> env1' :> env' -> env2' :> env' -> CombinedLHS s t env1' env2' env diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index dbed5e2ea..a7dabed83 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -4,6 +4,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -43,6 +44,7 @@ module Data.Array.Accelerate.Trafo.Shrink ( -- standard library import Control.Applicative hiding ( Const ) import Prelude hiding ( exp, seq ) +import Data.Maybe ( isJust ) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup @@ -52,9 +54,9 @@ import Data.Monoid -- 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 Data.Array.Accelerate.Error import qualified Data.Array.Accelerate.Debug.Stats as Stats @@ -71,20 +73,21 @@ instance Kit acc => Shrink (PreOpenExp acc env aenv e) where instance Kit acc => Shrink (PreOpenFun acc env aenv f) where shrink' = shrinkFun -data VarsRange = VarsRange !Int !Int !RangeTuple -- first, count, tuple +data VarsRange = VarsRange !Int !Int !(Maybe RangeTuple) -- first, count, tuple data RangeTuple = RTNil | RTSingle | RTPair !RangeTuple !RangeTuple -lhsVarsRange :: LeftHandSide s v env env' -> Maybe VarsRange -lhsVarsRange (LeftHandSideWildcard TupRunit) = Just $ VarsRange 0 0 RTNil -lhsVarsRange (LeftHandSideSingle _) = Just $ VarsRange 0 1 RTSingle -lhsVarsRange (LeftHandSidePair l1 l2) - | Just (VarsRange _ n1 t1) <- lhsVarsRange l1 - , Just (VarsRange _ n2 t2) <- lhsVarsRange l2 = Just $ VarsRange 0 (n1 + n2) $ RTPair t1 t2 -lhsVarsRange _ = Nothing +lhsVarsRange :: LeftHandSide s v env env' -> VarsRange +lhsVarsRange (LeftHandSideWildcard TupRunit) = VarsRange 0 0 $ Just RTNil +lhsVarsRange (LeftHandSideWildcard _) = VarsRange 0 0 Nothing +lhsVarsRange (LeftHandSideSingle _) = VarsRange 0 1 $ Just RTSingle +lhsVarsRange (LeftHandSidePair l1 l2) = VarsRange 0 (n1 + n2) $ RTPair <$> t1 <*> t2 + where + VarsRange _ n1 t1 = lhsVarsRange l1 + VarsRange _ n2 t2 = lhsVarsRange l2 lhsSize :: LeftHandSide s v env env' -> Int lhsSize (LeftHandSideWildcard _) = 0 @@ -95,39 +98,94 @@ weakenVarsRange :: LeftHandSide s v env env' -> VarsRange -> VarsRange weakenVarsRange lhs (VarsRange i n t) = VarsRange (i + lhsSize lhs) n t matchEVarsRange :: VarsRange -> PreOpenExp acc env aenv t -> Bool -matchEVarsRange (VarsRange _ _ RTNil) Nil = True -matchEVarsRange (VarsRange i' _ RTSingle) (Evar (Var _ ix')) = go i' ix' +matchEVarsRange (VarsRange first _ (Just rt)) expr = isJust $ go first rt expr where - go :: Int -> Idx env t -> Bool - go 0 ZeroIdx = True - go i (SuccIdx ix) = go (i - 1) ix - go _ _ = False -matchEVarsRange (VarsRange i _ (RTPair t1 t2)) (Pair e1 e2) - = matchEVarsRange (VarsRange i 0 t1) e1 - && matchEVarsRange (VarsRange i 0 t2) e2 + go :: Int -> RangeTuple -> PreOpenExp acc env aenv t -> Maybe Int + go i RTNil Nil = Just i + go i RTSingle (Evar (Var _ ix)) + | checkIdx i ix = Just (i + 1) + go i (RTPair t1 t2) (Pair e1 e2) + | Just i' <- go i t1 e1 = go i' t2 e2 + go _ _ _ = Nothing + + checkIdx :: Int -> Idx env t -> Bool + checkIdx 0 ZeroIdx = True + checkIdx i (SuccIdx ix) = checkIdx (i - 1) ix + checkIdx _ _ = False matchEVarsRange _ _ = False -varInRange :: VarsRange -> Var s env t -> Bool -varInRange (VarsRange i n _) (Var _ ix) = i <= j && j < i + n +varInRange :: VarsRange -> Var s env t -> Maybe Usages +varInRange (VarsRange i n _) (Var _ ix) + | 0 <= j && j < n = Just $ replicate j False ++ [True] ++ replicate (n - j - 1) False + | otherwise = Nothing where - j = idxToInt ix + j = n - 1 - (idxToInt ix - i) +-- Describes how often the variables defined in a LHS are used together. data Count - = Impossible -- Cannot inline this definition. This happens when the definition declares multiple variables (the right hand side returns a tuple) and the variables are used seperately. - | Infinity -- The variable is used in a loop. Inlining should only proceed if the computation is cheap. + = Impossible !Usages -- Cannot inline this definition. This happens when the definition declares multiple variables (the right hand side returns a tuple) and the variables are used seperately. + | Infinity -- The variable is used in a loop. Inlining should only proceed if the computation is cheap. | Finite {-# UNPACK #-} !Int +type Usages = [Bool] -- Per variable a Bool denoting whether that variable is used. + instance Semigroup Count where - Impossible <> _ = Impossible - _ <> Impossible = Impossible - Infinity <> _ = Infinity - _ <> Infinity = Infinity - Finite a <> Finite b = Finite $ a + b + Impossible u1 <> Impossible u2 = Impossible $ zipWith (||) u1 u2 + Impossible u <> Finite 0 = Impossible u + Finite 0 <> Impossible u = Impossible u + Impossible u <> _ = Impossible $ map (const True) u + _ <> Impossible u = Impossible $ map (const True) u + Infinity <> _ = Infinity + _ <> Infinity = Infinity + Finite a <> Finite b = Finite $ a + b loopCount :: Count -> Count loopCount (Finite n) | n > 0 = Infinity loopCount c = c +shrinkLhs :: Count -> LeftHandSide s t env1 env2 -> Maybe (Exists (LeftHandSide s t env1)) +shrinkLhs _ (LeftHandSideWildcard _) = Nothing -- We cannot shrink this +shrinkLhs (Finite 0) lhs = Just $ Exists $ LeftHandSideWildcard $ lhsToTupR lhs -- LHS isn't used at all, replace with a wildcard +shrinkLhs (Impossible usages) lhs = case go usages lhs of + (True , [], lhs') -> Just lhs' + (False, [], _ ) -> Nothing -- No variables were dropped. Thus lhs == lhs'. + _ -> $internalError "shrinkLhs" "Mismatch in length of usages array and LHS" + where + go :: Usages -> LeftHandSide s t env1 env2 -> (Bool, Usages, Exists (LeftHandSide s t env1)) + go us (LeftHandSideWildcard tp) = (False, us, Exists $ LeftHandSideWildcard tp) + go (True : us) (LeftHandSideSingle tp) = (False, us, Exists $ LeftHandSideSingle tp) + go (False : us) (LeftHandSideSingle tp) = (True , us, Exists $ LeftHandSideWildcard $ TupRsingle tp) + go us (LeftHandSidePair l1 l2) + | (c1, us' , Exists l1') <- go us l1 + , (c2, us'', Exists l2') <- go us' l2 + , Exists l2'' <- rebuildLHS l2' + = let + lhs' + | LeftHandSideWildcard t1 <- l1' + , LeftHandSideWildcard t2 <- l2'' = LeftHandSideWildcard $ TupRpair t1 t2 + | otherwise = LeftHandSidePair l1' l2'' + in + (c1 || c2, us'', Exists lhs') + go _ _ = $internalError "shrinkLhs" "Empty array, mismatch in length of usages array and LHS" +shrinkLhs _ _ = Nothing + +-- The first LHS should be 'larger' than the second, eg the second may have a wildcard if the first LHS does bind variables there, +-- but not the other way around. +strengthenShrunkLHS :: LeftHandSide s t env1 env2 -> LeftHandSide s t env1' env2' -> env1 :?> env1' -> env2 :?> env2' +strengthenShrunkLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k +strengthenShrunkLHS (LeftHandSideSingle _) (LeftHandSideSingle _) k = \ix -> case ix of + ZeroIdx -> Just ZeroIdx + SuccIdx ix' -> SuccIdx <$> k ix' +strengthenShrunkLHS (LeftHandSidePair lA hA) (LeftHandSidePair lB hB) k = strengthenShrunkLHS hA hB $ strengthenShrunkLHS lA lB k +strengthenShrunkLHS (LeftHandSideSingle _) (LeftHandSideWildcard _) k = \ix -> case ix of + ZeroIdx -> Nothing + SuccIdx ix' -> k ix' +strengthenShrunkLHS (LeftHandSidePair l h) (LeftHandSideWildcard t) k = strengthenShrunkLHS h (LeftHandSideWildcard t2) $ strengthenShrunkLHS l (LeftHandSideWildcard t1) k + where + TupRpair t1 t2 = t +strengthenShrunkLHS (LeftHandSideWildcard _) _ _ = $internalError "strengthenShrunkLHS" "Second LHS defines more variables" +strengthenShrunkLHS _ _ _ = $internalError "strengthenShrunkLHS" "Mismatch LHS single with LHS pair" + -- Shrinking -- ========= @@ -162,20 +220,29 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE | shouldInline -> case inlineVars lhs (snd body') (snd bnd') of Just inlined -> Stats.betaReduce msg . yes $ shrinkE inlined _ -> error "shrinkExp: Unexpected failure while trying to inline some expression." + | Just (Exists lhs') <- shrinkLhs count lhs -> case strengthenE (strengthenShrunkLHS lhs lhs' Just) (snd body') of + Just body'' -> (Any True, Let lhs' (snd bnd') body'') + Nothing -> error "shrinkExp: Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." | otherwise -> Let lhs <$> bnd' <*> body' where - shouldInline = case uses of - Finite n -> n <= lIMIT || cheap (snd bnd') - Infinity -> cheap (snd bnd') - Impossible -> False + shouldInline = case count of + Finite n -> n <= lIMIT || cheap (snd bnd') + Infinity -> cheap (snd bnd') + Impossible _ -> False bnd' = shrinkE bnd body' = shrinkE body - uses = case lhsVarsRange lhs of - Nothing -> Impossible - Just range -> usesOfExp range (snd body') + range = lhsVarsRange lhs + -- If the lhs includes non-trivial wildcards (the last field of range is Nothing), + -- then we cannot inline the binding. We can only check which variables are not used, + -- to detect unused variables. + -- If the lhs does not include non-trivial wildcards (the last field of range is a Just), + -- we can both analyse whether we can inline the binding, and check which variables are + -- not used, to detect unused variables. + + count = usesOfExp range (snd body') - msg = case uses of + msg = case count of Finite 0 -> "dead exp" _ -> "inline exp" -- forced inlining when lIMIT > 1 -- @@ -211,8 +278,17 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE yes (_, x) = (Any True, x) shrinkFun :: Kit acc => PreOpenFun acc env aenv f -> (Bool, PreOpenFun acc env aenv f) -shrinkFun (Lam l f) = Lam l <$> shrinkFun f -shrinkFun (Body b) = Body <$> shrinkExp b +shrinkFun (Lam lhs f) + | Just (Exists lhs') <- shrinkLhs count lhs = case strengthenE (strengthenShrunkLHS lhs lhs' Just) f' of + Just f'' -> (True, Lam lhs' f'') + Nothing -> error "shrinkFun: Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." + | otherwise = (b, Lam lhs f') + where + (b, f') = shrinkFun f + range = lhsVarsRange lhs + count = usesOfFun range 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 @@ -354,11 +430,11 @@ usesOfExp range = countE countE :: PreOpenExp acc env aenv e -> Count countE exp | matchEVarsRange range exp = Finite 1 countE exp = case exp of - Evar v - | varInRange range v -> Impossible - | otherwise -> Finite 0 + Evar v -> case varInRange range v of + Just cs -> Impossible cs + Nothing -> Finite 0 -- - Let lhs bnd body -> countE bnd <> usesOfExp (weakenVarsRange lhs range) body + Let lhs bnd body -> countE bnd <> usesOfExp (weakenVarsRange lhs range) body Const _ _ -> Finite 0 Undef _ -> Finite 0 Nil -> Finite 0 @@ -370,7 +446,7 @@ usesOfExp range = countE FromIndex _ sh i -> countE sh <> countE i ToIndex _ sh e -> countE sh <> countE e Cond p t e -> countE p <> countE t <> countE e - While p f x -> countE x <> loopCount (countF range p) <> countF range f + While p f x -> countE x <> loopCount (usesOfFun range p) <> usesOfFun range f PrimConst _ -> Finite 0 PrimApp _ x -> countE x Index _ sh -> countE sh @@ -380,9 +456,9 @@ usesOfExp range = countE Foreign _ _ e -> countE e Coerce _ _ e -> countE e - countF :: VarsRange -> PreOpenFun acc env' aenv f -> Count - countF range' (Lam lhs f) = countF (weakenVarsRange lhs range') f - countF range' (Body b) = usesOfExp range' b +usesOfFun :: VarsRange -> PreOpenFun acc env aenv f -> Count +usesOfFun range' (Lam lhs f) = usesOfFun (weakenVarsRange lhs range') f +usesOfFun range' (Body b) = usesOfExp range' b -- 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 diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 74bed7bfd..bb68bf949 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -49,7 +49,6 @@ import Control.Monad import Prelude hiding ( exp, seq ) import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Type import Data.Array.Accelerate.Array.Representation import Data.Array.Accelerate.Analysis.Match import qualified Data.Array.Accelerate.Debug.Stats as Stats diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index 4e3b4cb52..51427337d 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -439,26 +439,26 @@ vecToArray (Vec ba#) = go 0# instance Eq (Vec n a) where Vec ba1# == Vec ba2# = ByteArray ba1# == ByteArray ba2# -data IsPrim a where - IsPrim :: Prim a => IsPrim a +data PrimDict a where + PrimDict :: Prim a => PrimDict a -getPrim :: SingleType a -> IsPrim a +getPrim :: SingleType a -> PrimDict a getPrim (NumSingleType (IntegralNumType tp)) = case tp of - TypeInt -> IsPrim - TypeInt8 -> IsPrim - TypeInt16 -> IsPrim - TypeInt32 -> IsPrim - TypeInt64 -> IsPrim - TypeWord -> IsPrim - TypeWord8 -> IsPrim - TypeWord16 -> IsPrim - TypeWord32 -> IsPrim - TypeWord64 -> IsPrim + TypeInt -> PrimDict + TypeInt8 -> PrimDict + TypeInt16 -> PrimDict + TypeInt32 -> PrimDict + TypeInt64 -> PrimDict + TypeWord -> PrimDict + TypeWord8 -> PrimDict + TypeWord16 -> PrimDict + TypeWord32 -> PrimDict + TypeWord64 -> PrimDict getPrim (NumSingleType (FloatingNumType tp)) = case tp of - TypeHalf -> IsPrim - TypeFloat -> IsPrim - TypeDouble -> IsPrim -getPrim (NonNumSingleType TypeChar) = IsPrim + TypeHalf -> PrimDict + TypeFloat -> PrimDict + TypeDouble -> PrimDict +getPrim (NonNumSingleType TypeChar) = PrimDict getPrim (NonNumSingleType TypeBool) = error "prim: We don't support vector of bools yet" From e79220d2fc9b03dc57bbdc675cad92787e55439b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 23 Apr 2020 12:47:29 +0200 Subject: [PATCH 184/316] explicit import list --- src/Data/Array/Accelerate/Error.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Error.hs b/src/Data/Array/Accelerate/Error.hs index 97cc7812f..7e12eef7a 100644 --- a/src/Data/Array/Accelerate/Error.hs +++ b/src/Data/Array/Accelerate/Error.hs @@ -21,7 +21,7 @@ module Data.Array.Accelerate.Error ( ) where -import Data.List +import Data.List ( intercalate ) import Debug.Trace import Language.Haskell.TH hiding ( Unsafe ) From 0b5d81dd62bc6b6004f9a60df92a7485fe5aac45 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 23 Apr 2020 15:08:53 +0200 Subject: [PATCH 185/316] update README.md --- README.md | 27 ++++++++++++++++----------- images/accelerate-logo-text-v.png | Bin 0 -> 207024 bytes 2 files changed, 16 insertions(+), 11 deletions(-) create mode 100644 images/accelerate-logo-text-v.png diff --git a/README.md b/README.md index 78676ceec..bf9d66629 100644 --- a/README.md +++ b/README.md @@ -1,13 +1,17 @@ -An Embedded Language for Accelerated Array Computations -======================================================= +
+henlo, my name is Theia + +# High-performance parallel arrays for Haskell [![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) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +
[![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. @@ -122,12 +126,7 @@ The [accelerate-examples][accelerate-examples] package provides a range of compu [LULESH-accelerate][lulesh-accelerate] is in implementation of the Livermore Unstructured Lagrangian Explicit Shock Hydrodynamics (LULESH) mini-app. [LULESH][LULESH] represents a typical hydrodynamics code such as [ALE3D][ALE3D], but is a highly simplified application, hard-coded to solve the Sedov blast problem on an unstructured hexahedron mesh. -![LULESH mesh](https://computation.llnl.gov/system/files/142_1.PNG) - - -### Λ ○ λ (Lol) - -Λ ○ λ ([Lol][lol]) is a general-purpose library for ring-based lattice cryptography. Lol has applications in, for example, symmetric-key somewhat-homomorphic encryption schemes. The [lol-accelerate][lol-accelerate] package provides an Accelerate backend for Lol. +![LULESH mesh](https://i.imgur.com/bIkODKd.jpg) ### Additional examples @@ -135,6 +134,9 @@ The [accelerate-examples][accelerate-examples] package provides a range of compu Accelerate users have also built some substantial applications of their own. Please feel free to add your own examples! + * Jonathan Fraser, [GPUVAC](https://github.com/GeneralFusion/gpuvac): An explicit advection magnetohydrodynamics simulation + * David van Balen, [Sudokus](https://github.com/dpvanbalen/Sudokus): A sudoku solver + * Trevor L. McDonell, [lol-accelerate][lol-accelerate]: A backend to the Λ ○ λ ([Lol][lol]) library for ring-based lattice cryptography * Henning Thielemann, [patch-image](http://hackage.haskell.org/package/patch-image): Combine a collage of overlapping images * apunktbau, [bildpunkt](https://github.com/abau/bildpunkt): A ray-marching distance field renderer * klarh, [hasdy](https://github.com/klarh/hasdy): Molecular dynamics in Haskell using Accelerate @@ -155,6 +157,7 @@ The Accelerate team (past and present) consists of: * Joshua Meredith ([@JoshMeredith]) * Ben Lever ([@blever]) * Sean Seefried ([@sseefried]) + * Ivo Gabe de Wolff ([@ivogabe]) The maintainer and principal developer of Accelerate is Trevor L. McDonell . @@ -164,8 +167,9 @@ Mailing list and contacts ------------------------- * Mailing list: [`accelerate-haskell@googlegroups.com`](mailto:accelerate-haskell@googlegroups.com) (discussions on both use and development are welcome) - * Sign up for the mailing list at the [Accelerate Google Groups page][Google-Group]. - * Bug reports and issues tracking: [GitHub project page][Issues]. + * Sign up for the mailing list at the [Accelerate Google Groups page][Google-Group] + * Bug reports and issues tracking: [GitHub project page][Issues] + * Chat with us on [gitter](https://gitter.im/AccelerateHS/Lobby) Citing Accelerate @@ -218,6 +222,7 @@ Here is a list of features that are currently missing: [@JoshMeredith]: https://github.com/JoshMeredith [@blever]: https://github.com/blever [@sseefried]: https://github.com/sseefried + [@ivogabe]: https://github.com/ivogabe [CKLM+11]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-cuda-damp2011.pdf [MCKL13]: https://github.com/tmcdonell/tmcdonell.github.io/raw/master/papers/acc-optim-icfp2013.pdf diff --git a/images/accelerate-logo-text-v.png b/images/accelerate-logo-text-v.png new file mode 100644 index 0000000000000000000000000000000000000000..a0be315cd6b87ae2c3d640452c7910ae62967b33 GIT binary patch literal 207024 zcmeFY^;?tw`vyD{gK#P#sl#9(At|i_f}>knMX3?OfYGTiT3YFFq=2-vinI*L(G3Fz zj2^w`9{T>SJ!S0xxhpqrp)vX8Y~l9tEZKPJC%}FM=FJ6DM5Labh@Vaxm zo*+VGIR!-ezpwvg;C~tTUk3h{f&XRTe;N4yAp@#+I-UL!t&#~^!&Mz->3Y2>1^UV| zoI~SR56a@#HLMq*3mlP^#1@7+V4oK6#9$5r*gUswL5>8i{@4|}z zt|67DgDiTQloUK2ih9nfdPzz-Ald8{TS(*cI(~sBu z)W|mnZOUir7u2slo63f~a{iH>y~&iGgCdRHkLP7Du3XJt8N3Yq((to?w<*-luff95 z+L4=|!0N%mfvG7lOw|o=XG~9^qMUs_wL0+2){1A-$yWx=x7(dhYk!d9nXrkkxaONv zE{c|BULug5gd#&vgFrs6HW<~MlMFgP+!O?r=LSW(cDC+?pfwi1Y~!&-pYRF5RVEjI z=U;=9ujjKeEPTbsjem@M`9YoE_-odGzx`8~!DqOyc~uQedd?Y)T%bM&q{gGHGsyzT z5fG3+W4Zpyvch5kxSM|DIcTZP0n@3l=*zsWa&oDUb`?X{Y=K|=*w@`%{Kb%`NI|an zzWj34CmDzKy`5sz0V^AGtt4c?X71{#!F8qcX_%mOkQVqsieJJ=iJ6@#GAF5FaCu=j zdddm!C59CO*7WGz&FjDwM{?SKzIV@xj6`U_?#W}^f9;B{&SK|hgNn>%Jv;@__yCIY z$M*34%iqH@b@Gpfb{KrzN|F!)5LRU{JvAkz2S>9!4!GR+q@h)ndf?4qy*3@sXeq-D zQC^5K{ftO_w$Lk!jF6^T>~QN|&yOEJE)Q#RgT$j?bzW{zGy;KfZ_>H+ND|SVvCAt? zY?=yWIbQP%51+c{O==+>&yY6$cpsZ@9}_&K!$_B`3))uIM5n_Y)N37%_P62s^%sFP zC`JBVN~nH;v+-v~TiNSS^ebWb+`ZNFBJAi?A$j=;J_!krmgW4jFXT0IwT!i5U~DMV z8TO3p-Sr?XBvQ9_@`Fr(@n!}6xvhv|Lvt4UtP8&2kj4s&|u zlKF-_@-V3IkQK~*-aZl$F5a-;Z$j!M9VQyp?{t!SOH|aaHE3d=Vp^!FsmGaS#^{0c zzsLul1Yn$x#djcJsUb=9m5ACuciA^tAMnula9e2Mx3!_uNencPl;KKvM`q-fx{P=A z(x@-GBW^nuhHhKy{X$Hjl#|^0BNI`#Bb2@EaZrC?a21uXOsUNoY>F*1X>c333@q}y z;Dsl^9r^6~@!NBv(*vjl8}kcRJ$9iTA-g*Zt*uPL)`M@oYl!DwjHu^gO>|`quY*0i zn?Zd&N5l|SuccnR^MofcMI%>m@2&VwyQ!(^dTgSd@us|;yTJr6t6R>UTluJ6%;fj) z1leB;%Zg{o>9t&Z2;3875&JZ=JCU6yq~N+=@W*e7lJ&Y^Fh#7m*lJ&$ufu-%lU{nYDE1ZSq1*^s5gC=^ZgP}mew;4>W%ldTN6|LZ%qs##<&e$GxUQf#j zN#eNp){<_$!$Y)S{(#!GqK=Ki!a_u&kOgql3J6O&@bVGK81|IVy0E|vw*NkG>9Gw) zRzAc`*2Dd+^>QBrtJm8?t5Yvl`>e{fBYUd4n;*Ei^Xf4ZNcaZV-6naqI>lT=+o21! zmhGKp0=6}aS#gem?V=*=IGOVl6ojDl^-|y#e{@d3@3%;(5i-WA^L z;MF+e?~m=Wd(6THb+Ofje2BLwG&D0lX28%-i0VgH9Jf(XIk8^Ju=l z=d&KilarI@5c*d@Ho67aiB!lq=3vDJmlfMdu0sxyl5 z+<2~7*yaP!Hj@L!_3eunyV^x=+Vw{m@qB?r>R80_5U_6$kXN6n?vS_Y)6Jc;0Hyh` zDApO9q_Ep6LstaHaH};$DptPQ2i+@Y$!zrP&{EnvlFGxuap3Xompe$_YbLg3!7bc|-iz338>kn2X z(HfQ;Q#Nz^*0#cl>k}9;{Cd7QA17~w^wdXRU*8c3#BQC8U3@Yl?Lor8n~`E*M~m}| zxhcvr^Nl594p!@Q>o+k)RM@5M_Fl*SRxlXYFkb5+CK5a0(q0C*c-wlkSg+f?pK78G z$3KAwl`CLG;p3XAUWAp7WA_q)zzQfI*)aPee?O>+>6mK^tZc)V0GA*g1xnZMNapKo z3nz9izE6h~GA$FNg&StP}5zl3#Q+3XB`>Lv&P#&4|qI=my6b=_0*qYdsUC z6=o56+0d}CCM2Q3yVGENV?LQc8Yh~oZQOmCgW?KpJ2U7^esC)b%eBI|THR0)U#m8u zUUMG(>ulA#)BP>1NJEoc!xSR>S{5fR$z*d$mug}S?VYQXEue*|()(PN)6hU7m6u8Z zaX4Ey8PWr<-@^+A#*Q{n4-t27hj8@D$}%g z;>JjAjK=<^#_k1G^P8zf zD%o6GU@!ow-|j*ZR`RLIdwIwic@=o`U6@@PzipuTE3&tCFNw7D^D;KY6C+y3&1e#n z*lFf5ubHa9xr3}j;D8d#Zuq|YvDVC1ctQ#QhQ(eMgIq10>vF}fq66dRV(79^><+(J zT&3SxvW?DyH2ZU~c(x9313g%d%PZcR*&lhh?m6e+x-qq~KMco+5*jAF)+c$r z9u%y*_@6lwi(;@ewFI)Y{JjDnZ4bPeFS07%AJDqamSlTj>0LalxW~2-R!9H3-|#ov z(xFhh33tNqHB~9g>`(8~ArJ?QX=KkCAcCHxO+YX~(Qlw=+Q^=^2i;*y&r|`uS@uAU zc0E1a*H`+}y6TzlX8-T4R%UU1T+ckEYSq(wot{NfQnEj2&iNy}(A#tBeLiX9h(Le~ zCu$ylN(2`%kaeEytZ*E_+TW?I0!5(|WTl%U$QTmR-R-UctLt?g-#~YDAV>GgIf64- zaHXO+W@*x17n}Ip+&vMm!{}6uM`UNj;WI#O1j7Z{r`vz{`ilI{xd8G~EZ3J5r)`o0 zcY_}ssGkr(yop!S(wmNWBAH_YkvaGRfX<5sjv5J-Un*6m!#)y`O}Mb{=uU9?tPj2##i5>2ooHHnF-dcOzO>kd)kG-VHZ+ zqck{e=HczQ$!jfzU;6R!oj@=tYPrkm`B*!c-1-mH!pGgDlzu{#rmE z0n$l(SkFLd^y7-HASXFX9)}O)Y06z2vUy(fQ)=fYi|7i0tnqpMOGD)vi-o9%oDf(k z)uWYa3w6WIMb)DE<#sN5Ml9&&1AS2slR9(T7l`DzYfmj2zF`8ExJ$qS9^H|FDE8= zULR5)1f#wc4p~b{&nQ}NVFs}9zU_rMH zoOd|NEc{z$OwYNaqa%~Ct;EY#<I_={kl9zC8_1=rFTh) z@!TTbr%#_|jW0f!_B%d4mX1J~9dH61{X%~B9Saa|L56V=Zx@)T6zY)}^)&MyX@Nr8 zqqZhHdyIWOMFk_;Qb!yu-6`u;8CjI}+IFN;7}k9x@M>=D`*&>vPlQiF+FwSjMGZnB z%_H14x4y?9QYdA|jA4s@k!GdY*Vn5R7GpjxyqgGCcS${*y~ifHmgeuKh+e;AUOK*G z)dc1Zc5gtKgf`qUh=UXo2n26A+0cqgejtg?f|~WaKvF@a9}>Xys`t*uYP9QmEziKK z-QDQQO26jDMooYBr(UW9SUqrO2;P=-T}}3IPiKN5t&=mh9Sl5AgIo@tAXGAYhQhUq ztEx88zKGqfSK0yvQY=5lt~P%Quf!TDdVY}dm{`eMiQqPlTR?p1v@fPzaPM4_eGeF z=Zn&P5jHRSPJ??%Z=ZOpE8#UZSy%Fa&e4Y@@tO;eiQ&9%i>>g`@bPF3eTjbDas|F{ zZ`{t?Jx3?Me^_sXa;~_z*rjD;d}pwwu(qUFTLj~}(i%X;%X;HRl^uNb@*h}oaWnD_B!m@GURqrZ?vUOu23XqLBb7%@Qv^_uyT5^MM2w%Ge;dn%%cMAe-ZsS2 zF$yS3AMS22U=jFKFy6Q!dJnRbw6qSeVr9HxNtRB&_K0r(m(Lox*V(?!Mx`{=PWs7L zY>ZzP7ZbP3AHdUVbH>sdxZ3&X<@a0Vx3jPyo9-H=%~xkVBg^H9!)6gI3-ag1Cu+S~ zxjOkZJo+Bf!bzZRq2b2Y!IvvtX5Rr7DCMb)B6$tZ-+hcbzcYp z_=erqpnIuhy;(1FJa_c30{P-EBS;+_@1t8-Ovd38o>pBh%>r)hkl>6Q*S8Krfd9$Q_Fxd9iRINqI{+_u>j6@fo4aCU&AHzBWv zWF?`^q|IOM@fti3W1ypCvw2$U>GEPSuRxoP&s!_Mzf@B_i5~3v;P`>CozzTCP0jQe z!2`=qI*K^XsWcpS$#op>tK=R+PT&q3ws=jvc3g~+9S$(}cUZEnqC;c=68MpU7Gqdb z)51bSc1)I7oMZzonP9kSj!VYUj|}Wt0jP6C9IKo+m)>jpQ{Uxjiv!g4K`089!Qmh) z3xnQWJ+RxswTt2!YPNdHHK}B5Dtu6YcQFPiVti)jSUl(U{tdZba}Sydd6@8ui@r&l zPJp`DC+nLLJ$61`L96Y3A@KS%iXl}U6SCgE1>Jio!>hd@IQN@F<@&FC!(P0ydUHLD5UYmIDA)vu3C zS6PLlT1BO8CKoN~KfYnGdKG5&d8;(Ch0VJOpbJj{BlF8-#>s}FEwOvE#a`Xk#zGGt zx_IFg&(06~>92g&fWCHPK#nb8~x_rf-qzNgR5U zV7I;c56R+BzaUaKR}q&n{}0$Nq{ z737y#%NrY24OLZQj7ittmN~$BJ}ZB<4Y#(X;EoblUS)eXMx%bx6Gs}R>bBpMq>R-R zD~ZJ`59rGp0-K*V1oe~)OW~!7))39m$xk)_I6V*0Sp8Pzn@ijK8$*Q#`TaU%3!+_= zz{0(Bx||r*RNQ5(Xjb#PnMX}zbhoR2JlR=4?XuRv{c+QXj~D}!{QkK2L^6)jadw?p zwLshTK+J7b(AEbR&*J`jEmEGPT+twZxLGM69WotB{GwmptAuS8B|1Agj|*#XvM@9@ z(o|$rWKj8*2TAjylQ!G+>*_sTHwIuMLPJNfOP(*})pE7MIf7rwsaVP>omJ{_`To{Y zqWjchP(v$JF8pDoPSHdvJ8PKP=01?i{DA_4O6OpvRdue|!XSVZ4%uG~q=EtXz0S5j zNukRoFb?HAYLu7SXm!^qSn3p2bzh-p^%|VamiBZi{#se73bHzW2IWq|0|gFvfe+Wo zW%1^pVX~AP-lPbfV>_Oth*+r@v8@K#JjIBT#?bMF$(9UO4q>R>9iVMjguEKFhUX!j zJcS@Sznzn_`PB)-X1~~IXebT)3q4=dr~`^td2v?j`n{IjiB3q$tJ#s>_c3>mSLI{@ z8Q$HxHwgHQ?y0tTt8zDI&frZ*2CshKxuq|$T-Z9&bclQV+{SD3^cVyNYv{S1Ank<{ z-ybM&w}!a`YP3ntdsAAMbZnWe9R4HZEqB>UxS_r5=;jLH*ER2?ikmpo^8o*ap`cP^ zA1WoKo6N*zzXPb4FdwZha6+cf1+rePS*b8k6^9SUmA_RQKLr%_G#%~sBgFyN_PJDs zSino+wZa*HrGk?o6eu4ffIM1qIiwiCyg?`j7|{4}_LxbG`6V*z1f!B6=tQ8@4^pg1 zZgs~)L7vEPx_44A5yCU~Q{8T00iRl&{rO)$cg07Q852G=(O|LEXFO@beZ`JlYyD!xKd7I;yf37nej5c zPUz2(eL6=+N>$vh;dS?S#0w{tWOvf650<#q)dL>6X#Y&Sq#fz`dQ|*!PjgfSQ#4>w zxV+9X-Ozx^g}d0HjlEwO+z^e|;B>%H48YLt39;>50fB*bsrZB!Jb*FC9;~rAih2$f zjn9xXT}V-ZLFF*=Phk^zPEL{^5yvB_K}oqobtOa1Bpa%+F(dmudFhJ%!I=o}c2Hk* zhucnR>eyz1-572BQ6tH1H&6A5VB~+rvXh>h^*a=hoa3ZYrd|?<^NQZ!^G<@ZGW_6$otfT)EIZui~yPs zT&<=$=a_zeKZcE&S;9Nth8kfV4eE=0Fg{ebawGw@L-@6wdX24_#V{umrrOT#i_vtm1#|UZ{=>t4}Npo8dH2lOdb)_!T=7 z&&Dtj9e3ogfmEs{7SdXpkkc*i^x zoz6Sai%!P?P>KTta}gU^FjvFBOJH-HoIGzjNC`kH+Aq`=SQ74p%mi~48rC@umE?y1 zBp>E{r2A_UmnUs@WIv$e<=G8sSg=4UkCck8P{#IjWV=}aHlvDT)H6Bt&kj}0yi)rM zMpB3s9H&XcCZ_*jx%~BACwj2`qZ68gy=f|=_i@bw8Y`oGtT(f0gA}A4F?1@AMMZKh zW=eeZaCma#4D}Vi;czNys{dfO_~MB%ZvfR0dy_}eF!@I&LqA`+hUrQ}ZtTk(02DD= z;Xs*j-Sty2Ad6yo>$?klH-hymJX|NR4eOmhW+Fu0EZnpsiooDHp!39Q!2|cKUQv!$ zYN#7t1&g;h51b?WXj1!;5nqmXX?5=}EH36^9IvyE1lWyv>Z)Q~3p;>Zyr8&yfqc^S zMUXM1Eaeu~wC!7pl{ZTCQ#yVup#{bry_BJx1Kacp!z?mKP>gG z+1uN-5j7_~0AfJoNnn8(KwoW`fL>i`yV+A!6`ADN4y`G#$zo}H&A&ggH{`ml)_3VKf$I#0t2u&qdl6kL;=7anx=?cd9~7!bmYaJ(p zA~7*BIwgtQ%mRw8jWck0Hm`5qv+)hf9Y;s~L4UfR&Kafdz0J)wmuV?=CWL6HQxyS- z4HCckm;-n*W0x!4+xR#vd3g9!hK5B2dLsn;iu;lbttjpc9Np6(U*P-$5W#`dZRr^? zKx^jK^}KAMc+lYrCj{sW6vz$UM8ol#d?S|*v-;k;s+U+;yGU-Gaf8i&@e&*HTUn06Ayq{&8VyndNQ_fHp%oAd4yN2~1jQam&W znGuC>S2Z&L=BA^8PM@8E)ltnZSMZp_%_iv^|N#rM32-ylAH2!OX#59n34g*QjdV zuw7uiR)F_F8m$b`X)vZgsMaFvpw;$2Kh_PmH3Uzg2bQ8S&os^GxZj6gsU= z^d=lM(EcGS#DcaafZjl6U;bJ&Dsur|fGzL67h+OTd+;n|*36rfFm+I`$#xK7qMZ<7 z=Q1r0mCH2_2{$L~ShO4;&^P&=3#;NnbU0x42t0L;D@u)OiG|l@h{M=W(!qB;k>x>wnhoC6~cVhmxGQ0a{$wr8oSxx+T!H42>5#uIbp@ z)obXqpr-u7T6?rpUo6kc;{8I{w>-wd^`)wo?w9A9j!2>$(?lYmn1drDBXi^F>>qmr zmObRv7bEiV^;grs&co0{hhUK{9R7LjsE1=`QDD6jktegkxL4%3HQH7f$J}}BD{o-*sfI?I+U+=Cj}c`hXP(pM1cA&YAz^a%_DZGxoz@Pl048@C9#pmGt9Ujk ziOXy|-+#Wg2i*V6Oxw)S3$8pZPWhPjxd>bmF_`Y}`t6TX8wgYE5n@*H8o6a7O4Yn9 zj%z>a3OLNktnikg8$Hj* z&U!!xkzszg$Q}kgA}x=(dT7lJk=F520?|pIp5481{>h-oId1VKQ`&O{mrywc(>q#R z0|gZW`XewA?}CGwLMKajxxVM9kCZJ(nxD1b1*>z{f9X&`qWFed`J-RYk2Xk0-8_BE z+zj*jZX52%Z4Rxnib#bAw1q}*&Q;6eZy5uJJQ}&D6dwCx2@Q>JtH%H6v)!hCpVl18 z2<82qs9WvP1oQkE1C_I_bVph|=&n;L!n$ufyZ1C!<5|~(n%4tgmdf$t{r(g*chAm! z*zeDWL^=_0K?BpXgHOQVZhg6Nw|j%Td)}O%On@c?1X{@3ode7}K=SIf3T_)qMlPKVQq>}ZIr|4D7*+CHa< z-b-b60Q5><&q`B)!dS+8v)T+;8A>2IZ8#%FMc16;=?uA>0P%-~pA5bDe4d?~Q?3}f zW3g3PKR2k5bKNpOE30Iu|6Ka>H%^HxX~PrfDw!Bti?)9sQVD4|U3*OJi|I`ocud&b_9{Ia-`(@Sgla@GQC&S*X^+?5TA$ zTn=aNRS|uEB}V2;b@f{t_=P3V*hQAi^58;GX$v_>jqI;tjG8!d^-G^)0@;iQy=FM! zAkZU?`yC}hbgHsjLjqm4Xg4PV>Vzu@lq>Sdbd)o-9De%EgF z-NhfBY+lz{1gu_Xbvz4x$*}ZE6cJ4&b7M6rsisGr{tqV>mpIkcVUQ_XNC!rCD71Yx zG2g#V-;tD^O3iCf58*zQBbjr+>hgVQqSCJB^5*8|Y!<$#$YpVEZ`|+aliu7yt+8Zn zb#S54SH9Qf0cm0=TMMmiF5R=gevE3gnWtiJC-?`4SYH8m6hp`>0gbW#TMB;+hf{UI zdsy36ugYe2%}w#8aYJi;p>m9|h3!QdAy55R1DI6atCb}@SI{vU=YG6cEt%tby~FDT zRzV_j`~#_+JX9-3l06t;vo1y01I?C@(@KaB6NJykO>S(({EC2Z0{~qd*Jb(Q7aXM;{QDmS< zl?}?nL!DLid1oOjs;m8#xN{cn38I4|)8$QhAGhI);5Yr*a}v4gtP%2F?qg2r+=;^S zJjp`&Vn)6ksa^4Lp1|XQqAA}ncwdk7E4v=Bn)4mMZM=x68nB8Kkoy%4qtB5%qo#Yf z)t-@*#H=3Bt^Sf-$oA*E$w0h_U=qI*?6XO#l)mh2TDr_^k^m-W^sATWb}0h)DLq9J zapOHMskH{4xy_|R(Nw~J)z7Mbt6M%U+9;j83{a~eGK)Om1p+xrDJv^S$GjZe>ktBl zbi#A5Mk-OH-`*dmkW*RCERSnS6vpr2N##e;EaI;kLqf((&r>ejcmE1921h=Zi?upj zmW~x|q*hU7fqg|2R-+uPS|z^jtq=KtD#~6~oh)in~yDC#PrjTpA5a++$@< ziMnOB)IDZuy}Bl}^JXO{>jg1Cl_$$Q(4&m2j3LOS&>Q88JUJ}YxsENu`4yO;kj{OA zT^;QwN!$&+o$f%-hA$j!-?lPo4#r8tPc~bbiXsjjRuNMoQp2~mYx0;MYU}3?JnG{{ zj&{!^3&9yl_^<0nM^Yw&z3+!2mCSSE(%SF$3f@B(3p&~Z$V}Zh=Vk=={8|?JL-Fp} z*woZ}@rEuhx3g%Zg8^?;HQ2$y;n%`9YBd{mo=O8(3D#I(mje68kVhA;{4Oo&N`yS# z*x#`OFs`fGm_KZN`gFN0DMZ}#AyJ5K7`IJ^GH}O^{Fx9zoHkVNzbaz z7nFM#>fEKNuWt=Ci0k2=0&!>DFF>c~wi(vGl(E=JGM{bmKF+W251Fv|-2--Y*8rX- z6~jY5KJOn-w)0a-Uj~BgU3;^XsKnJqPTjc?;BbQnEBzkqs$l2~)FJ>Yao3wCS8n)J z=Wo7L0K*ZR%%00;{3vNZr#a-~`Z@6js|5X)A@A*Ro+4CcM z?rUGur?>a6-Y|)yE4CTYEP4z*njOjS_;O@YJI)duY!GM72~{^gTovo`9yg9%d7Puu zKC|8`gvC(X43&vGEPm1JZ#$o{Ped#y3?b$|$E>V2VSmv6+QmTaXJ)(`@ccZ78e0p;&jC?AEEO$>p8C}?o`emq zCy7#rUw;N6kY^h$SmTknI^y}Li?S?;E%j~qgzLSfZ8uNL`@MzHlCa_CLe=>|HwL9f$HoqREHV;Xk6E zfJ~;w6T`3WRoxc7R3rr2ULJLw|8Ps@v~8uqJCIgo&sTdHr=#Hh$Hia1P(2PpEi~UP zhHSrq{PZ9TG0>xI`G1LIK!=ysY<*kzpLfs;g;`@8z<1 zC%uKu^>eRdfYo}~qrN~U5uHj}K{1y>HNCR8>c3W;&F{}f$}+USK^-RZUEe9Gxg0aF z{{sBrD%GQ~8$uc>sRG$s03Tj_b zPT;9pMbj%H2L`MPh@Ik14a4KN52}DeTtG5n0!+S>-+-(EUYRLtb$9kV)kwpbHQ`P& zfqXhx&IK4+M|$%MHutFA%IbAHOXVFWZ_36$*{Z4IZ;405MC$(DZpZs{(bdDl3y3Z$ zCa~kvkM1UVnl%>*{gO!{W$|;RROF6c_qn2mm-sFtI7=^tD7Uoa^=WnZ z!wyCxjRBhvCw#rS?A6T>Qm3lYnbsrKbPy& zZEU<&AdH*b)(&}-OK|67Q+YPsYX zK)2h9r`eu41~_m<=6iaP*cS__^zy$Gh+X#3ZB_8%ooDaTRK$*5T-~>q7RpY@oz+rQ zip%TnpJIL%KhC23=v1lg2HFT-lZ25$Wa zkVgPPJ}MC>XCt8RJZS6iCQVpd=nVm@UPILy#!AmAXDeQy2+^;Ha~?d4IOx^SZ|aCk z%vO=sW6bDQVM6g!%2bWn&N{6(=mp{Q70xq1&S%uolEzvck3*7M2*DcZJaoOdaiea%{Z?4I2hx z4NDa6*s|>Xt->78?$#ENuGB#C6O0d7{)(i}d3Qz)0ug997+VlP%qNJ7ib70~+>Fe7EhR9fiA{9IcBh%s?4$Qpd0Wy#e^*`Qw5%N+m+9u%K*3>oX{HWjO z&y)!Y>nt_jl^3yLi9ini@n1?FjNsGS2Oi?~pmfTI!$XOhz^%1v!-%ZXyRXClHcZCx z*Q+0~2s)x_H#QE}Vs(vZ9c#uQ@6xKv_l4~8pUas&QL_pCS*jg4AxPY-dn;DWaU$LS zbf5Srz=W2Xe(sDlw-(Io_eb@_dADKO{5&N^DwynDHU|Zh>>YN>STEPTy?IxGuDpuU ziaR$D66_n*486>=n+I5qNWj3o_lZXh(wVsySM*#@+Uw`L4;^z?Z=LNg=r1y+wcOuA zX!7$Z^ZZbEIrz3UII~}~vk(4ih1b4&+K8MC(8HjA8=USAf7|MCbe0Mgx|B}*%f{E( zaL@9ArEg$%<~lVc2F{hfu*%Wt;t^UH^bG^-=t13`^vv0PkL-QJLZs~MTkwOZmDA-O zi#==X5t4CC7tYpl8(d*nY_13UEqz~8E6H5jaa>Lh3{YjdZZ* z3o8#UMO@JmiOapxR~=R0Fd##tbx+_@k@g<~4asaj^h3*B)Y0)npsIpjXS9%Kus|Tp zKmB15Pu?~>{eh|vzrgsJul~{J$}i;M7UDq5#zfis2Ywqd5dZ2e?Yh^0uEedAv1+Db zYV1-G#E(+UaszJ59tgkpfn*-FeT ztEE1AG|cF0E|)3f`2J*{Ihy_Zn8k|v|978R2kEZBM#f>XDr_R@Idx7Z9#uvXtPw5} ztfHp#zyFkWNod-q@x=`2a~oHT-lmLY4S1Q;!s;$zjg(D6g?6;H-H65{Ony6^+C_A) zY$?@Ake{jo2vk{o{atG_6;mFenmGRG@ym2eGMaIq6inO9X_Zss94#*7)fTFlN$xA` z7QeBZ7jBw?Kpk(_%+G3WsW%3oP-T0j>1EE(rhC~>kfW9HzxXvE(aVLBWR)rgFMf-VR!S&^MZI3w)BS1mJ%KWy<5EA-BCZsv4ixa{%K^;86 zLg%MnVp*ExOc?9-j`d(INvILL<2l|DaiB6gO4{cw>fqavzFH*L8(#Fvkv#Vgv`PPE zo#OTUoU(1o)q#4TGo>x+!YLz_SF9{hXoUL-bEv7Sf2%8>N*3oLJ`Cs63V@>f$PiLH z*UV(|K3#U!-IDtPv<*o1Oh?B-Vi$oVd!tzr(xZ5F`E-Bfx96;03+Zb>|GRZjGwV74 zQ{dBTgEDuYsFjjLMLbpzT?^F#0i$t=QBs6=w`90@QY3~PM;2|f3SO&{Pf0+JbpCDW zhc_Dmk~YkvNqze~_Vr_zw8i`tOR6V9f)j0)nayP*M@zk=!|Y?G7H~lO!$v;mz;x@- zHZDQsUT1m1&+$MH<{>pf@RXV`Or0=U+Hn~O8lVqSP_?}H=+0HYYO+V*a?1yk<%L_-N0M?JS~x_3eq0 zeiZ)?wBO!@aXBTC4T8T+9Kk(Y;xJ+oTm3AMxyP26-(*)?ugbyI&DYl{GWuaa-Fr+O z&al)HZ{+p8&=>|q8x~4CY8egc7Iq=6;A?Gw<8=jn%mGWj)j5_r3d;qUkAjK?(h<)? zHQ_|4^L=!4QfS$+{c)u!5N#ii;dL#YmUn5ZCMCD`d+)L4PZ;an=z)g+ytXHHHuk_N zo_soxxw|C>n?g-U3!tl^ zjA1;gh-c@rEW>S%XlxkX^F%&y@B#V1(d(ctOHY=hcB$1k2YYROz(o{OnLUGca)O7& zz0npD7A{nM5puehAl-@XBa{!w$o{&+O}rKPy?1;AuyaNQ%ylNbutujUTdr9R1^Zms z>1OncvhZIJ3`}dsFU`_-NnJB;D8Kz$h$2l^!^1e7W0mQ6^PKbru;1Sj5cyZQHX8>= zrsWF0$>kI@Oq|B4MPt;@7PHEAhD&<9QU>lfzm%cL^M-fK3;U}jR(kZzpIeaqsU|Y+ z23M24AS3#F&LLNN%-zmqz6!Tv4G+_3=QAvtFuTAqCl zzSw#!|AOUfV&#;>kZZ}kF|eWM4BJH(WNq1DC<9OYn{S5GJ1%9YFZ2b9va@F*i~J1> ze7Os>(yxBH-5C*-UT&L$i+!@2+yAVEjhA@1sM>$#JmrON4A%nA1Q|pEE}z)#v)kT; zI$dv^pKj=WK)}FF`*z&rxjEg@%_9QRwo5dW*FCHw8 z!<&k?%T?qHZ-*~h)WG}nRj;7$qFRx1I~N^pxSuV$%IJi==@}9-M~INpKUm3(*r^#? z_3`keeqjQ5B9#{Dxp1pq#uLdrLSN5l3^e{6J5Dax$SZx<;*D6B4b*Px!?V3YtpQ_; z=k{L;Z!P;wdU}&w18E(auw1}bND+Hu^)Rgb_OHC*{#&?i{rs7yp%%nEf(hvmcgE{@ zT!3;;s8bkQ9+1xJJsTN(yIqbcMq_CRH?LJ$+N>6^-a=m2!JhMDpkVU=$<>P^Hmq(Q zWZFiUC*RsY0zD?mLtfS)Mne<^jnHT>hyljtLgRQ_o=6YbMjR|#?QJZt&kfJm+t03l z+#4f2#nv6z9{nt>G{ z=fC=>P}lA+DiFet zdscRKyB6p-s)-nRd+ySgnpcWu6$nw%0v)->60%`rUhKBnnPZ_JKGrui@tbYsv~DeCdpOPOnbYFt=3EV$ zCxfp1c_h9xp`U9?s|~TFd^~p8ez-(GP(UTvG!y<8PsfnQ_XVycr;%3xYQ6ifIuG8^ z(NRZbWj%Ht*unS82Zw}=P#ri5!Jyp`e%rMx#Gl@E6Z6#tCSJKe#gRHY%l&wth)4~X zCvyI`nyag86L;mr`24PTM@gR@a4_`eF$J5U{X%PGXd5D6|G+e&V@-x8G9h93h*u3} zSs(+Owb~PV4V)V~j$+dM1E?dfsXi>;I>4n87=_#%6`*ez10MY1b0!skxbV1UNw+9i z&}J;IV!hD7c{OIDGnwgFby4@0A{-o;8ZVM!A1At=mJWHQI&^ZNkOrTmCl7jqe2)01 z*X@OivX+W7<>l^(|2(fRzoaO>@$Ub$4kE>?dK}{gD4G!728rDfc#-7fZq0DDm=mT7 zcV5JE_m=4fbCikN3*)!r-fU}oz5Gp>avVctcpi-j-oWsFJSIWAZZR{06IBO@m2v78(QrGFjq$NsxQwQB+Gl<^(tV@E>W(6wcM z6iSJ#1}|^U$MP7|KQVFGn>&&e6`gjdTG)RVBUno`epCHKO;Ok;u6MOge7`8FOUAzA z>a#|KldS#3TC#cawT*9v1qVp6VZQUQdj%)H%7^69Pvjv=z_mojFj^xm?d|RPJm25G z%NpjqYqGBnaoEUtkRAv#u|tFn=noX?ZO(z^S%kD3TfOEgi?TomWl@|(8mYa1Z zUEom;>JGx z{I}l>D+q(#s}J_}T>1A6CZax>V-Ba6foX(K@u_yzhCHR{8LIS)pT88(mIg0mMfj`y zWz3!TMFI47gABoX>wqR>@x}yfY;dja9TR1$Y?1mq1df0Ke*vQtVU`BJ^{*xBU=R%b@ivwn0QX^%8m)y2|-rj*~W>+B`5T*qr7LNOTfi!H!w^z=x zX|P1TVR)(zV_JR;uRBOBAQ|iE=u~ZQMj4?^Y(xN^Vs2URX6?hR=2rF00$+cMa{ypm zmXobAEIbY<79aVjT_m(n%cv-okNV;v&Y>^Pcw$~0PmnsPytTDyty~MU=S1Ngv{ksn z%YL4hF3G|R#5NTq6hEu&4xQ+{hp4~p=nFQpms2-sLxz^V%o5Fqv?P+_m}63EY>i%z z*T6dt=&mzn9?&e<|6ZFKpOWj;0~eGts%zaIA01s%kdb+8kod*8E)U6nuaYTXzwEQD za;k7A(8E+8`kme+w*B+t}3F^;Vd1JPTAiH5Hx4PNi{;i4;{0tu>v{ALbC2l9_jhr@I)EY0iA>o$C~ zwMm1r(v*+JRNz)Uab5iK+l%ZyZ88Ai=ZQLwRT2Ike&%2K+bAqIvV>3#?8Gev$*bPK z7Ww(K)Z&$*;r@=cqcT+e)LguC-8WmC?>*I|INpYsH;GbFf#WX9fv0^p5G4G_ac^@3 zG2qZ^Z?7-DQ*fuOUmmD8U6L=dy2H7a-KlA5!QKHd~@#`gzRjq{OsZ}~}GR-gat_4s&NpwEX? z(7(U5y#R)LYqu0z!C5YoEDF%I^~T1}D}~bxcoOh&Bisc}mfG42$5{F{{}2;ww(>)3 zY-J#8pP5LG4jlVsZv(|1u^g`?`7T{74mhav(r26!m`~~5WVw|i&27x=Y1R+p>gl^~ zT?I||tP>TzYH3|o=k@bLIxW3w3bW%%wx*#uI)>kHeHT%6?wq-ZmM-aD@Ak>^#H9ak zc?A?BRSEeqQO}|yIudRIt@2_uD$~8*L?dJCSmq^6_E(So7Z*e623woSet<@ALaHc+ z?WX+B6|#p*@GrVuy(nYk@?&p*sA@AxiavpjK;E6hCZuWtZ&96&e(Gg|3Tx}k9rg8Bw|!9LC>pJfM(D&-rmNWrERVe`dHODto&6Y%`>s2+XAvRr6( z-TQpqBA9Dv+8AG-IH4X_x0Rt6*&w;|&?sFa(~u|rTf&(O5D34+Y%3(vPJ&d5r#R(< zddTLtk8>yVPpr3ha1Qrfx2nn=ldQ{vmSRX=yXFmt+O0FrMD>7MBF9st75z&4%)yI~ zt0>v`$%0HdqGe!Dj0qic3nHqIe+he?BiK;rg}u@}?O>TYQ6%?SKje!pBsFB<&V$J9 zuILE)qMXuz61j8fU#~Rk#A1jV=5chuG5x1FIu$-_P;t@I7VU98>h zdf9;0ddb|~mmIiUYemrM!9ZYk7og3m`62V4ObvsK!3H|`&XrZyraSbN=hL1%RTRlq z@bui;i#MiTF77%twpRD4>ICG*&?avBtD|0ow1MjEtD?rTWgK^G!5u3^-Jk)Q>ao=W zlM?ZJnIT%PIp=t*-KH*OJBDVsdO#8niko(J}dR z9qbTExm^6K^EQ~nzNc24FN}8NV~fHM@$acBt>&) zW_#e?^igZ;NS}4>@qHQ|RoyfZk?m9hg(U!-JJSr}hP{wa=4w8fA5@T>_-#D-UCc;C zWb3DPmA>H=>3AjOQwx)T)Ivte1^lS3x1{zUbsgM3N6!pUFdzTBOJJ)dJPB|MGbR1u zp=ZKpuY%gQnsFZ5+4b@!u&=MqdpR{Lp1Z6pf1isGY&xKY=)|k3s8D$>PG!h)U9WH% ze8)F;cFaPse3cRU_&CX&Mc2#mJ;z#q^HZ!W)HiGY42vP6-Q(t}6i27x6rm5QRAR1n zDtFJ0JR7iaECFZV4>GpWGy*&+U$h<*%N}Pqht#V{?gH77ZBpDEAmxV zWS2&Cb#)~(gtnuj4j-$q|JKW?R`ABv!)1;Z4)(CHxaILW4c#=3%|p4=@nT{8D24M= z>$W{}BPNiO#@B3(X!!!tGV&3j4@WZ`fymeS#?0LBpWQ4T!fP3yh%>EsdUS-!e0^0X zqb~QMx9eu+CZmQn-mZ&a={{GGUxtJPhtP(L(RWDx)14#Qob*?K6V3MTFKKl(9=F5j6MPydY%gWq$HUyC66dF5#+9o{ zj|@#(T4Ej~b2Kk);@Lx?(a98%ggx#(u8SXm8}q%vC|zLt{6Z11G;$dkH~e5@D^IoR z%#|l9Nj2JV*qEu3Vs7g=opw2`h>SU2?~o^j=T@rgpkip84-TLZ8)Z0MzG1CsP~gk- z$BZ>D%gRD7?U6qEq=>eSO1rV`O^}qNm~$g1iZW(s8kR$!`11V{`y5*LgFLtD>#3UM z&XLD7n&4HFHJU$_G#7$h%tN&55+U2Xzwz3_Cf8ir-^wC1$K09`+D0SzxxGVZ)cW_5 zqg`YD*d1{+sLM80lEt6u2obHx#{VFjb1!!E>B8TDGs*_!k6ZQ_8#-<+i8?x3QqwqR z8zKxD8y{7KpS3>e!A9M=9!;N*(|_mskMRtv#?_71H;-}z)wY>5f@hpDd&b*# zOB}st->3PFm~QBhbSO+r!wRnmiH8ew{0+WKG+kXb&>^%xqDv}kj<9N6Aa+N{LTE!S zCNtz$VgT~l>c?(PLl2LsK8~)GhIpH(scBRlp4RKQO>V8^>x)ZBsOHwN*KF@VtTZ7f-flw)m=Rtw( ztKhm_1)UpBIk76<4#T_4*C9R(j1(VaEA9>zhRE8ZB%kWP}l9JZ34|( z9c-fO$}7^x<+HOgF|QKz4ISpcD82qVn28wbw(q&au2c8TPPEahvRN@p%1aK&=@Q2c zGEldmO}{nJvs!BXZ&vYhTM|!ne5LJ;vmCD~=c!jpHp7RIiwd25iH8Sb(?*W-Zb=gjk{9f0)&4e$1f#nX6R{H+Kc8kM4PJ)y~T z5#+E$jHv)hW5%I1@dsr>*T|7W=ki1^Ble9FtY*cz2QP0I&3qNxs9i0xY@;y_$YU6u8t7-yuIH+2#z3I@q)3%}2y(@=Ldl5Az+cGi+`7uuh{MiqM1$0F_} zh6}LL+LU$aXbsE!WOM^&RhhcSxBn$^cyz|W{`=gPAB>-fYV&s&$62OYy?Fw{o>X>t z#-(*EQ~14)3E~M4zO}Q^;f?SHI_8{MK#_!SRA@fvw<0?mx9s0@1y=XL#{w4oy#ugD&kdPL?(r$&;5P7&hr^^TWr><9=jfy&I zS`@N|SZUJsB>A_f-IxXKhVmmP)+-&?I*q!Tt&81x4V@XLL8)kQI603*_Tj>qmFeT| zd9=RTy6iEZM|E|09wNT}@ZIlap@~f3u{yhYdGmTd^*1WaG<>A;@PbIcoD3dfhnc{L z)GD7VE;u^ct=IAW9qScBu$r4+3-ZtC5i);=n$3|zeJU}q49FlSCtvYCP1Xx|Tk;8k zq7Ody=M;8|UVe<#;c{D6BDBe8>3Zvp+`*FsU9<68_gJb|vQrGuWd%vJ2Y{54W6Cff z5O-yNeP;K1wi*&fX#MuJLwRKFyIt)zw;A_E~8lgan6QtLz{hhA<;8 zX=PJI;w>K0dq3*7|j7$FY#nf{JoPZjg*~+CLn`z!?Vw{|pvPDJEZ%-v z!l?}OV?z-CO~Q8sCPU8g+8ShKPTDta`LL-p{p6wO?iL!0hF!m z(r@(y9Xs2Mf|CA`lEF5G{Ik8UbXV{?l7Lhvkag$@Yw$x(PR^N1Pj?)d`ChTr!?219 z2VYFY7#Mh4XcKb+zZQI7v~+&OOd1mJ`{5xWRT=m*t)l2B{c6?9$)WwE&40mWyL0GfKcJN(4 zPxv~`3fWn6LEeo?f4VWk5BPYt3yX`{^lQoa8hT#U)4^>7LTgv>WIzlBKBA)%7gr_3 zg8yw_hSTUS7AkV)N@4;Q#G=1&XB@$c6rJS=XJx)FkLoLNN4q&|P_6U%TiBoQu1BA}>uuDTN7v<# zJeCa)P9zhH#3T%RCizYgKU-%J`GtjAP-xJv0gRP6XkMb9U&S6WcDA;R;WbOC)@T=H z1hy}g82J7N*6s`TaRF|IVo5O((pR8aQ9%?{H4RKuO;>}dirs~=&Ty_(vAgsth`#O; zfBYa;jryn6)RyY5 z1?mxR#N`-y>wf~_2iR$O5!BGis&&o7KU*%(+37yV>N;x_!*ps~#!8`<^tA41zP^`l zHZZbZerO4;_2@0q)Tt_~;Wsp$GViT-9$8yK&DK`xR?hS<#UD?+#wcfEwmf&e*vGxDNckjl`tZd>f~_v3;#b=o}EZ zpkIS?fN`3md~fB8dDr@B?1KA{Qq8GkIXlMjuL`$W;y4tWL82c(<62&G?sMfzLYL9; zw>|Cs+L_Amp8|ip#2Q6B+BA&=1T9l)0o8m~xBF{FW7?ZD52zQ*%dPHTT`yBNXYbF= zoitDPd^cLhT8y>Z*=3*oB(~PM7$IA5Wqm5aVZ6jZ3N>h-cJFok>B|`WLp{8poMIM? zRT~=`qRY*JeLHbk=&Gs7b}aR0c`g?*B{Peg4z3po_9bOSq${pCplq7}~PLq*a$ ze`pHT)l8%ICX~kB__@6kJoQ-TEb1s=F2o1hLl_Dwg9XaFponO1i(+WU|{RV9}N!VekLZ-9*Q9#4`tv}1~EQHgaiHf(HSqODi zbT33h)sI5>H|g&uBP!s8jP@iGq@7L<)_}-6vYokZStVD3r19|GX`*pD6`BTahYPy5C?wfUZfN60F@jqkU{{>1caUpDRbO<2CW}vl zG~=Jp{}r_2dTE_W@6Nb9uBRO{I5fl%{e4cqW$wQdOmaaHLioc$Wy0*yyHV!nAl*aw z;|K>XnTQveAkZ!vbguAAu$TnEv3iD)Ol@(L?qIBWQA5pcQwRr(ox5OWyhXuWF@iOL z9jDlJe=0JyK{AiV$;HuDjJ6Lqf;;s*p;6VVrtAx|m1aGxA(gxM_=Ub`xnU8_P!A9u zfCW^|Cs@5%0R>)$2|Mg22BCCdzjTo^85PuWzMtpA1T31qzZ?bfGD#KJZ;Cdz$nBrjxV{G z1AmDRg08NIj!@-Kt#+j$#6V|v^NG$)hyzjHjEB9Wkz>U=ha%XH5RPXeCuMqPEc06~ z!2{ektrd)Na)x)(yy@OJduVxzi;tW0zx#Q+_^&8#ruYOli9aWN?p zvSGg=_w3qDKM?F83{q^Sti5AYRJ11a7tJGpz95{Lg=GkqH{#bfN8G&oj;;G-SLJ+y zKJ7Ixb3bf`GqeSBA5!{6En@-+$e8#;quPn65g2iO<=0~eBSl$}>bI_@xm^&SqPH6< ze6|8vbI*Td2%hw%H~03WE>eLIA%k9AapAAcLi7Ub%i5_7{-!D^%2}S+XjQ2>vX58# ze?=Gs+^Pdmq+!d1wL5`_cKZK+R7XWGbiH4-x))ev3{OEbj!9OX3PUo_84ByCv9SRm zk9BT?LM@1P(-{HqD)^U$l>oa)~f}4Hff1@rvL(|&kqk#{S#WzX| zC{$;f-i*=JyYI`ovZV#i@6q%zJlu%-!e^hhYRvcy6zIGF=LQ-r62hG&ikJ&hE;ypA_Fo!ameTK-8uHg*ld zbGo$MCAYsJJa4RRlkAzbP-WEzVLH?n${h-p{?LKQ~wc3bs5<h4FU^ZiYIaibp}ZVZohpE)u!F-gH-)JAMerH5Is zjFy*fI5W`Gz)FH`WE@2OxS2;$bY(}g>1R# z3M4fOun{>4dK~Gz#yv%I3eSExZ*KmTq>fY2G{K1Yo^`$+Dz;# zek(i9h&F@ZKtE^yoptJS->isVws4BrLa9ekkkh8g(QBq*IPUdxO%yMJK#Yt^K& z;gnqBp$w2H+`YN*FWCy4#(VY-$c6?BQC>U%C2o;RARb@lU-Q?K;-2=YZMT zXz=Wk%uc6IW_;5YPBl#9y=^^#EOuJ!=j+A=HGt>e16$-#i;H?%8Y(+DcrqN07ze); zYchrjKyZPq_jr4|GO+z)5T!Gy>5%2?PineSB${b3^@-SX^F1SvfY>YHcW>v1Ki&gG zHY+RjEy$8#tUf8rAaMALeNi(jah+Nz0KW>Bpu6{;+jSmT^OcmPs;t&`2tg5TfV>-6757q@}vI1)h=JK)==Q3jr z;iChQm)^R%W=uCBhE#*ADETB82UQ7tt2^8tzZG3U-@Zcct<@PnJ9~R0WQKHV!tj>{xvyXO1*dJF$an`oG|;p zdl^Pgp)1Y$EJ>Xo<_HEkIVsC_fE;g74fYx2jv%U)hEv3?VNEQ{el~uYJhIu`#c{9F z;lu1zR)~YpN^7#UY4^@C0sqo`jC^pzZfBtzV0f=+Q0SykA9kg$It>r4?Yp}t^H_Np zD0wxQAX1la4nJY2Ijo~Pn?`BM1lg^4{mzWFGtb$;jq>|2jhR?a$VG1ApyJi&t*yeg zmt-RJG;xl}>sXrXiPM)sqnw}iePVxOc@$+i&kf~F-Men?tupNkZ;BS_lU~mN5Xb5$ zD3J6AP>%M)VJiyyV$)8`s!99{aMIph5*wGt?WmfM4%|3JCp~wrB30wT zs{p?rpcf~%4hou(P3XiuL+ej74SJFe^nmw%lRnd^9(yF-^{g&im?WG^NVYYcV$s31 z04Od#i3h0Wmda?pLS3PW!Mk-oMyBl*hwK6+pcR^d_|>fY)1T-ZIeL-$S*gExw`j7( ze`H_*R^{ExWc6x?j_8%f^SL`^Qp~Xv__)GvI+uO~P_Gb0v`vUulh=p^wXyq)a2g=> zou}+0_%giDu|&$CSnS$TvUz)$u}QP!Ml9$^s&rT}?5hrlFhY zIF$jbmI`}3Kc^5aEG*Jyu@n9f&vRIzcsw_jJaQNG8A}aUmR$gnrQ)-N;yMkToqPQ? z)dj$je&k3n-!I+UGXckKqiwvyh-vYN&`rKCxB81)* zQp5(f8^uK6R8wJ7)!y2hDT-a8zcaEm9k3(}iH#R5fis!EQY0)0;V$i%FBLWd%z}Zm+tX`C?EL0Apo@yvm}@|;2#zd(B8-g_cCq}>yv*$C=8+A~gf2#>#?~;J z^z(&EOM%h){WJx0%hiUb+&t6FQ1v7v20@^0K1hCqo@d_;B0|FJ6v;`t8qhY@9OWaq zNAE=&PIjsn=NoQOFA>r)n{M1?tR}!VCscTQh$+~aKN^(Bq2zIRExEcbT&y9o`Nua- zw|I2X1x%E~8ndQ=f(!fw8Q`LS;c`DffVbM+UxGJXgyOm4LoO_FswcK@ePj60olOA9 zC3?vRy}f()?uS<;zs;eK>4udap^Lp1dlCyHlAbA5mpW5Udy!Eq6#eZ&gnDk}@cs~w z%ZyEV>=x>5uW5SNQ^SvZq9CHf2ej)MSvx_X9{L4z3Q%J_9@Xnz_w_u9!rIupUzXoJ z^oU;3QtbI5UR4v~c1wAhS#AwJt%mw}F06Sujqhp7)M4m}LE5R&t{0%H^Po}(#Y@bK zTIz2eyi=UWg4fR{j(xYa5*hf^vy%Joqu7asf&CPB-TWghdf8hMR1?X#gb-RX_Nfdv znX9Rvgb!B=z0S|f0_u*YYeC}_9_=VG$@Z zHs%ORP7=I{5DX-lN|LpOo=!%{CZ-T>6*@3jfUC+(xa}|tiNw$O>AWj3_{8uHL*kr{ zzue6TvY5djnrjeI|I=Os?|yL0+aT)PaucE|Ht@$ZkULSU(i-X9CCAyGh$BSGQCQG_ z$InMX;%7VO?FTRk9(U)d@i$i^u3U)MmL6QhtD+=drEastnwc2);>I%c)kEdLHg3I2 zF-ejN#R*}0-`Xx~id2#sDxfTr(|HEcyOekD^!*!wn(MyzDe9eQu1a3+KhNb@Op6Y;&3-gVs*~Iit5E)o)j?%z!hBw?Qn>CA zU`KSb{9GWW)83zYKA~vm8GtBWM^9ypXUP^8euzM5lT}zec(48O#%HZ2Re6$_J0PcL zJ)Z62l(d*m|JHsB`ZlNHq8wR$37^ITb8}Fr2se5o0$UQ5#T4eM~4dT!_Wr7HuHFY41aQ|C|utJ6e?iu&U$M_U~o9n++)3y=H$`n!wN zu{3OX|6Ej}HIMuQIq$pjv&D0vnK+<(LhQ>uMA!-D=6zG}ez;MVuC}rYghC9eD`Q5}qv{-5>U$f<=PO16*BMJQLEC>QLK0&}r8h6lXh&Ig{&|k- zK>GUC_a2^IuXxqibSkxLTyC2w{K|SCJASUQ?*dxXnpVyts_t6K7s&}Em^vkv*m!?C zi>RNqogjOp1m(PAaAA`Z85c@khqtnZcF_SVT^uzgqbT0#PjkJ!IOII7E5LBwK{cQB zx6e(nYk2 zRyQX5?()<(9)?IEn-hrQJTM6G8GkXi(Y~JxtmAzZuW*pgI`l0 z`DU$7@M;n?s{Nbo+;etzcBqWU`E1~cxWwBcB8-r)onPjB9^;@h=HSen3A2jKdbh>E zuO#W*#Addyy)(FHv>*>H{)5QR*H9bv)wJRVy_`JsJWz4cb~BA%LZ3brWP(y1^@8T= zppydj<)!(X_<{YVF{^NbJF+^j2k{o%Q_>B+i^v)4TN-*GFTYhxJ$0h{?o`f zMVO=1q(hmjl_8GJUZRLFia4S3!fGF0@_)8uT>t)N6O+e|(sHy0@BaE&p#*_R|T%4@=McrdqjlP^4GZGe~l{{7zD7t~M2 z;AKEg^}2h`m8XM|Jfdx(dijY*v(wC!$SR2Zbsl1Ys#2>ze|}_|gNDF8rED5a&+2QO zl%hsz88koscx>zXGMxgv6k&RtqAh|mtmQ3KCVba%c8gV#VMSISy%;`UE}4G*um6sY zI3-b03<(8XFB)Oh%Hbl1^8@{D)PuiCv3aYNX+gvl3kPcYGzzz~>P0iB<;KAX|4dnN zy6Qc6AzU{J)YjhX71Ef>(#3G=>A=EEJ9@uM4G9@zidVoIOn zoA9l>XUH7RNcFm48&JQH9{B~z3Z7L z`@RMQKFw=Hx2cARN?pQA{KEIIUv0!2zGL|;pu|$^2>Dy#-rc(|BRV%;jRHx&%lGf^ zuV(@C!kK#(PFhy26lJ8Tbxm<*y`M)C8s-~-wbk~v#ByT-dt=IdSll>$aL|hJb{wz6 zn>g>yzEWhgx@OTs{Gd=uzJdLg1ifGxedKsh+kUVF)c&KDB6=cyrj98zH!wDLLP&re zfFv|Xvu@^lN*%E}pdcI^NBd{X zxAbY!XOIdEWlz7l_clp{@5IJAf9jEb6(v2N;fuZNxizfu@MA`3`$zB}uF+k`)zzRTbKt&7m$3m;su6?flb>Azn3 z+{xB9(;@VoqTRTu!LQkzuAihavOi)dD99fKNefP48l*z_i7(DiBt77VM+)2NqWvEY z5yLd9#BzntTpW{nKmuL)H`RH%vMRi1BHq_&qZm4Yjb-{?k1f5C!Lp@#DRi(+QrF!x zUL*?lcZAE6$v&H+K#4(ZV)UYAT)Qj?<(sd4q&m?$@7YF5kF48~r=?m1OF6;g-m|uW zxRL2Wt&nP|m0Qv8;v};*f@iNeg}>6^jzpyLc=~fT@Li9yK(MxaQjy4hcp8VfL-?VW z(>6d)JD~Y5!Ou^u1GWu0>1_9M=0Kx?Hxt5#7S)wJpd6JHiE$ie)xL_ys`xrBcR<^A zt)y+fSWk~VdVHyYmx7%9i~(A*t9}8wEM3kr{O>er08nc%;-Y|gaZx>1mSTY6>Y>bI3vk+c2+1cE@O zL`zMO+FM=%mQIK9UQ4n6tqC(|&_i_nDl(*96TTvY68!Nditl`_Y?Xvl6IzQyK^)CS zRR{vpBA2(FgpG6MY3qC$Gx7`ZR_<~d_fFm(o-i)M*{5_r9ln);dXJ>Po!HZWM#oJR zp?49Ic-gc`{5l>ze0wIh7? z?dPYFGND`RrDeeu?jE{c#c7UOHDX3n?g#GHjb-ne{oSH?hW?R05hlfQlF?H`kK?0# z*>Qyb+xcy=9Jh31tA?%C8t-XuZy6=qlHN*!q&kp>j^|ewJS^Q#ww8e1xrJID0lsD; zw<5H3xX@Ufyi2YSyeQ-0IEaC@Qt(3BMA&a%e?UY`OiimvdT?=n{&yXJAHe%?_hv}9 zN`#26{T5?_U*+`-myFvGQ2|$jo|GhsCNcWs4cxEzCPPaPks~Ul<(YHF>0Zk5(u;+b zV*`h!suDdmp{~`mxGtg+%Ip4^6ttb|5~uN%mAVZFyX<;aZR!|6JFgs=qo?|s!wOR-T_!%n-+Iuz1Bwg0At7E)==2e zgx1ebmJNFDm8;b+)FwvkIwX&g-ruX1&*BZ_0`jM3!|jv%$T0CAztH9HZ<&bE+B61J z{sxskDP#6Y!NDP(eil5pN#PXa$tV3JsHLwDiXixP4WR4WhyXAV?`Am9TF=G ziwfVt3nz0u<;yIz#N#ZwoM`bwXJ==$NJL{rYvp>mGeTKyB2ZgTRdtAQY7yhT94IfB z{My!`$8n+2RD%)L%hK+sEbOrEv>kt3P|``e({MB!@?x;_wIE&;aDy735p|aCZq^zV zITWfqjg6}^d1)}WK_GZA){Lj1KY1SB&ehbwi;=%>suz^EF$6N#q2ueE+sGBkCx$C*c8L0Sj0J$ z!OCiTbzm_d83c2=xai?ZQ)ZBj5)wTx|NfYErep3Z0-58-Ug7i4!?qRI-1mYj z_8z2F4a&<)k%sIOfY<@$R`2$QE+AHD?||T}xbX;f=61YZ=uGw4B{}u0mn;{$wwzQn&cTW3S&zVQNZVdsLH3v3ZWV>G@HvLE`B#_0e=6~1 z^!2zQI$HR%o9_zGzdt8|ZyuRYdpg*u(c-o*-}(%J%zq$CFJ_iwK-l;7oO*lwOC6;@ zymoV8VfJ+$@_6)#Lc#+gKjl-|OIypkd=Y4Ah}l!OAozF(yR!W;qH1LA@f*?V`ORkV z$aXDN=A%ahWQXqxIwQCPyJuYU+)!>FRzvaZfOB0H21R%biAYOILP)O_ENwmnD4Bk-ylym8SAPQ-Vfz3VZq4@8n zVdqD8ItC|eD=v1I*x=|v*}G9X--Swnjoagusbx6e|F&}zP1Q)Ma_4-P{~_!?nm?Mn zlVzj#iHrWz&}+e{I6w|J{5Pdb;=mA3fo+5-u}B_nc6Kz{I1IR6^sYM48mFN`!s6pj z_AI95CwRve7If_DDTYdOd;+zq_nUFEw&HS5ynb z7Ffy0x3-n(Q&HEoI6S@anI)C(7Wd)b01Xk;?vryO?1={kR^czQtS<}Hmxk=laxuj| z{GMQ}Vd&R|K5DGD^FkNwLu2#v6G`+lU2`+Dg(ZWCJFiX_Ma*>y z!47?Up*B2+aV0=tyX7LNWjy0lgRAQ3=s2Z?Y)DWAc_!(y=i&d@wAN)&w!dJ>Kp3~w0%POW99b= zB+-BCyW(>7aopc#t8scxLAPab0CeO@p3_p7ODp^ zkbFp@#ttadVZ|6^-+yP1jSxFPPbDf@S<^hUAGKO&)OZd1HhN+1h+hFciu4D>arSH| znF_eWvo;B}z*&UINQkMf&^NutbVU13{Qsd_Y*5JX4T(Yc+h48od7RPP6;W&OSH+ zDvK$lbkn)JX1oKa%$&%ceWjg3C$ibi*50QgrG{fnx-xIs((n=qElm>}4inJJ3SoF+ zeo>|S&=vIWa?WorR@Szbm8)%^-2Z3wB|o28-rNX$&9dBTs^;j*wVT(IwO|s_zsthm z8v~`LgG?K07s-^#mzS8#0%D>jXCU5O9JX@fVbN$(5{%Ds?b91rA()4>FRQn`tFGKr zmS}C>{3;la< z!Iz>R9aoH+38(CrkQzka5ever)|B|n5qGf_-=k}OU~J7WqN%CLjy`%QUqFp}NBAh; ztc}Wf?Vmc@10hVUtgI+Y+NjTZ8&8xOI;<4``um?j2j=C`OAPS=@1z3$64<&}ODLaU zoFgEC4A7kv+w(z4!b)9i*S&60;+k1m5oc0dxWq8Q|4Oo-6^{xGB`5GINjPZ?XCs$C{D6|6 zkEHZVdwcsi02L}-Wuzmb;?2loS;=1*~*5xRk2vK6E(_X|*5X74cIlkdTJz5)oqY2Is zX-x`o#dqC7Oe5^DuV1U55q2tQc!Gg~+>XO|;lf8QUfXocQEmp^htF?g+(IPeaw&+n zZ(KEg4c#w*&%e7b=F4X9&wA?rZ`}IN%y!r?Q%BZueb0isp zPEF>XN%8RTG%#GMvKZc9*lgqtFb9cjbCy+KFp*(vFBKv4J<8>&T3$Lpe?$^(e0uaF z*lOcu94JDV-)L=Z)%XY)EAXL}u?WTF0{%oKBmtmUQQP2UqiXB#^&#t9JG)PMt=7iM zjQi%cY|;TjRr+FP{WuA@UP=6!5Z#BZp;!UU<~nQ_utV0Rmru;;f4!DND6aVLq^!5d z+j`@80I)3RP=vPdWacymZf3qJ5ls=~tpAL%$nH`i%&~JR5nk%{c>ldu((rXDUH+S| z?UP=smfTDcWGb={u`z#M!(I4JO8 z>zYjimzrVD69t;lgWdAQ)7DQC4SEI6vs?54!gq(hoh-tfgUH(GaSOEg1(KZrw~}@G z6)s>=?3V#{t`ZFy+E05;SigLm_<-Kd5eUXGcs}^xRF+-$r5j-u z*@ET=q9x_v4d*3q@_$#&g$p=!slI|hPCm6UiBy&pS@|m9CrZER-fgux5W@?q)y3#E zXcsSo@oui!XXi|CnH!mKbF-H!3beb#8xoOuP00MmabVyccvG^d({~2Tk43 zaIwJLSXr%vt?PFs`|%o|GSdBxvZth^q^&?4HsrhWwAWl1JnKaSM@Y+C#D+a*5z|WM~4lE1HJ4KLfcEN z0_S_9R)wQqxVBuhDcej3>ucb_qpRGD=d&afZ3>@6N$*1Xih4+SE4LCC^Nz!~COkx* zK&`oXo>H!BYQ2o9=B1tN(^SHQ0JMGLNauog6~n+yB#JaCriS{+{1&h zEKE&aj|*Rdt@l_5G1nR7rvv~YjZ`_M&7!zqIy&@HH101=wmwT%SP=#6COzG1a1_A# z-QwK)Gw8?43b`Zwbw((@Gi55zoaD^1L7T+nGZ6^ne0i%Q!ZK9S0E#$=Y#6ZLzn@+q zE`wP|`PTo+&+zcL`s3qoOoKL%L}XDv`7JF%L2aDSs>u8w-__1q$E;(8cvy|045}b6 zO?k7AKH@rglfI>;p&~!2!EPB*y8DW`IWP5Nv)JDC(Q6O~E0WXg&)>)4EP$F3OC`59 zEig-mqlbi~-nk$nX=`1sNlM22{4^M&ZCvBT9=AX3X>9-upoBG!&PYSgR`RqSM-Vr( z<*iw$>HcUHd)G_vjcRy0m5peXleaB^EWTPS46^o&uhsq73xaY;fP+syf7*Pha8q{!}akBlzTWO-TuoI($E)KWZ-_appJ2#x<8s= zJl_ITicJ@J%pJqzP}kQIvqdBqLF|8^=bkBE)Y!u>gE)(xY}UPrWgNdyv^RPM4-HZ6 zLQ*#q*p4M;!(;ZsyTxzbkKG_5xP{;~-hW4S+B_4~ zl6V}0g$d#21ux@tBj5nZUd+d~e z@a5g0*+g+0t3txcS`LIPL$-82zUqm&(hQ}G?RbwZTSJ6-pDX62**u^6D@CmdC@$58 zQQKx9_&!WDzFAy%vb~}n^7MtS_d=X{#5D-55}MFi-=8KhcxjIGWCbKZ+hwTl6LJ}v z6K~$UDqasQ4wN>fP%!exq9&A)dL{h{h|+o18_&HO7`ue=sy>*2+8L)TBTW%EtBFcf z#x)!>`FX*?G;iU^=}us}V_!yf3xir_gD8)3f#97Mvw#Jc@h;h3J+7*Tnx#r$E`aa% zr<_HoGRGs(15nv~KLbRG2fVeszC%(;DRWK8?x(lsq=B`2&1qH)%`211sc0iP@d6OS zfA>y)Y-E?<*E(C!gLgp}LbNYA%g5~+$^%R~bj)hpy+S({I=0NQ>ABlqE#Gy_ws0?F zf!5F34re!pIlEnyyeju~!)DGw9n;omI@TkEPHpAc$3)Htgf>UBg~hi!uRsR=&D{t& z397r5^xES61%Lqg7Wzv8{Y>qV(clwrvTKA#HVxVzM0Cp9ANz@n(m1YhwO9&~;J+p2 zc&+G+CJ`$t98K?up(YxNJr4Q>=eArN#C3EGe+J^6ahroTH3k}KzH2(zawO4qP)a}+ zn_>kdV+(HjoPgz)IY8Fy59XE+-7_p3)pG@XmsjR}aYVip!eLc1sF^FF^?Q@6@I6wl&urvjm2Pw&Dabvb(S4*Em|akAk;kBBhTr#}D>kcg4_np$ z3lzsOt=V2Nhl)E-af9lDpQUUYJCnxHu&`In0XX}f^=4|YbMHcU-Oh+s1z;?fq0n6S zh>aTCxkhohO3P&Z+I6^w_F1x8CP&T)eT1O)qtl#3M$iyQ=3~jfI-b>4eR}_WdE<4_ z2Z+->t;5D!G@%}KZ@ku_K7U|)80jYkI!6t+fQHRaHl9t?*@U)hh26h@D_HtVsw@V0cTiqiLqDXbfSlBA zGjKouLwcV}{rW>EE-OSGu{qyxN@@W1A|j|x*j@fT#UgU5Fo6%19i!gkwG%dt^gihK zK5c*p1He{|kvbw|u(NrQW~VchL<3oY>~+h{c|$8+>7V|tJ4Lh1WqE)abj7A@i$Z?9 zN>I-eYNR>4^&Yhf(qIQD;9j^b zNWy;}#o_Vzz<^zPel8(~=s*@VlNUJ-nL z`>VEbqW=Pk&I9>2fh6jH@VVl@`MC&dSdEL!;El!;BUfGBv~7omQ!<13GZ`E|fadnU z*kY%zpB$JRh(?ZgTuER{X%u}yW8YnK4O_UqPS{x9Rb1SclRBa+ewB-TG@I*%77Vs~ zxI8GgKkkkUQxG}Kw%vhU=dW2v_l{aZEq>F%1k4cVMekFez0YT&Z$6OPR|1HVZ4D$a zXLfB=z+RkQ7qqPs>36&4esWwLu{>}%ygOPWR*_IO<65hgYYvIF-I633QSdw>vu415 zXl<~c=l862>1bu;4Fn%mB;v>i{$Ma}l#*|yuif2#CLvm}-B^?OM;z9Z*7n78?=%7&I}$cn$}+x>`jlH2 zdlXk*`t-r@s9plN6ifLa!y9_{=C-~y@VLt_9rU;1`(JHXj01uKTTFxlDZPJ@p4lXT zexY}u%1J-T?dS8wlOKqj`GK0?2o6O}232kRUWfb3-+j#uYX=ns5J&M7Ry&}{=TVgh zbC%w%Fs`HVHNH&q;+mSoM}%L;;(eg#$AD;F_DK1LcFS54J<7v=G_y#4!>=#BPVS^T z?=TA*-cgHdj^L{Sh0c)b4ZpdFLcp)PnX(ZRbSRSK(-?&I*D_5fdn2cur6l|w5%SkN zs;NoNU&R>cnEypO^G!NAIYLcMpnuL?RXu5W(D*6dhfev^<9(#Mrc%`M<8gouJsM<$ zh^(N0-xGz>%tVGYb+Le0*Ly!eWa-13)wdTBJeFFB?~XlWHjqmz#Cj zS(W2Juy8!ws#eDvf6m?&orNP(Cp`GETx~|!^Rdp=O}%l}>uQ=xbXC(XgEi<_qoAOO z$GSUB$Ma`q0K+7@vaiE={9B1*5H-#`i^0ng2Mdhndc%6T)lj14u!tG)tpWRo@avy|M{X%^E&R||bW!tm5J9E}L8u)h)EheUqU~o8iRfOXK zwYy)g(6M$C=-r%tlwkb#!$;8T1wR9Rd{@jGz5SvBml*+v@~|QGQ6kx3F2V^xn(YgR zr<`|%bOvCNe_Dnq57d8t9!@P(W1PDRk&qzn(WCWln8PMeFt}~jp7GvpJx-&@_1(&l z;|vbBn!0NH`v7WK!$Q}#cYQp32qznWq$q$I;|AvGuPp$+y~w@JypHB?mRt7 zLT%cvzqsRW(Kx+6{PX@Cn{9*NMRDFeHNy+2o{BlD8642ZBpc-ulBr|aEs6(6k=RU{VC zlbu!~SxHV-5*8ARuHoXj9(6Do0jrF+I_xd?+wn(M9v@u**=CyY)DC~dW;)|DTIB^c zRO8zDEG9-oW)2hLCCHD+3_#hWRl(!#HgTqMgGQ=Rrtt%1N&nlI{SwxFE+->{>N3Q3 zrj$Bc44#QE0s+u8B07>7{I<5oa!w|JRD@Nh16L3z@{7Gi&lE<# zB_T2Ga*SASIG;In`u$^^eCW4j)zmireaqdIVb*VR*b__+YsReVu_8M|Dh?l?=NV|K zKfWS*!R0{4Z(O>Z2)s5|h7N9+iVAC6m@v&<2H_4kWil=qYG0JMaLt#XClFj;F0y#Q)9b%H@2No>8VTc7(MN;Pr#} zD{Afq&4jdZ{+B$^jCA`qfr{rCrGL$`f;YVWU_eehX^Fu6yHO022rOX(2zsHdq=$>1 z`!^y4|1E7qyi8OEjm{d~!y-u7hW>}Ew+@SP``(AgL<~|oMFb_K1SF-A76zn6S_Gs! zl1HVDh9e*Y4BaqGy{|d>Szt))hO1ExHa)Ky^DdGC1MeHIet$7Ur0ZZQ39$_Ka@B|CD-1((zZ`oUV4r(_-Yj~LzfJ=|kybyVSDRJx*IQs`>8*j)J#Z(Uu~ zp@;Za76KA`1(iTzxi~ph0UD}P zj=TB1@V6RjYfx5qzb*XDt%XU4sRE(1wx=?fZ=N7s%dHKm@r(FCsE49=_GYA`R3%Bt zp6=jJrn-Z-YlB%f;7Ze!ZSR;B5r%t-7=Kicu`kMzIwG|a3ne&6N6!(9{*|g=UHf4h;0h`v~|Itd9RXQ*~@M>{gD|z-wz7B zzmT@uUDU8TZdSXvut3r}^Mve9P*4b2`ZiuF?4xE(u>j?m%ltjwzn-@m1wLHfN~fWb ziD4?CbUwOtcIVmBmrfP5fqP?GZyqn1v1?m`85k%8zT zEtCLJ(mDJ$(uzEQFO(K<^@zO355Utyoz z-5a!A&i6ABF-#!|F2m~k79j{mU@Mdrcv3C;ntb*T72?0^;@!vnCZc+}KA^y^-Q)ng z)-X61X~-u|(xLbKg}DHS6%#yjbdR+i#xSS_^&=~yRy>Wwx^WINu9kT=3!RTKu1<@0 z{9gbZJL;8ps+brBybt6GwzGD>M#L75hwFgGEixicrjxhoII2Fk_qPG>MrX1no!`H&xRiTuBP(C}_bBGP>A+lKP8B z7#1yMn2hxE?*!@F6JK^P=~V9;NPOn zf(BH3F^iv|uel$kTo1XFP#X#lz>|NBlck+1ElimnS+KXpfjUjwUHVlSFc{2YAy(Hi zU*oV~|F<92YZ@AG?Hf0`9fk$?KcuRbw1g5s36K>bhU#gsiGlQHhWmGIUfmn2R7kd5 z>`9)UtS~QBvb{f${1B;t^P|?xq4V7XK;W+8Al7fB0WfSHaO&(t?yIj+rlxiNqXl#inHU zX-}yfKak3ZxF|!*nPkk7s$uZmNue0S7f+tgr@gs#_Xw223fkLO(@}z3v1?=WvM?cs z>m}ABzNCvlp>_%SKJ})kv3owKLRWqEWWoUy8wvb4#D9>!)*ghFACVOgpf^1Ex&@XJ z3aj}ix6co!!=5Kv^ado@&PwM&xqkEBTCUuT?yn!y!=PeP({i(`LEQ4R*F#qDAGF|So^F;pB+kDlhUMqiJs;qLY;1T( zDTF@brR>>hnG1%a_jLvV_Yc$%dqZ6Xb(7I(3-5bqeQwfHr`4Q6$6zjCc6w8t>U9zi z&K{&{JrE5cXQTO^r+?|0+~4SNxkDKpEnUDyV|>qL5cM^loU?RS<|F`cNuS0J03jIj zi3o5fQk%6)7RQL`OBQggnik?f#;1p04n{X#*hS3?6N9#HV)Fb8k8yD$6_-_1pof#j z$&X<1op$_XDJdUvzSN_>9MXU7Io9jcZ~BtC9)e8B`K1NBW#PepfP^zaR`lZDPwZo5ZQ!v$+Bd=TV1_CRL{R$^KDtQ@VWhMA_59#Z;Y!K3wKQZhO zcPM<7VFv>$w=!jxEFjs@nB=bEyIJwmk^cpE)J;z;aVV&1A#fD#wb3j|L1)=`t}17) zov2&FPg@Lp_F?%X_RN;rY8zeEk^5EcYukk`_TyzA(!L5qp=@-(9ZQbIB6PnpAXKl= zMD~AofSNBA=j&hH+JmHZM+5#ZgfS}Ap#Hh|ClVIJ!6_4VDi7)C?YZEnG>==mcO zOYaL3&)^)h6JTKM0==qWE8&8M zU!wzQ0)I;o9#P53$*ezMx7sAyLxDHU*18uck&f-}KlkyJp=PLE7g}dXQz^FtSE4qw@&j9?2##TO6leY7}y|g55aH zPvi$#VJ(X@;%M6mxKJpD_Hz_0&=5Io=U=m4f^fwPc{OA{`pd%2ΜA&#o-z*RPAn zAQpB7fpgox|9N5Ud?wL-d++`c?kDw=*8CB>h1H>eA|{=y~V$j z(aUH0U6vbdD5^GI+3ds>e?-1IG=_wyIWif|hCY3;#2PM1>Ezh_fWxR|1PYCQOM1|7 zKwNRUy4%fL2@l9lpaFM1C?RN@K-6XzwOMPqe|dIL3DAG(EJhV`eIBhRfMk_HKWYBu zEA-n^y8)8*eGx3PfC5N2+cN?V+W}9@QXyBW1ChdjTeVn`&$+Tb-rscD;$k|Vk4lRC zEBIcITCoz*eNJ|ObeJw|V$lade@ z{$~gEq7dG|NwlLXg}s00rck9A<);nlYFLNc;RLhh>o?^|8|Ta|P2uWc)}L%@ol;L#RhQOJF%5E7e? zcDVuLhIx)wT31}&*3Llh=5#UI#gA9ZOa6xiosX5_2L+0a?;69~1r&~pRaQHdwVO0R z&$;m&V6$^P5@IdHyOZ!r--HTRIaMgZHw9s5{=-g=ydIv@bxI)f`cbGTKT&bYZ8=fZ z)HRNNyXpXKw01}eyOtWqM0LnK>!-7dYRBv|nU=Nv3N@7Eg=7Y7y`BTN%!&$@TsIT_ zPOp%ee@=ibMCm+$aSAQDrh(>xA#6I=cmUXhb>5HIA^;yuQU3K=^N@tML>el$CVBba za#~tiIHNe)yjfpo%b4(m1kvvO+Vl!rlpdZ2pr%6mh#>>ii$HICGN*D_De=g*%L7sl+r!IP04Da_pYmw}OZ zj>R9|t!SbKh%kfIxiGcHvmF_20GqC(Uc`!AGQm+R*dH*pa1kjXLmBFh_c70a3=!9l zvfp;*4w1##*bR)c6qkXM{k1hpx1*WX5nYc0IG@cl5!?zG(2v2=CtR1ioO@)kA|0Ds%7bP~*8($K`TRqe(w8ypdSF_0y4wE)+-@OE`b8fE26jXB>F8>K z(53Cshz_H7>fab+pnp2?6}l*1TjeqXfshTC_nsS!fietE43DTn%w#9;B&X(IuD`nj zF`-h^a(6;A*RroX*NAtWX~_j;#Xhn`U)`5au4lrHABZI|{s8h@XL-Br1wA<{K2_Yj zg!XdAaG|!Q$M`7QpWQ{)m+hfXJGeAO)g>uj!Axh*u}$7k|3%o!fuz8E_0lX0kb?J2 zIt&akC4tmPYe55@<3b0KdUf)UZ=RZgqr<_ngT#Pjn3jQUn4JBe9quDXS7QDD>{5QSl@fi}>#jYl|Xw zZHC!l6!<@Y7$SL&hu5QL8gvprM&%Oo!*I!nH5)*vy^X)9OPA%Gd%xW$&fOnimRfsigi!p@!B}8!IN+Sj-})C zCuPe$hDLGi29bwrHP(HzPTdm*yivQI#+$Vn`LYKpYV>7OB}_I)sr3s1&^!mC$B$di zOYcMc70l)2HuT)E4xuV4t>@&1!PSiwS&Q^Ecye#9{1DY|*Xp2~pn|R8$IkYEe6H5E zm;&UyH-1*fZja#4_5R+#@@SmFwkM+VtcOC1J39j&QP?^zq86I2&Dpn3_5x1%L+6%< z52r@-n*DrUS&pkje0z5Ta@u}y>Xz>NC{GO<_1{jlda9ycf6x^>!%*O?kDlB9&JL`* zJ@524-x?Id-tr`{9!|T31t-3IGFF}%ZMp$eS=7|&zE}md$0vV667S!)26fbmnPkL4 z54Ic-+G@P3Dcz}bI4{~CEcNI)PRpPz-1Tcd2Avs)qR&qbdlcG%HiepoW-ZC3&|o~6 zgaUX)XWFS^gd?hIpy7l3{VVdb>}G+r4SGBpILNI-1)QOU$p7L%B8~lwYxU-;*+Ot~ zLiBupug1iF#>TQRqhME5H>o}khcJwIgJ%m z*{Q9KwGF1n5eMp@cRg0*0|0~*yx1EMYn_Wm#@LM}3Al8;yF$09cgI#(P}>fo!3*jT z?nS^i8gy0s0;E9c21QLZ`kq2UE0sO~7E*ySBi?~x9bPBc|9XCM<=OXaPTE;oOwETZfEE#}d)xGshu!>k zi<`pKI0K{*VOJGs9s>iztGb=Q9%B40n^*;vX|qqCCunH`f>Bp3VAZS(tfQ{x>3P`n z)@5#v4l^dGnozA}-8xad^K<%~uCDuHQ*s4TS({=Yt-+7VNXKzIvnD@3fBiNU5#%4mCs>{t_Uic1$l&02DYYDK zGqX>=0aCPgu5MfQgy>E5CQ5l^nxC6{EH{tnR%C6h<-rSRtM|Al?R>rP{qc8S*}c(@ zXhX}oefvC=Xd!{${3II#2UNsW0v(V*6)ZCM*{^;K-@XdV233F>eM!8Qn>YBGAb)F* zZrzy9z?@ryazzx%-@5hnKjIm=2Gq-YT3#nD$E%g;^(1)=tEeg9=o1D=LA8R?mDEA+ zaqFhRxy-T*TJdKz_?(=agF1i^)zjD5GDs11*_ZDKngH2Le{bB{`S?hbMBiXYH~B!I z!rD-sostUj@3POPhu5Lf@K2*a0W3zplU&ad?M(iAFfPmwom;%J((3qHrv$u*fqIKkgou zn;|^*qBxL$tXZ6T9O|>nSPML%pT}zCvgG)l_$;J8tKC1Cwv}>tlzT9R zLACtvMU?241yVI4csCa&Pt5nqb$ET?|R055y(ve5 zb2vS%t*99Oy-)?>c?rucEEK4-q|y}^H>A-{?Ew4kb%2!ewT&=%eue4xiX5F?+=*G; zD5fleS@$GfGG=$iCw7$d-aP-XL%ZAL8;hI}s7HD2ttUGQn0LI!)6LY{ySrmjZ{79a zcl--6TUU}S4|+zu-@VvnsGlVlVk$PZ_d+PgZ8>6L4C4X_23$jaIPHY3j_{ucj}YUJ z?8c)!wM3;-m(tWX`vXk5; zJ|pD~olNvr*H%}@9oCmQ=r*NA3L;lyHOXRNN{Gmb1o9uQootU9tG8q2RaJ*8ePe^! z76(hab39Itmm0Y_LHmf~e_q)3<(AWetO1#~AY${0mD4PIpbE|xT0H3t#=)QETwKj! zw2|Mgpbip$l2z1@!XIOKKjY?`*5?uoM5^_9=bpLN60dGfsGvAr|EHSHYIx(@}d`%;{NC9 zE`Etw(Q5jE8i)94-3&Sp;n#JYRw=Iu@L6A9kB%|F>>?hJfoc~QLZQ`%h0pq{Wnxug z{0Ubk}7Z4p`7icE6~$a66nVnOD6B!NL9U+FT>n z>$QWt?QufBV$RDS`=}>C*stHsL_#omtLeN(_>aKICJezEE3T&XTdM9Atf8=Qvy`=g z`Ua6-n9!*#YxN?`@;re;z*@zxn}V;^wh(B6UdER-0g&6x3EaZ<1-j{{QJX8p=yFF3v!+HAtlg- zbvwqNO-L2$KtmtL>0ZZQ_wmk?oL3f;Cw65wWjyD2oG0ZP&xUaZj*Ty9v*Z;lEyrcK zSs+rl9@KyNHb(<$Rk$__6=@>3{ACFaYEfUF(lytLeua0PYlq1o?I)@2Ik>$8=33iJ z77!pTq^;#Nh$|^!kNkq^tUo|^zT1pwC}vdYoALA0=k;Tgm~!0MSBL~8&IeXhMU8y1 z)=Lr=l&?`;_NIc*!P;d(UEN2u{H3vymBe|%yO5(WFKj^`&X1!Jk^kM+!_{{_`u2NH z+BgNCvq!~AbIlZd zcq9O7_x}n5#V)l<21@d)ippW10_Hl2YS4NG;h)#azIUQ-?w4I@ueI?_%!KdVmlAwR zb9tJ5D#~gxs#vkL1#Ur|Ki|v>1FHvO*yd9p)X||N+zoD9Nq)3ts^X#D9qlVI^O2}Q zLP)N0+6>Q;Eg?B^_xLucx(D67u{e(#`uKiUX4HBI6NO0Zw{XZ~V^g}6X;m%vpX6qD zbu$*_2lM8?fA?Hf@W!-F z!blw=S31Ol=1UN)M4(_+T*mYeU)B^T!aWR4Lkz z&gA`~3=AK!VVnBF0i!WPraeglhSMILsNtuSU*9UU5y%b74*?S~QukJ2;z0&|1ZqG& z6#o@B!V%RF?y2u1R=GF4pkZZ|7K^}f3rQ{h`uzof;w?RJnMQq4FP#+!IzDL!?M{~n zaZQP~n(_#lBN2sFA`=!4_d9NeGbQEcpV$IO!u)p+A*(&o{u}-#lUdSB$}4b!_UcXv zCtuw^Rltw1f|1(9{!o1WocnS%);k3!O8(BB6_(Vl2RrURvDycNV5v+B}SWW2W!nB-^7e1*IQryRh)e&%s&Z_mT_}p}a`AozZ z7hZ6?QM1rK>Bv&kQ4a_f6f z5;$v2et*kHFBd3+F}$vc=`U-Q11Tk&3q?oFQ3t{`J{pazclHP zSwUU)_NippK?WEN%tJ|+7gS8L>DR`9l!-qeWcmk;qCKW+L^UvqtnJUxMp5J1sR$=m zN-)%{}$EHc%r9T0Km zKi5fk(1f;ua(@@mn<}z-aC6M2(Z7xu@jH~Qm7eL^)Mp>UHFq=8li3E zdO~OnMMGe!3w_>RgcCfZTxB;(_n&XEt}{on+jp8&A6^Ja^N`D1*|iyj&hexskn6OW z)3N4js=Ye$e>#rZU;oASd<8__Nqcs3YkiSXVsr(FzU z@&x?3QL^(V@o(CxpOxx`NAXd-f~RW8PqfP>^(Z?lYtcTyN-PP`06ZnflLhQnJG4#* zKeCnIld?~?3%x!rwH@glzvFeI`gH0PNQrAqZwWsr`SAOuu7!o{Bksobi4QO1Vmm?V zH~26=xZa3~bZm8cV`=2~$$S#k^?IZ1?8D3OO?Hj)U3Y7H zbshHx?nyfcq@m;gwo-ttkF|Ju->#3F73zCU${p37qJGJUIXS#&FLpcQ=rptDBk6Y!2zLsQ$W2=`dO z?g0=wP+XqGcJnMet~U7n4SeUrA)p;V{reS`^da7*{L;5~u}B|-_yI(C*)ZqrZ$8PI zG10&RanbDh)L+d=w4(!hMmVX$gm9`9#Ej@mMi;Ex!=K(oG$SZu4k%vJR&yGp87Dhs z8JtMd+sQgm6x;#nchojKp>vN32v+Em!7b^?4}X`asI6TuFE)#%d}RPw_$JX-MVJiF z{L^RG{<-bPfl`-_M0}x7bzQf8_|Mv!`^#mBc(7r)l(_Jd`77g3LyzN{ozKIvn7my$f%@p-Ju-?*^ znUC9^i_)TG7gtt};&tvcnJinFw2h6lk_aKzsdes(5)6YkQ({64Qo@8Tsy+dX6F3c# z0BqP9kB^t9>HmHm(3t*Liy}54)NW}ZLql6bAmmqx(0zMz5}5pV@7^(R$n%O@H0}?h zmgcX0tzB0VPC%UP7Xe* z!AzMn1je14U;CPN(c8A{{uRcYvhb3oUr||kw=#ZpHDKG`k6ogL7~g^Wb{QqWI?jSv zI%=)9KQ<{&f7At1R3J2n|4aT1B8&hkkbN)dD0^_wq|~0H11mK&aaC}W%pLs(H=XLI z*ka6uvSEeqM{;1fQBuI>AF?9N}VJCjAs7JwpnYsPq$#Zx4Sv6fXwZr8= zf(4ILB*#n-=z$3E5z30Sv*X=#x08cM4_ss+{rS#^o8w-!4u@by{G0r?tJDeo;S?%cEvClGWNO6zCsyb`|$``E;t=ILI*LUB||UwYJ>CiUB~He|@j$*FRZmeWM| zLp5rYFRBcrP3HY)-f3xRMQ_p^E?HOG?tFhS!5oyK-12^%zQot3YSO$Y*=^Vid@PO`pHRz5x-&aU%tHnF1a6-hKA6|ayq6n=PmtUUhCy>%MH#{Sbw4R zXukVLsG(A$`*D}{w1X8nTm`hQ6*BC=cKumV_jA+w9Ru;hwuM+7RjZ4$V<*ZmzvQ6X z3yTZVw0Hr>M*w|zg`9FxAP&QzPDI17TS&N?lF|=g8BGQkUYDi9R-07@(KM5kz|kL1ql|Qle_}@OgS`1=s7(Jg7s`OY}8Yh0r=Mb~9O)uM(SCp4$ z);-%0W~d$?o4locdiMGUo4JNt&6;#Ha7_)HWyoNQy0*Aaa&CdX;&8jOC0*B4I^Rtt zNch_e;s3aunu?*YcwjS-fnqE;xO~^3aQwCW*hE72!JB8!3PvE6S!6P=$l^O7nsJ`w zEb0YEyqENdj*ecNT`RKu>{~LM2{aFz4Osz{3jye&LyP$?p?`R zGL|+u(GO`JBJjZ z=EJ`BxLPVLVM1$bC|0{zd3NPKfhe34BE-c8&3CP9u}94!cv+5%BE7E8<@hJZ@9pU4)vC)m2;X zM=9WXzV*tbPf$!Wokjp=tK?t53{~$X;MIfV zT%QakfvY;4FfqYjBb=G|f|(igE-&X}o%G=(0+a|#tW2vy{NPL+CO)8PJE9c$x5u6$ zs4yE#7qq7vgMyS#jsX2OpM(39fwk&ilgV^inmuUs0glMQ9mJ87iP4?J*L=m4$a0s; z4-95EJRNN}CwMDC5bU&;D2KP@sEJDw7acWF@c&wnN7v{FDG(Ck;hIwQqygw-w}(%c zrFxxRS5-CUUTPSj9$ZK$2NVhNQUtg7O87VHco3R{G)I5`1jn8BL}o@Aj&!Ds)O#?Bq?9gT}_tI5HavwvY~*F7d=1*#sG zh0F9%`dE($9M0RX4Kt5`ry)1!&IWIalm7g;`h2QXQV%9`!?WrbkX>zh&8twZ%`wLk z2Y#Jvf;Qvfb!f>_&a_5|iwQ3^ng8{4VSTqd+D*T$x1{c@13@vMEn0&ju*P=RblcYn2_3SQnPyV)3&!8OabhiFLjIr~_oSR0N+@}w%5t9QEt@5E}8${TS5 zczT0sGyIvulzK#`4bAaz{XY>MCU^+3U>fJ|P)11jJLPPJt%NB2wl?`?PrY2)8xU=J@R>OV7TCC6pjoU_TZ}pdKMbYdD<@SP~*Fds9cmVwbJ&r?2h}j>U64^0IJBZaaq3ZAjUB z{IJCLNmB2Xq1q@A?q4mso`k{e|G|qenq3vHMJ1DZXG)sNN%z|EimnG{%vwb{^$v6; zo4c$Hy@`Ads&utUD##Kin?Dhflq+tV$94@SobfwbJv%%11undEoxD>uVoqvmYK9a9 zevl!G!EFgzDtshO#el4Q>FE4%T#-21qM_fZqQ^>sIzH?-xh+vY!*7Ez1qYJjuWf^z z2bWXJwdR>$^gf19Fjb(=j|u4>-({zsU~ z#4J=yPfh)f8*RYHqu{**>5`HRC9YQHO3kji(X{m${a(0N0NH;x?%(xtqG9JAp0lwQ zSybbm9Q>e8$eLs54`j@B@)Ue@We4XQRLj2mYci2q@7|dsYs%N-(&0x*jyo?vGOhI5 z;WO~SnIf}c*MoNB?#F~ zoH#^`rW86vFt=^g_bgU*ael!tvy6c@N+af(zC;L2)}WY8;^GJ{bUR90rDWm+^p2(A zUci`P)~w`OdtSFCLd@O%(IKk*Sw^-hk2Ut_r@ z+t)ArwRo^(@sIPDSoy^HZx2{I@pYsS&tVKBXY0n8)1pQ0CnUO{j4qVj?6o2w2=`H& z`JnZu#r@dmXtVsMz3~t9a`v1|&rkZfr`#ow-4Hj7@dxI(# z>9NdOf90*EFxmBAdYe>oTzPQkh!QymTzU`Lo7c7{N zNTW7fQ9-4lqk+cOJ))b*sE78>Ub8VRxneZ>DqLAEjL>KwBHe_<)wFOta0gAGFeyBN z-}nmWLzU)h!`>tG%?&Jy#tAm^Rb{ruZzX0xNWG#vc*scg`vdjNF0St<9iWzmT7sG! zQo*bT3P1R(J1REfY9((7*T}{5w998a{qAooW6z9wyyyHiS{;WTy29UDkamF$)~J&`tpeYb2${4}Lw@$r?cT+q+hY4huGJ zGE(sgPCQu~E@b`*{+Bk*65YcgS3>QQUJ5gy%6&;4WLejj_#p*|@ISUJr@!8ySRx^U zmf!sPpUIOWOw?$YuSJ+r32)cmJl{*X4UDGkrfLL4ihuBtD|hG_;nYHnkPVc z(KSv0tE#H{bXHXy31d+NoP7~!BIy7FJ<4Y&Tw8GUl6&X@N6bhin5=M@%1X>}Y=>aV zV`Ee)S&BOFrOGNO52aS%yt)$C9G{)Qlg{uxO0)`JSOS#tSp`R(4sX_0rS?H10<|TC zgRTiKELmCocPh}VgfBPsw>7>dB#=*wVhgB%9thm}!Aw=_{avC7L)IOK)lnsjqXkxN7q8piHz5Y!o3RBx$NI-Pj;Oa@(>xkH*LFAs z&4uXK6s_7xVZV6(yiLYVPKp-_C1JNUnF7iUx#z*k;JVp)*>mnNt=ylTQ*;<66XU%~ zMmiW*rMq@64@_(BY@Y=ZW{+pIZKnJ5tu>=WB&g^1ZTb zPjtZZeVZ0LT*T^j-c>2~@gdjwdd*tLx8Kw=@(>c!(SI{Tn0DTHB-HD zp_O=c;KE?j^52_Uy!hYWVx-KGF~>wYaonb7RaKI80U3p*eW)R_r+9c&JN6k;0N5F1 zq{*EeY5~8a#As->q+L17d(y(8X{pj&a~JsAd8$R*+7(~)wB~MtqM5dR(Q1o{4hLiV z0fK@Jt2H1fqY9DGe{DbLKT}TMlRyIa1W#G6ot*TE7=p{;s=)cI6m*a!jCXw|Z}Wz7 zydKt<3?^1e?9k|4AKch(6F8h?4G3<-Kei-ZEskcKyMMzi>im`>pWulUP~U#{Rz|^p zr)Rrst9L;F0-6_*gr$P&Q_iUAj0N*b*t5ir7qDDHz*r&?O3Z>fs?s@`T{RnvKM^_} zj1?A&s0Cnlc@JJp7Jf@uX0X;_3oBrLAcXDQ#|#ZfmYH0uFWF+=4=23GQh}228U^zW z-AO$LVYbs&!)~Fsmn^tuoLhO9yn9ey2DnnIYGj5+hKAgfAq>@`|1Q?@opxcW1v+yG zM9-l{O!Oep*GY>?kel)BtVKUe&6eT0zmqn=5xTZ4qJd7jH$k0a?Vi{lOW+<5a8KDP zk6IXQjoM^KlxyoTq@tK=sM4jt!h^4$dHY46xA#D2e zEy)dP9K3jTOL16XlWuI`zDKtp<)+NY{B$ukAfV-!Bq!K;HIk}= ztC?V941egbidyh_#2Uo5Ef7QsCwZr-d79;)v9p4fgM?GRDnPv&wL73ym&Ra+aBK8c zb?$M&F~s%6O%@c;=oH-lev+N+wn=tNwz$L`Sv6@v!sQxA3C5~$aPFo|8@a#3$m-x~ zyi15`3oOqW-~VqwkRwYj?{bpDfhSe5Z6x@Opt8D>lE-RpcHE<)I#P$Y_6qZX4Ul=b zZ8s8q`A<^lQ*7W(O)o$uqY$i`ebzxB)H(UcO9|1aSu1QfiJG3Wg8v2=uY(+ik%*jJ zm&SF0VrD!tHPj2>2!Zw(BV-Y4`n--GF5P$fePfli@%s^=-cLuqvb^Bmm%xEVWgDLM zFet;VIHw8;0#KlU`{n87i#4GS!lQHB{+yQ=zi;>;RK&C_DoOaic(Q08e1U>?giVt* z8tF)jhU#?yzL6JNn&1S?n2|laYXEY64ZXsM@l=Q6h9SZ-l_%S9A%Ts(0c=2hZ{JO2 zDFmv!ME{mo%4j8EZ+?S=H_CWG{$8dl>9@AH{)!|qxivVqy^OM(s2LOLjRI*veI|qB zTj}Z|s569)?#+^Q>Ak{uXx2gLrG9+pJ`mn(SGf8(?09e6ZL_?h=^q@-xO6;!M8ak* zwmb~VwlLk{GD<)xAMrhS>JOG0PoSMoKqMd@tEIvArT2q~B19uv$B$xBdftH(+9d<1 zd+_n3y`I!vE+N-{^X72WWZ?L`}m+o@@-!Gs4xsOu}`&#W(+GI`he zGn&9blFWbwL{Yn}HP0=9iq#P8oUGb}tuhbDY7Ej68=PmISj13T6U(V!G6o(CK*LW^ zw^({>FenEC%qa*S%x8_Qbs;bXC0#(x*D$I8%#s`)P>mSL*q&RpIPS6(v8dGi2qXYM zno5{9v=ng;%e&I9b#~X*3nIl1FafW-*jPoHmm=ou5)03e+;>t?P;%>EH_!nt6E(oC z063)r&qI*V;_G`?yW*p`YI0h`6eDO$^Qqu#4r-yQOO1y%s64^Ov2t^x2g-%Yy@-V= zu+Ra<6cB?*`;8{6u$Qk|_wWmYP;1ru@yfVEsP6!(dSXIr8nr;>{|8A)qb!OX_eGik z+>ehI|EA)pO|{l*gXP}3N37;KufydvK`R^?8HZJ>SSHN!3gJQBk^JM&OyhhXS&McYxhYJ?n}3*EE7sCdDgiA3qASh7x9F&iocij<#t}-VVa=?) zXK)+TRCw*w@%>+x+|PNGb;jE;v8AR{Al5yMT|mgZG9Ra1()r?!0o?^u8#e(QuFJYzh9D3)MncVOUa+tf*8Dr$WyILqvNY;SM1t0)I^R!D zoI{LnPh9|_(?sU}Yx@ZbOUdWBxN4l^a#a$jp$P|xUF8wr;mbMPXakp6Ue8jLrbVMb z*-YjmCMgF!IG z1d+e}PlZ0DLFV@4Vq*?)BS~sb;=EaCfPv2hq`ir`LE-m~8u` z)x(wFy}zZ<1@7M}zyCE}z@;1K8yb!2o&8meCTh0_gsH#O<5mm$>W7%C_g7j{RUfNy zZ}6`!r}Jghy*BVR;rw*4KBjzFYF22faS?lokmhU~$W0Nx`*^>AZ~wb80uHkJw+>I; zKt7u}(tI{a2yh;t7G>>OCr6LT;qTC}NM{Q~Nw7Jxb-`NwsUO7){Vv4k^CwGyRmaJ~pL$J2pwWO^wL*%Q1{D}p?df1WEznIB(LxEs`K(G7^h)q4vV6sUE z*Yi~d_{{b;Vo5V#U~-FGrh zc6*X_Nj7_@K%rPx5v7-a4Z#Z#D+AxQ6BQ;nRcboGr=IL~U@D5bGduE%T%Uazs7^^K zH15&i6Bi2=uuoeHpQ?8Suv;gRY?v*^Ft_ZtiyPdkb91tGt@~tq;ZPgZO!X3Zc}zu5PY(y}E~LoLrf&3BfF4)wJWOEtR@#@rY<=VL zq{;rAnK@`pnDDpJzv#I7D0g~G_c^TcPjxrQUjo}N2c{8|30kZLVhK$I3mC088uuiw znN2si>AYo-2r@nxCv#?NB|bmNp#*CND$#9S5>7HQ->Kx!DlS%v6kymw=B#=&06G+O zN9nIl5k{6j2=Z@hn|b;cIFaWKb75eDWS|S6+L~rYaqf$?Xf@pxMNQ2-q|n5Z&^cmy zQm#-o>8+zZxz~2<&nu_xHOE@oqneXgC1(PDN#0HgSsgFPQvtah^(-IN>(P?!J6GBw zEXYqS)XIi?=70EAiHJLlvMO}byAN#lt<%G(WNin5r+c2aGp$vo4wY~t>Z{A@zjBps zHI7v<)6f7jDh6sq;G(EN&TKdB6p_?$OG~-+M>k9cLMb^krd&@c0#2PjcY1?xv%F-w zoD%&cchwp+Ug{}3_{+El>*>xr_HLjL2fB{Dh6Ww(hJ%`fFS7v~^ubid73Px~F~PgH z%mVBT#PZ!W-30#&sP#eJtTwMKNbh;3TDasGrfV-m+5)yKH(MYNv&vkpKR5F$S z~9!?cT~D#+S?@*FbC*w-2u`pF_v24!|2wAXx)l&nffHQN|HXsxBMpKjs0VMiih zBzsix(~|DtotAdczXHJhh>c3W;R0>VVStL($h`dtqTyH;t@j5Vd1PJ1aEcN4t>^p% zz_|c^7CJp_ln&dR zbgwerHG;6V2VgSRe6G@VdecC{JL;A3h;j=G8{Uh>WGaRQ0!lqRdwn%OZJpJA3UAT`XotyV6^<+ur~ws zSWHm&35vStZ_Kd-vseS-F2B8H+>VbADIpob%_jV)L7GHd=UQXrfO1|nxy9SKmGG$8 zG&ZNxoH-tiYO~mUr`6o`@M&F+y|$+UFI@RkKvJY#wbppOB=%(juZ`VN_>*VIDJ0?Z z7n46W`|*Zz^(A?oT7zM5DvycI*BhLcwe}k&AW0~P;l^`_|8LM5<`7jZAt1Pw(G=)w zgvAmbU!}=OLC8L$h7`_E**GmEud;;~QTW2036Sga=Z90sp$50py2nCaR|*P7dZU3ZFb%lZUUK`Q zzZB>nIw^tcB--%sd5(WvJ(bYmvFj~ReVvsC9wgQMm48&|l?CnXJLD;DUvogGfQ2dR z(~X@xDY2=^lFW7N%Uz)Z&8@mb)J+zj84B>vx3vcw88UC)Og<5C*&w%W!ByRA#&$Ra z_8-(SGe>Ti1EGOWGOC9q`g3|clw3Wrj1{tr22)F^)h;0F{{`#D9m=EqE&QDg>&-oC zX%#34icxVJz>{WbH>)K?sjhfgtgv4#nL*j)U^E%=BXtDn06dpKpMTY7a8xQz5&Xv9Yp^IIB7K(}2 zTF6}vn*R47*tEnwmb14%5dEaCAanESuJitSxw2RdU9E6RK`E0ANHO&Hw*|xt==V~{ zOP}DF2I>g560^0op{_3&gFTlklDC2KONn`HJuJR{>9WV_B=bBL&+(?GQGcbbk_(~) zkZ@VG=m1L??;6V93mhCCz5rTTA!=A~^WAi&6-KcIVA6Uflcdu!Je-13tt+ zuy78w2)%(Vwb!jZOY+y(a~Z5{6A+#4^xdP06!&`nTrCv%@3oRTBYI?Q!ydhc%NHz`S06*01~M^wXk< zTU?TC7#l{s^FF^ArTY;s@WQ=Q{`WUWudCuq-KsAi_G5drB+=n#S^q9CADk*f4AT?i1BCM`&>AxaB9 zQUigIZxiDGJI~`a&-I)=dvP#?1C+tL51BHj9D3u6O-qAC(|a}JfHyNE2^W$iNoUW=4_~0J5Z>>yN9@*pDus7h?d^9jOTyX7D z(Z4A&UZp_IFFR{gUHt5I@jf`LqGMoSpk6|9$d_SaP)GRK4&)f+5nf;5NyzZp=&&v8 zZC?PO;O8fK;-FCm3=oE`vKf6Ih+a!U9#ES68CzA)O3@3CkBLv<;3_6GTyu}ET`Rmx z&S3-ctK`+9x0W{+dC~@jE@8o(sE3{El`Wg@)k>O|wu#PiF}eKCXsNKsjMkPC&VOt` z1s??>SIl`tuRVMNl2}!NtfKsUdh zu@lFSk2D+p`dn-HHmB+<{RuwwSzfKADt%h?1Sh9kf3m-We>#>x>@ybdNlxxgoZSp= zoFC%CLosImlyPr%`<7D6ZN-N`OXGWMExF_RVuTQ`E%LsTW2WE9lpk7$6dC1hguA{d zLgJlzgUzBS_@Cgc*PA1m-_j9E=~+Sw@Ac_Aru!7yERsQw!h(&$)^EBcxK-Rd&-vFy zTww`9$H`Cq>7}YHr*7WnOXMfl3kH_h;j`!J&w~Y4Sb+;yi1#WbiN6qaa$tCA6MN?* zCDdEUaKsnjRfrqw?ea=I)vS-)BjWBREP@#hNxked>R3tSJUPTw*%iCK+t-9EEA=7| zGbF@qnW^_SS?DuqTVI}G3&>90f1aId$WgOjig50mZp~2u%kqljMb*9^^A1Tp4*N^6 z1x8WCQ1_Y^cbr>nsOC|^{85FYM3hQSF96@%Jn~bFdcfzw@MQCX7|`~Q$W1v93~Xo3 z@|GjUb$cRRJu>1DoH^`lhB0fjx2 z_sl`dGXaP0^h!kX9P7Og?_ag|_9^;2+)&uv|JM9+^>=bqq{fWvK(ASIk83g1-DTkH zyw>=G{vgL1xrk4fnsB|#($`n~&jwR$S_SG_h!0=HJll&SNrpoI9Qdhgwmc^qRFjywmMHdLnT5Z8vBa9Vr7es`Wi0{BTXV+N~4 z)Afm!)#n)#3srSWQ1Y!*C`Cc&TcsxTOugNFhy|J@&nv#-3b`@zMfit$hw9Sua(h=@ z*=&7N`P28hw-&QSa*8R9fV)DPs2N?2UyqNE|C@?M&!!f2tjG4)t^2uCcvavg=09J| zDcaKH!S0{m&49xuHzqB`JK~ZGCG6A+FA3ToF^9peTZ~l1v0=%5(p|g~wpsUha+K)x z!%LG=tVg2K zda)+;N7@?mosPox%g+SCm*!L~v0vIOuHAko`MJU>{P&ORDO#q?09V+nCV*`LTtD&D zO@#K6LeTCL;fsMkq@`|UEVF~Vs+mN21G5rUahwpBkf8JJ_f3Ne#dNJK36xoq za2W@)CpGqtIJe+#C8U|rQSQM9S2`UkF`nsQ5VxbEnq9x&sP$nd&I!kC$;BKM3?etq zL8bC_7MGT~3rpkCmLsy*m6tAM%Lo1C?a`om$BRtzedKGD_AU@o@D6`z;fn|>LumB! zY7tNB+rzekyz`-CX&_$@WU0NqG&DRM9q080DwL-m2h~+X?A%A@=Dz&@@1FQ}WVrHj zn92J6sZC?(+75-`$1D)5H4}dfFH-adXiy1G&27$GCOlg{9DVEH)s7{I>QmkZf!usc z4O)s86ctSvIRwttPf6#2)a61J-^oWRH4E*Cg!^J$_=<#_d`g=?N!0vBojJJ7qfSM$$W$C7Tu z#rp;vfm^B&a9cC5aSP)w$0sjhM=UE{pqsib&NOtioCPJ`Y4|}SJ-RfJz@0xPMP@Nz zX2vVJz894>Dr^kPaxe6A9OiGPZlYMt4|>5kUh%bMW)w{bIU1@=YN@SExm2vbb$Z!S zU05X3^7{+XBnzGsVn)m_g(9xiCWwfEze+4doE1TSv2(G2SPlt^SXx*xK6X^D1;VR- z6-PPB1Bri~T<0aT>K6P+^pf!D=8~|?npx50H$rs>8^0^9gUU-Rt3fA%elAtJ2v||3 z^#O#cU5Rm8c>`-aW{25z{b4|~pA}`g>pNJrmQi-Nn`fz_uyIo?#e7~2kc1n5Pr*sV zZF>bKFm`2)GQRcg@10TU(HNy=ymlGQHt543VzDq-f;N|Lu z3@;6yCB0O=arBA@e_!!GdmpVa`Y68}=OB=HOt-n13oXl0t~sS=)D^h*9=bLXYZ|}# zGxuCGP0}XWO`@?h^%>;btk=JPrQoN#A-M-3$NuVY137k&nD2jB`Db1=(8G6|Ws{b{ zoQL$xHyw_zg?YW$=pIfw3YC9_{1u$8APmU`Y}cljWK^P95gAa_`XuEz{vnNbllCplmgnr~?v}1K?DveDm#q}i zn3k+!ek4KSyt6=Q9EnIQw8W-=Oo6sJ~6p zt9BZV&Wp%vn8 zbFxebjZaKS-7$#wHRFkMcuiJ#plAP3#Zuv`G}CM)d0%iRY?skQ>V5_K@E=n_iz%xg z_v9Rh%|kuO_e1_YegtzC{{6%&BOWuivmMtojusEPh0X-8P^}WQ{AH|uwzF=J8cxep zqHY77Ah*sc7q;|=Hw=7YDPgbIMO6xbQvIvA#(nog=sIUue@g79hev5vn3<`I!y9TX z=!1Z|>jN#e3}7yLbnp)4F%hlAhDM{SS?dfhyCSS9rqYA2ztG>voz!o2c5$K4XA^&1 z3KdH1B3P-#)a;$Q`1oh0vK$5sDWjM>aEzesyRr|~lzn-o*VDLivQ5?`% zn4<2WbjlhPxM*a48d=Qqvv+oO=m3u+aRYX}bnLW-EuS+*^iH3qex@ckRzsIGmRwir z;p#eg$uVtAzw-m=lFzJ^6lNv#bEe!tWbCJFNfdbhe_KX^Ce62URNeUHq=^wdnF7Se z^75u^@*cVJHEtkR;;zA=e=cuCu2#jg8D-9ydH)WNXZqOxq=kKSnQS~YvV+uqf>$y0 zmBIJAqUQum)%Qr+75xB$Q3GZ_Pf1X>!#};iYyHyk`IV6?@ocb`-vw5_Xm39aa&96R zN(`jf4_^4F_~u@>_EG$vA>(@7Mo7f!@VT%ztzu4v*_rQ; z5;gqCPF1pDhGQ!qCDM}ypps-iy??Qa>E*}BPd`)*vag(! z!{E{JdFiG5qdW=$Ep`knz@>klXDH~)&2rEVR=!d1o8=dWx&Ku~x zC1$=907MG&Ck%L}bv^rK@07(PmR>PvHVm7Vq{|(rG1r&8SSq`A58g4C zBxNspso?XuK!LdR-NuJUReLi}QWr}?K}iW4HZ^jtq6WzM8RDd)S`tV<2GJ)v^uF)g zS(+T#VApeW(9AJ(?{B83S6CRxD1|@Tm__kM_%Od5zZ?qwMK>%g^HINdY=4*~#ZdT4 zLscOB7g)s??4*UNpDXTl#AE&CYQfNb5O*?k6K)&eJFS9WtFT{dI3;}9fAF1}tFNWC z$Zh@cLAoXOz9Z+8KIfz$d1gbFrc=F?N+V+w2$5_#f&d_2Vy| z0?<4pB=*U+O1J`68o$RTj$7iRm!Hq95~1oz^L-(<)#cYUPm<&G_5mpRMsmpqQ>w40EM-e}~b~%&ayqJN3Ix z;A&kSH2N+Qtbu^tcj4`K42%~=Js%o)72@_?_`#8SaAlJC+7Q0vUl7&v{!_=Kb5m9@ zXXKu!cAOe-8w(a)BoT5`hJ)sIXS}BW*KXnB;$jx&3|3t1l;!8IVwFpJ>M2$k+T0ll zgHnbTR2To#h?Bp3) zd2rSlQKTgu-6zn3saNa)RN&=d-_lywvwjXWXqSiO?{)Xvr20vL6K>vIg1v>*)qVp>f~_nn%F8xXLW%FMoU~+6Z5*u#k5j0?1Q$$sfNjX0#kAN-=$Y%%$+5s0n#!N3#;g`8sKVsKml!Hh|`Vg zj`l|RtMa-iGattQg(R${$z%(j0+%P11zXsjUMB=>qPm*k&+)iC_H?j z8Q6H7fPI8{GNhS|{-DkooTp=z8S&Er_=AAN98kxR-ymD)bjlcroFM|ByL>+!+K=1b zOYQTWD90%TF8|4jb{1N^3YPw&ac72t-Td2sLVM61eh2It%DovX8n)c*HmUDWfJgF! zxAkHBtxCI|m78%NYFHyg13ObwKD=qijpUxuANxmv;%$ONfMYo1*KaAu$PpISK=G+f z#jTI@wH!}d-bqwH|L?@|aPeBe>h?&AHGDH_-v89aL0=y)_e;V2;|qw@&!FH(I2i%P ze^a@@c zR@;qM;RGS@Gi9zrBKX>)o{+opHM;I99i6bu;@i}VvX1H44rxbF<1F@(!J~J{l)cw@ z2OFrP6IBy5=2=uwz~|s704AG}hGT2-@l0=iXNy}WSO(lNU_Q+4SDo#MR+#=Xm>#$~bdUU6=9BJ-nVtEY-N=Ht zWTLg<;pP_Q!37oSuFtp*gO_&xWbEwLM%_q)(!citdW^;~r+hDcHFbcIv^nzvN^yV0 zkFH!28^74NU1M};#mvMR*Ma4lQ#>;NLKL!d`zd1wIaKDYjGUVkiTw~!U67m%EwykE z>)uR1ot>N<#hRo+8_52Svr8R&+U@Zzt`S&!6k3laXvHoo!h{E?>l(0sc$^G9NRdh2 zLdI6KmYpPbHe~6$tPgppG6`P@1j6%%dnojL}V>44!2|et}+<0J?Oty0+G1_lKH7f4pX1&cWKU4*>Xm zv9UP?6eA&INm-4u<>o8Q1LJOcdwbu%e3UNMXOyjwXII7J{Vf#HjQV4BHfw}#8(@G0qK^Rc{Mvx(DNipNR zA9&(WEGp61$i_wywb=k5eEs)(#YMxeF*lej7<%*w!Fh)wyIXo}89prod;_LMUs*#dbWhpc*fkEdErp z;BDOFNZ=v0%J978pLB{T4&{ZK+xVv_%?BJa1TaW0?>Hp$wEJOCSxWOwQm(G~B8!Id zx&Sa5z|_e+1sOEK^|^pG9?CNdFlM;{2Gnt1*0KWQ@-|mt{mwF=m8Wj3{Ab@2np6Fk z3(#MzE!UKN$DSf8`UzB6|3o4kuQj)Gxvwd>UjrQl)P|}Yh78V%@6`m^4ZQm8y}yRQ zp;RYX0cKgPMUv3EVP4M-8LR~OEVe?){ea{@+(X4vVA7UYb#*n(;2D;!4^a1TtLJIZ zn*1F5W_QG@bdWrNupVC5Z{_05=$yyz~ zpgYPJ*E1i;;cI`5o%A`|nD2--mU*ALJOB6P+jE+jA6&<)$4U`vG7Tr&$3cO&N$E8^ zn$y7#$Bn$3a0uYg*=xeF!#$nRjGz*w$qO-{I0i}^2!->mXJ=t)8Y3G2U*E7E=^G_$ zEABPK^4gAdsy(14279gJoARJSUmiSiaY;GV{G@Bs>g>ya2mLK=cnlm46Gk0_Wa?Q| z25h(0l{Kz)3u4^$$s3KehQZ$+e>ei0klF6;tpS%(ck3??lpRZxvV$=2fTckbj11{u z(D96dItSWA(RZW~U$4zwS;FLF<%kVH2hBvuIi7%=zGntbrni=pdaY;ykE+!=@$`TLM6(Bf8!jZ3mKfAv z1QB@Bv12Y!Y>mgcihm#vly2>Ji^b9_?)bru*{yQ}T`dL@uI5uDF2uS0J*8bGUMJ`D zkuNt-TgjyD7#74QsdEl)J}EHn1aR1z`Q?f5OisRtYamnFg%jP!|AA!U?$^3o;p3h3 zhL|?w#RaUc-v*m5P9zkr{(CcZwD@1^MjW*t#o9?3k=B`YyuFWA z&hlvgXWM4476Y}YLh>FLuk{g~$yuV!9oMVHAH+?G>q3Z1)bJ0)_=Fbcc_hpD&zrja zd>f6v0inB zgVC97heRCq=Z#7@NanDtX-EO*5SV&KBPG%X;Y}U~+Y8*cd~{n^Ci@@kM45ZT)9pGY z%g+|2%fv^b62EIEhC#xAkyv#bUbnj37etH(-3K8dMDhCZnW* z+k9NaMoz{XN2DM0Panaq`IlPMmIeY6O|#)*RXk4KqH_7d>lVh??}kU|B9v_UvF;Si z1nK-9C+?@N(wwYYuiei+Co?MT=weo~!3v@gv!5r)so_x^);^0rP^fJOhYdNsz}50_ z1nF>p1SjRQ@*|e%G=%qcCF&L$zS2?Pt$bEpda@nh-JP&r*f41(D`p5^ebZRDUYSn- zCVnACm|v9wb|704)<@Ajh;fd3YzBao+AT925{tLv91?$9$`W2R8_`8YZPyj2J(+M@ z?ydV3`VP1;KnOHI`K%xKbc+hFf@o6b|E`lg@bL`~AxeG3-Hk2;NTi}+$oz7x4%wiu zco=%B-+;l~NkA|i6jAloOWrYVG*{-*>uj09F(81q0bGPag>BT4-P<~-UdRT3wqD6t zxu-ikZpX_oE;-5@)f3Oj({nP%KUhw|O<$$ix;o{%kxm_Z|LCpmd8D+kd|_RkJB^mx z@6Z!zHVQlM-?6c!S#Tt9jvd@B8Y& zIK~Lh52V@-6$$%uw8 zj$!9O0f2)@XI7RC>1LtbdFiyQ4=KLlC=^I3KSAvANN?;p8!yQ?b5ZENYvld=G71}g zG0~lQXCX>+2f!K!@#}ZAr$xeS7n-1bwQ36Z1Djd@A@o@!IH3FaHmFD<-i0UDQRA^+ zF~;~b%8)5li)fgGaAa`r^}bD)Lag0KPC9nc*)E6S_seaFX!a5<5*F?=*w{SZn^Joy z79N!Q^!KM$*`Q}~r&Z)PeyXfnx`2q=RD6LE>#55Z@KR74crzN>p0+wX5v94Zp%rW# zCnUGE9U^%m;YiWZA7R!I!zUuxrkT{P?Jz6EZXm`&9$5IRFEhC(eI^LK9KpM7-H;e|O4cMNYbIcbu5(3MBl+P7rCB8#YWYKbS5)i6nKWp5kdX6Z*J9FF zn=!3Qhq65!F4%YVYKHW^3mgHDpGc9k59~rwo-UHd}Z$um=h!7>)eAsuBl^!x;ChNLTu% zBR{JupIteB{MjeoPJf1}#I}`+$TNE@wpp7^XCeCMv@o!;e2>W>+u`B>#bj+dx5xQL z!tJY!MrHL>fc8%7NcY=Nbw6(*uyKBmUAc87!=+o>Ms{zOTO-PrnLpy1s=@3af~jN` zF(d4Zm-E0{uN;H$#zjX*qlR2YqV>=HtHmnmRi{BO_hmf=n_-5v^q$S6Xy__dV}_Sh zdes9~D*ECr^pcSm!j${PTFRvPEP9Qf3jHe3#+(Hl>BIgr!mexEcR{4X&mNU}hp%lE z9gKZ3@5~Z2lH#t<-2=iJYq=OozeDJ$p=@6M-c1FIMV3LZ20(BT+X(ro)}1OJsQ=L_ zw#Jb>kszU+PZ8~RmDSZ%)?Dqt!X~B+?7y+0*AkEB6ZxIamOSW6BGSE^{D+otz#Wi9D?RQJ}`=k#xijnD9d2I&>H!rMOo>3wP_n(QjzK&Bf3>t1b=`RL88ls7Mq zk#Nbb1uB|i^W6pbxQ_VjioB0PawNG%Or*QM0dxP6FE!-ykxv4`5T}YN$sZh}JnUqv z)wPzRVAuRo2oDY=ddDLK2B%dcWzyg87+Za0E7Sfkw|{79a^>rhCbVhpIT~^Ue+NC& zX-jf4G|cu|1zt`}Am74JVXYp!CX#dcTdf4hAcOj$&3%J$l&-V;(9EzVpB%aXcDNoD zXEK<`vE$x~mv^_5J4pDfCCGF9jf~yAFqd*&-5bW8?h~8upj5oKv%BvwjyfZCA z^$UljK6y^r$Ms#`bqggL*PQdGe9bZ_O67E_`Lm#M25-bxN{WZi+yZU&lW(Ehwc780 zo_%5aE%3cpTDJB&6+XeK3`5@fJJ-sEXq%twe5h;mc5o0)aYm(ag#C8sw#q;F*O=V4 zf-9;!*~xs5gLEY$7nS+1taEpU`Q3ipPOHd`iTIZa;wX5B|*ui9&7^8 zx?d(j*Cq-jTr9i3hq3L)uu2(*g~!({zqk-x76>w{4iyo5+;uq5uc``AAVkP9DqSNp zJ_v)iiQOv9e$P3Oi@M0oH>l`acM=4^@M4uDFQL4VXer<4<8|*<|Alns*{^>(m$UY> zic4%@d&JrZj%m@@Xqc9|aL~bM=7rqa5NHPOZId6J-N8jV7y-&GDn)BA9&&v@srTIRW;Rknd4ke zhTQCM1hY5gt8aoOMA2c!VaAeyso9p#b;wI2_)3~)E5G;7n=xnu8Qy3td9y5S4d_(@ z2b+x8@^*eBNUt+CwMO}@uSzX+cI2KZNjyp4V#8YM3SW_ukf6xGGey$kSmvvN#f|f- z@79p}YhOR*o9zcV9_)fL9>Jvwr<)(fQ{toG@qlMXzP`+9P_tqueruf^CIk*Ipl*Q@ zJkk0;dd8J08g^#J?Q5^Ru`m9&%(2_d@gI%ymF-|ocCzgct_3c47D}i1QPRGtfb6lZ zj*_<8-pm+D1R)?LKwsT<9;tX@n@7tWQ~TiXU^~hBsVazpyo&%8BmTA_K~-d$(2a%* zo|Z0Z98diU%L@vcvO$9L&S_ACZKBaIYaPVMy@=H#gKGZK?JmH3PUzI&k<2mV%bR|Y zS)X7Q8qi+n(by z-ofJ=kgf(I&kHm%;F5A(D4euxxFNUoXI7+cHWMW?<3$3oLjwj?)qU$n23{YtAC>P= z2K>Pls^-b(g}Rqn4ohRbcKoqm@rDFXCrCrj@4d+u$hlOB^;;e;S&psh2@MX~o3o0M zm#!8%9XbBR3G4?413M_nheGQ9w#Dh_5I$G&1Td<^9lDu87*R=41iG`LJaqm=#3yx7 zLdN$2FjQhN(zf3Tq(|`V(>PfZf=uIUaE8$aK^{OKm#>kepf8QX^L%qm?rbd?mys zhm*3v5?+)S_4ia`e%UzQoSh6vDuuwU^g|;rKj|Z|Pw9mlv!$0V#f$*Yp*LYMPYP^2 zj1oZRl||V}&zN5yDe}I*;Q#B_1l_#$R%f5x!NI0KVa+3&EJiP5ArSkUd%rvEBx#~) z=el#%HMJ_hIl?^P^zH(5`KdPsZsrGxzQ1@BKF-e@1bFOiw1M3%*<3_LA8o+Qex1*t zMgB;m{>9c2uUj7mu0D=}>SpXuVk_-=^Q2tY1joepZVE1y6_C_g;rn;Yr8WX9Aj>%t}@<}p=e3?lifeu_-)c| zZ)wKCR^IcIcaD8kBsBkfLFzwc{gDaS`PVI88Z~>p$~rwW^N6yo zRbze$wZ_Z8DWeIgDOtcBu_Laix&L^374DVpJMF_Hofm~h&lNhUxvq{^qmvGPO)FO( z5=QE`)0S_XRPk_`Npp5~b{))r_d#Z^BRVE%E31bwpAk~nubgpcEDpDgG!kCZ`5-QK zDF&`<_@&hb0Z5z*9{rAiV(ev{-KBb*=M{%?4Jav8A(?j?s8k;2FR9S${8lQ_;OyPRFhpUCb5{z-#?b=-19*s%dOAC1J4iQ z2kBe%=*)ok{!_%lrf97=Fcc}>ddFIIe3)@?&7XOpul5%g*GfYZ&SYvfe`$GaC zye7<=)gM_K|Aqb~C6T|R{BojsC*H^#c(1vHA4iHgf^=HJLqle(TZEL&50zuZ6Q z7%*!h49zFmq%8wNh}mPNe0qSAa3jC}gODgL9wcBs#rW-~`OfAUf>^3>#5Ldz{={o| z_P8~Ff~OWHus1F6ci8pbTdRY{45}s~s1k2ZTJw5DU_qRN z=@U6?Uxt@VTQ4#Rt8gPq9}B4!K$KcJQx0FL%b;`c4)yg z_(<$hLG8>^cP`*7Th?cp#FqB?d^hA8Wc%-1c@qw4{P8GpG4s#AI=}VyV$|i~x@4%e zCm#kM>A$0RJaa0r*S^BM%(zE|eU>4Jy`&X5<&&H|0DL{*V0i7kKp8gW6YXJ$QYkvJAiA)&j>bRta_%$qq}Z_DRH6)CmCv z)Z0~O(NjEY%Nys8pIMjXve$$iN%5%UUj!xERU!}{xZ2}i3PKYC8I2Yfg;s8X0$PTF zxJo_rjSJl3AYnGjzS7+6jjOVr(p79g=#_=dXa7Mad_YEss>a$Ne}jJ%mCt^0DI>N1 z@%Lz|Q?Bz?EYt)r3AywkLxRQ@m)DXkE|9FPkay6;ZcEPeJjJ6I5SEKCdEsM(pxSBSBncJn{dXMRrTrRDo`fOaFE%QY&NcA`9T0P)5JP}O};-+oJ%m)xb z$YFrz`DuvH3Ymx^Y*GH{*0YQo4YjVxWIxvCr~KJCbOboN>5Z-hIcPqA8g$<=K8DUb zPN}Ho&B&@F>t}&$DvDxz<%>&YfBdb=!xr0opVipH<@xebgKaZQ z)d+jwzW4}CQ(imV;iA466s7a#`yWFLeuC3JK*3n7>Z5Hzw!BYOJKV;r zZzIDha5Y_3_>5934A68wVGlP#E6-25fB<4B`_payx#F z$=mhw#p05{wJUhr9GH?ULNVP!-Y7=Ge|-tu#A}ygFl2@T!CI3-9|;M56MYnQh}g_t zlos+%b{(Gh@-%C>*t{soI#`ue%H6Ag?BdB>xXKG^HR{l%PAHy>$(Y$cB)&rq0dNn9`+1EE+DpWZ2De%s5<)TW{@T=z|f%^!24> z4?p~rzu5#lEl@XOfz}(GCX;Xkd^r5?&j}7YtZuYv7qz%A#MC~@hAuBJ3mXagyoo!L zP}NS;?22-A;OsGD=-GlHtqia5S+v|g5)LXY3u0_}?VX=3@Yr`>Zl6hbW_3zImiex6wU;h#eM9ckK!}og;w%Lcny@nhl1LqdQAl{3M`s8N|1-h zY#xQyP+fRy-|yY=sG|C$y_>yDPC)$uF(W&$dKgK`SJG@= zKX)5g$raL|{|~jAq0ZTqNTzPZ8=phGZK&KrKXf~h8POmDZ^}C#)jH9?VN%qvzeYg% z6m4AcH?xMBKqV*kC*NvRg5yVMe&TLjv7|Rq%YE+M#UlzDgurlgfCy4}8yLbxJ_|pc zJlEcPraC&z%Xx%}AtY#7*Cu5~ZqPM^g1md8=hP6;loio8?buPHQBmt93L2jv`~mZtcH#-nmP{a(K&jJp9jd zgD$gT<_pOkP~GwmEMyeXbkHj7L)`5YaG{}Rm&=ZqfJ_WbO*Pr(rTI7;Uiz+*$?`*R;DYkp6*AICMcKyZFBi+zk}5Db>F86d_Z25&&F@55>;>9U?Z(ZdAzv?!Y2L6 zZ@|f|MlbFet~d>kj{Y11X2Qb*;A;gFB=A|G42O@o_K@LOR*X!4+Zqx+upnZ$^*RP_ ziMga0++6RyTtBGxuW+wkhQg;*Y;v-D%9B79(Rb{5WQZlNT z0?i;lsI^g)Bwm9Vx8jCr8Jc}ed7r#(NqX?eCqlK49T-V2ATTV1!JBDlYS2a+Lrv88 zn&3NQjxp*vhUsqhr!$iIQhMrrr(h##o}GO5bRH0LL?c@E_wG69A)(^@>lb82LXHcq zrQ9lCe5*q5bTGF);#=4mDlc1+pOa$;Dxw=E%UXDQmHHz0w#)t%u;VGToZKo(Ndfwi zRP4hugK@oG@|O#+9yru~2&W7bpBxma;zXP{oyH#`#!sJnC>ky|Fq6A16F2S z4dL)YNnzGJdLHjp6vWM{;;tCMLXdM+5HT^eQExcb`jGw4oKEe1i|N5_% z8xb;bEgjdm;~w8t8?@nec#}!TVt4$}o2SRLMgO6VQ0`-1{BM#mK8Lk_!ri$JhAWXl zD!SV=SXp%y6dL)$kTzvY78BCgg2K`O`CjRaP1rS!f!=UuvVK=eqL7&GmG-~lP3oG1 z^D#yCro6r-)W7BSE*EG1M7quk*Vt|v(F%W4_sfWDp8vIAnRM2*hv@o_R|?u6w-bs= z$M@Etz36)-rn2|(KA&mi*% zKL<(g1Hwv3!nN10KJE_PlZ<+`bl7F6!OhKsynGI%Cu&h++yAjkKw4!ix7B)Jny`F& z{u}jdzL1rO*VSbOE=F4rk&BaZaB zJUmF>h6slfky7@_OJxP(@^EM8rJ7fxvT>XqZ`l7y1NlsJ5C4>S=ma?H(NC=>;U>k! z#8M^*g+ohB4=?GukwIDUWeT$XnU;Nay*Ov|Pnbo`3Sq@QDP}m}bi~ROv1|5|UeGj? zw8W{k%{@3FFAekMx5YUtQ`-8S`sKDwHvXCIdgX-sa=}0S+8_U{k8x6t z{-Y;;yZBg6fBi(B48kWS+^t3b-joIJtlG(-O_WqBu}wuQ$580^^XbMw9vlC*Wd9SF zek>%Wcue_!+rwfu7xm!vK8svT?cjtz?lL=z5Sp|=qkT8{TP&9WSj5&|;{|bm)3W@w z8~CVZpQ*8V?`N@ZzV}9#Uia9~&E*${?R5>~NNe6Bx#GlW<8nW1!TbPY=1X-2Z*x5~ zW3!7cTy&|vzd^*IMfWR`8iRN>VpRjnbY)ko`VhFWWQ()>QD6KV0tg#7CCI6bem>{o z!;p`H6)B%D7g>g?si_Gxx`X8pn;U7Emte&upW>LEF0vujemBlByu`-J+U1faj(;6P zL`Ng{Cg|A@HzzzWx5UIMMRW!@bq07DXz`@4m_xVA0Sj%rs{^{2%~E`WBk|$O`x{=v z=8nT_P5bHT|B5mNZ+*Ys>o-*Nu&#lQw3&uWZNjFfW%V^L7jkv*d~)Y+fZ?b1n_qh` z3u(Aii`CPq!1e@2-oRHsxU2<_i)HxlK0H9~Z7LE68Wr~z^`LYGJ$Hj{YLkzYLbiSk z`jJ1aai&5+B&O;st2KW7%i??rl&#CGXlQrC#B8-2ns(WBe`hr?-M3$3k>g;U!;SDQ zCYWK)v+kytn9=*RG@ZgBXHoLc4{g@A?G`%wEiQjLmKzVn6|DOWMBS!TyD(op1fx zHHZ1o2bKOMcXohl>#>RZKeP3XJp=-I_txB2T&>L5C4=c8jG#eTq`s zZKK0PEUbF3M!kwr+Z++GVO&Z=|Cj7seg9yH<}kqM21ZkdW_RHP(@N9El5h+*wYvUM z{k;R_bOEyCVpxdcLR~OqDX+#%d~uqnu`2T?E=%g_>EXGKGoD+IlwDH~-pb-wT^J#Z z6rQSe9V7C1!1rHj=Jb2tdK?fCFc$uCM@Pp*S7x#9`a~`6hs1G45vjQeL({Or_%0*( zdMR?!IIYNYs8L)VY0O`J5WR}PPjOs~ojq9i4Q<+HLh=SpXK^fRndBqZ>RoUo8N56z zn6+yg`>FWh!XZW4p-j-vkW>ngR!WL})xG#?b)vRx*^8L5-|gtrv@pozG5HiP4`V~- zIk6auXs?0NdoOMC#ZZ3s1a!&7Cv-d?1i_%T;O(XaO1{83Axv>_+@(}vEN&E zt%(Qo+2TXGMS<~Jw;K#}@#_bkljKN-m8Q&l7F;4I>SD*U-1MX?(W(sA%qqE7Rx#jf zX1$lQf1}N3IMmIeb}blRhwJeE@Fmb^O%sUch->PH4}~qFv?`4R6GxLKuc0A3Vrp~= zkP{?6kmNS=&@7D5t|g3y&JEeHFMA`LTBPSZ{R0!RfCz{PETOH2VoSe|dF-NpY>N5! z;0}^Br)+D*r|SU%c=nj%EEzlh(54(lulKbZ=5e4qy8;ICK-MwMd~XJd8v6pI)xCW+ z@YD0RrgvIm;2TE!Cq18Z^+@65wzmc(C)0fAQeOcjVnGYvV}grR8V|G#1#TCi3WI<= zs^RrmM@GI*Ng=mazuPq8V3DSb&SdR!xVwri&PYp(T3D?nHdqP<3(B0@-!f+8zc#&T z7W8y$s7%JC(6ng#AQ-k4dddgBb1ErnM^66NvmMmkhO5{3{Y%NG0lw<$g8wd9mv)3$ zxHtJ@q3Oip@?LA7y#+ACBflf>R}(_Xe-^Hs_6BawHhKJHC1S$O;VHU$WNkOC5>+g> z`eJ4#SdINsOyG*$%$AYOWhU741>^$OhpDTnprCUZOu-(%bsf!fXD1e{&6970oDbaY zANS50pHcp(4df~4Ps669(C}7>W14>(0T_ckpV~(fhn*eOTAFkdJF@tVtMBV5`0g=g z!FOtE(GyzCOId(_x34#KxI-r#%Vr~4syab)BE7x}*MKw7|YhV}KB`oZNK$}vOYc@8WSva^u zOOmV;)sTTR!(Z@IfivNXhfgiH6I`Z|#BUsz_rA0%NV<>LxS1)|An&1W%_J-ir?~5G zq$(6ob$4rT)Q>d!^yR&_cwDZczv;6!ZsLb_v8gOK6w*`WXx1mqta@NJqgb1U_Qjt# z5n4U#4ssSgm9#!w7rs6{Y+ZQUq-bdN;FPc>enJ?gk>iJJWJ5YixlPpUqp?kn&4Yu+ zQ{S4jI$NjJu4Aw8f$vs2sxa(zLnAhwezrIK#T0Ciaxmncmpk6c4_GF=_0|Di`NKNe-=Y4}!d$9aGmkn;N%V zN}B?(;R+k?wxzZIt*tdJYP@SMzdSETwq zVEY*8gxP1<{*Jt!{9(Z|UXL-UBUdLp2QZfR*3{SoS3dezXJOpy_U6-g}T2cvkI|fuFlAE%@uxBb$C{&CSi#Iw@zgtOLdu@rQ>N znEUe6udcHkV(Jb~*^D02z;`k9$mP;ie>15G*$Yn(yvo1aX!j;>>z9v?uh$Q1oaMjv z(95f8C#7Ak_@<=fMMaQ);R|*x(0M>itkKkEO6J0PMqXqqPOZfiZP(E<`)K~k-K!c8 z+jmwI`pU~eRU!tUW&{-X0YzhfZP<+s7wGrnIeUEY=1W%o>({T(G}hRO$jx==mAW-9 z=Bl1j?g=FSvo)N!ZDcnylSQ1|A%E*@9tB4)z?*Dcag`v{l@t@sy$o2?(iJ8xCzW3A zveN`W*ehUGfBW&nhtvK}EsPqmr?=`${lR&)#XoA7W2*^4l+pg*|8)qKLe2Nitzu~`|7u-zo6|!6p#>55hRtClSa=V7pXdE2-gke1z4rRVi8(X(+%sp+*w~okh(QcJ7y=(? ztVh?~7NA093L;K^!%_{z2b#X;QIzCToF&BD-jo0z%_b};v!Zw( z9;bB}vX*Aoi*UD^N?JJY>=n}TI8ftKLQqLPEpc0+rzgAI4|IQGcrwd(b3NpIy@&1b zH%KRkeH$7@d5~uiAy?9H*xTfvLAP=^CPgFQyj-tY18|2X^ePes1!Z)>ZSmRSQQEEO zP|0n{!tG7Up2t}|c1qDH@$rl%3`(Y+uk1C_#`}UWK0djDP7a>CrjDTdv|D5P`Ex1f z+qZFL(r|WT6O(A-c|X4_TpQpKlLh;=C4zoJYBx^`@4`iD6{kDXM-@R+@E+DG_5q5A zRWxDT^~wxQ)mlsoxN@S3xVVuy3p<7#_}a%kVU3)-^s3rbM?b;t*BwscA30`P4jb8- zlYm|h*O?tvxbypt%9?M_bF$Gy-t{*sXx3QC=p6sV56|&5Z38}rv(RN(L=WFXM@_l`mYItI6{94_FIX7)J?#;zZLh=%GYzma=oR7=H zFIDcaNN|vO_*Q68?ZVHEgalC|^8&?$L^|1>S=IO==uwGfY|b7dehB`51x8BI{s;V3 z1^xOIS>vi%q~R%2t9ETFE?ebp7e#qH($m|FNV#1%92`7-o^yx1 zZ>~waoATovk7tP%&I5jH*E=~k+E9hLC>3c4@RBoaaz0lErT}0+X#jd3OJ!>ni^u7w zyWQj9d#p&}{3pQ#1)}XRDzK-r)&=0IsF8?cDnj3q}2uJw)W66iW2- z*yS=m=2Na&O_$%iQSdsP>H=q+?RM{zTF%xvp5^DJRqJ1!lDIYuT77^ajKpQnex*v7 zgRdXNugfRT%pV(PQcn78QsFG4r8ZBI0&NFarwRE|D4xkK<%Ybo0@s z>KdPl>Jy#gMf`}}8Bi-WkG=7y7F{Ew7hYn5oPDhS~jUPBQ;lr86s+b~=f8*&`!MG|2Z)&<}DJTKt zlKnd}QZqUT9!;tKn1*vOFkM<^4(DzNtkj+Oo`S>=z3i7{WX-xCY5zRMCAuuVEUGd; z*#;9K=Adeo^Ol82eaG-iSfJ&5?{hyg`LOV?FeB~NI*XFIgI2gapNE?p@1!S|zv%0m zi}F4vVqkB`BG=s94^;Qu7Y3ahwzLBs)ssyWG++WhfqMAh?9Ix_b8$#1$Gpk0&dSfO z?B2RW7I%G-hKQ(FaOq@w5`lT;eW%-CI*!ntURW_{QbI}?L!aT;+lN&x!|mHPL);eD;vAl0^t z44jQFdo&w&WaO+6!|&PFgeODM_@LUVKJ9&+L9gdOCuJ`Rn5Eq3C@4(?JOLS_K}VTT zchy?0CVF!7xndI!yF-{%`{NXbBX=9Gqg3ZKck7(V!`dMa<2B9O^$5=0UstTrnKe0EhMbo)ao{2TSvm;bn*;cc9^X}V6Ba~Y zijFQ(AQwz-t2-SVJ>HhiKUTmkE18Uu1CQ6I?78Ao2fJsuau(`W+^;&jx+FCP_J#&| zOolE1IJO3!x+jJaCMIUq>|R4fCb|mZaFwg6?C=an9OL>rARxdTK#v~V2oLeY{XmkVJ_=5oc_Q3{z1y1|RLlC6Si>~|K8veWI@guj zwDrZ0W#<7ww8pN7Q&Uq)QKJ7sBH>#)m{&qW(d0kNyOVT^|F=^;ML{GocdJ|!GfY9g zi8GkHd5a@!1FuSBCoD#Kr8p>lAoByo)})X_DfCJ|w@+a8Lsxd%Mefk#{~Y}T?ekGesnMVyuyTP4^zv}RkNeg!`OX9>qxF1w zd5c1BNYnUVsN`$%v91VaFA%HKyt^Qq^3r)1$2OcmVDz?ORP!l2G} zR&JyJ7$nZKDZPj1u%)hScF;7ZJB;KqrKtS~;{cocb7PwvR#fJyUds(J0xd{5ox@F> z93SsuL3ogg_Y_?tF9~O?A>*K@XR^@e?O3Wtm787m#|yX0_(L09OrQ{~V^arfu)3N`{!nD z?gg$cEPG=Gbf!Eg{#$Z^@OV;uJolTZW!-x9>hF}e80dpz=IZ7A7j7*dB(rNg_S|Kv z$(HW5kS~7Y`aTmq?G9)FNQAc9(@XdVnyOmjqd4q28pH);FhbHsq{)aZVCI&$MqJ!6 zf3|#~dw+RZEHG->%B<+Lx5Hy$G^pkWxUln&&0UG5mZ)cUM7Gb(OTe|q6M3ti>7r14 z63qMFskLu*Gpd06EIJwhip;Bql&1GllwOz7Y1{LaX7JAJsT<(j_RnxxpF61{MI(ME zU`wuz`^9?Fn$F)$o{t2@59&MiojDGvoL+`>uQ{&139c0$6APfwQ3v{od~sb+KH=VL`GGV^}_hdC6VjBj@m9-YZ`X+g|cq#3fs+S+0$7k|8) zg7Vd5+mDy=q8pJM4F}F2t#|R~L~o$j-+R(73%ZEC9;RHRKN?IghQfCXP{)mPa&3r- zU)E9ua|8M_QV>P6u8O8;Tt|Z`Mv%n*w&qANDIvAV*3@u0oO1E2(QzF!Q;al#vYs+? z->HpZaQK<5f`T_lS6`*@^Yc>`&v=VxR>womxqM8z8^(?h2BI)jQBffjeuK(=Ck?#i z#7^XQUqTE_fiB%dz>gUHXGb-5w(V*?c7S$2h@`w7?P)b>TEwdt^!WWK@Dye{aIB0~ z0Cg9s)w)?DO?u0Hw+6Ble~}+zR4(f)0E|@oF<*-ekw9&2YH7J0?EmG<5u9DXI#~Ct zBm2{VEt@01XWpH;%2=YdJDJDLYZZNby9{w0{B!S3+A0aZ5S)u?3L8 z!*~o|#>uyL$^E6BjBz9;;7bcR0TIzv5mfsb9Ka_V|ZerGfvhe)RYoa6inKl{j*Nhva0aulM(x5f1vdpef)S z_1@`?b(?n;qT-=I=Qi*}Ehn?f#gU^`KNV9viHe6|>IT(r@K9{hbwor&q$x7Rm4qPY zewH=ZJxWQNQF?T@l|xTmb2G*Gu9b^)p+NBo2A}VfTiaV`z!14$Si4&JXsD@gxTBUE z)m6*&+b(}0@N3o<>R!0zqi{Ss2m&pLO-^EG5#+g;e-GzkR41U5E6E!-x5)$Wx&2E< zf)^nv5fL9a0k#1w$nAHS;za>C%24EywBCE^49S6!xZb_}n+iPuej!02_yz`M?URK5 z>3~s1MY+k3cHEh+;JRlbyGtC4JXZ=}PV@Uadk*z`%ZuRksI{D?^7+74oxO)gQ^?uK z!5zwc-`kHKCj<7Y{0?eR%vS~gkK;aFqlND6 z@XZ}Z(L$#L#P()!e}CVPV)0j#6_wnA5>t$qGvFpwGXr4&Ad`}kdO140m0MVqOX>y0 zM60;9mF2&x68C|1X6xq6qyjN_Ae9{eKe^l6j3saO_xCHHqN3i~e54J1mnf)@TR>q| zqyl4RjO)84z*X{`htiL49v=&^!Qr~H5)y(OIAs~wN{{BDFsMTQkG{Bf?M=j!cie(- zTK+xLXaQFSjDuCy#_VP3ZioqaIKZEKp+R;bYuS;MlTPJ}3b#wS*jq(r(;mBQX&X(1 z%89AEOmTa?wNfVqz?z-fm7P!A4c8*fv*3Fr&FJwTU?|6cGjb9XzuU&i8za#^=1}Hh z58g6o8AXhbi@$Pw$y}@g>)P`!V&f^iBe{LvjqO!D0_)Ld#mdFQ>4o=m`xu8A6s69|B6q8(9DL)s_phZE1BI^tr4A%o8WABx@#guU6#V!rF&*Wdl5U2=QdIMmo!SqJLw|_3 z-)rIk^1CZyv>R?_0f{0HNEFM$l>B|rL^Qg-1_lNZQow?}Cm(zdckm3%NG~#Lzc8zEQwMGkU#v5v;8|D( za35Ylq{Ky(=aIhT1#wfgZ8bBF9xrMXon`<5RTb}Nl2^J@Z0o51HFsW795W&;Odv;* zHu*bs53+#>Eu9ox0N2)l@skCIRJA;Qh)`JV-}fAK*xxCEIavtX{s$uBE3=sffD1=b*Fon73JuQ1J2RDem z0~;kf-Zv9Kvk)DOBhoe;3b)PvMFkN6D|T>j@C*d~G{lMHsC!;tku`wUS8EhGxdKaW z-QPG7^Zfjd*-8H|EjwN3H93lbb@T5Q-z#`fUWe9xJ|T~a0AX74wcgW%STLlZfp)e0 zj(;-4iKd%8B~`Cvzs&1PW=Sl;@fw< zrV&y*$y0I5dpEnV|LDZhEC4RkK!|2x+c4qFmoLYcCElKsHiC<|fh!{cz{R#(3?6!k zh#;zQ!uS1lu2HMz0gczVPezKB%|P5|v0mnCF?sWmTW=YH07@c={gq6|s}kv)w<<~4 z{HZJ2de#}m?&9AUwGuEA&JRYH97 zwV`-JIs6fs=by3-M-a0NKeheQw~`;7>b}?=rddNZ2lbuVs|E{wI4FL@i0c0SJ=y!h zl?)jEk&#L0xHcOOwRc|To1MA(wP~7E?!=XgJ3@CWVaRQD8Mx4J9Wlj7iR+&J<6|y& zjr%;*?-+O);8{K^Keq}L?^vPP4P0!#>2qe!P2sDWXaoUkjH&+w%iB-NK3&hvC-p; z?2j9|cItOH3o=~M`d?UDPbXh_hSbbWhpX>q*+fW2p8tR+69h=i{~?rsw##PbX}r#e z@Sq&R8N&nj%hVR$DN{(d|F^qDj+Sy(9v)Y5LR&F$;<=4-f6Cy2=4u|#8+(Pz72G7Q z1wQb(ytByrY2YB-4}kEQ!7c|X^B;Iraq`6dzJTTbI88ODPHGxmouG5&nm+6&PjaN9 zvT$($gaIK*dkam*MIqI19mTW%ZGH^A4{nwcV}&cod+`Kw>*o{M`LKH`0Mv676tBIR zbJs)&>eKrjTd~>y9JfdXf8^9KIP$&t^$QSY)a0j(j$(J$`1oP{M@&En^W_!p!s>+K zl&&)$Yp7O56-%)0JyeKVHM-2){ngaKu@J<;)r|W^a`ZYcpX$Ft$ix5DUMjW33+W(X z!)1=hMid4pI{E-fvcg^2ze1(5FD%qoDuPENqXWhKwSH%q#^ zLKyo$k&OA|0YI9HRC_IMS%$*w)H5(YMbIlnpcd)L3p{7;%MgEO`%mFfy(Aq4huLNB#D$gwo-QnjcAmThw{bO%qVt* zxw!cMRjV};?Xu$iyUlk!fzZeQH%Ez>+s%|1)cXg%W{#zP~HjKM@cS?Od*7ME4(gk4iKZC&>I$`tOzUb2oI8mVUidGk z)Nny^w5RFEc=-aAg-d?)_h{ieV+5(yWaL}E`%)Jv2{GsJ&pbpEIHBOamsKmqvlJW1 zPT|A?3o3~Ir#F{}Qq?^cI>{_oZayK@+T?g{bbmO5FjFjCp34V%t%LaH2QC~=vKCWR z-`g@GlF67Y{Wx(|ZrR3t*F>LG;M`b4POb%wmh?ck9CGH=C}gJc=XR`XD#m#8x5qYi zoVJDzx$hcOSxM|%hh(9u(=0{5Q^Q!2f_MU|DhXSp$U9Eb?T^WE7ibg3hA_O&VQ)Jr z-0Ho&^Pa#>Po0{OV7gq*?<`i%V6%RZCm>~~!bD!OP+>h8J^AF)8v6m* zbOsSN7`Qwi5LHx1R!Di6tzlIX(@}^Pqq>qSA(H1bo{?BJ1WI=JKqq=_n$1^ zuOKq8IFf7ExrJcsiO4SDtmu^6Mq=8xrl7h{Q8%mgde*2C45FObMJP}bU40@Gdmzr7 zk;{;g2c4{_#Dn-$wH@?#9>*Z1Baxt{FVv;XGxdr1@;@OyK5{OFi@c9*QJPRxuD2q3 zg#;;mVfa##vWpDyGveJ-g)N5_v&p4khnIU1QmdWlW*V25R&fK(G$~(GW(2A~3ltUC z)L}z>#%*4nCB!j$nm~ererH=lN(&sH`I_VTY*G=&oE-3T%s^9-BQG4O9BY#1@Es$F zo`d%!Iw~e`BC3LxMG#ZM^D<0{l(k&s=vOx5feBI6lY5%Hi4k0*bzMo?y1$A|KZE>5 zn1T+;3f}NP>w-A1z1GR1Tg;Y3pxTdRU|%HaAxaZ($Lta{$YD_ANcmQ&BUJ1c#kuOQ zqzOO{-Kt?idARP&pwpN%!Z4w7%1@FG@>BjbntxJHi-U^y+Pjos6LCk`sb1^=ppsINc|RTjYgF+?CkN*hiHeKyyEhY*C%*k{QWdhAYy zY@B|IRP2lkDWnnlsK^1S#!P{FnV;0enSU6VsU#r8Vi>L4DiT#3xZ#|I!YcBU7`M`a z8vy%IA5Hx=JrRa2%7`gMg|(}B-Vmhg|5HOH*xc!D=lMg3p5sP!os!O3O+|9&qXGF+ zYxXN~*d}aX-2%C^0FcYBJ*?}$_AU{7w?F=6VkF&=%S9oS7_-g4GJ`PeC*3h)3zDum||Y1 zjn=2^3MrHZ?{2P4eNv+6@(#z}@b62>Vm@Oy$(fh;l22mb_?27vsQq_pVatvw`IUNU5FUQ{P@N#q0#*#Uw=z zby_r@lTI`k4sdL1yzl0fDLOT%kiL%qghC2kNa7Ma_dB~3C_iv#E9|J71%zvy`QUf{ zNtp0|XYgu~!-ZY=YiO!uc7{r-= z)ArCQ|b{4|-Ljsl9oXHgK6ea9ON=)=^_2#x9(Xu*#qkC)5m^O z6c%FNv|Knl3pzRDqavrquaWAT{QI|i1J_onviL#F%IN#pr?p{&r=L-PYYkJGsOY>< zd6#$DD}RKlxd{{IsQ8@VIw*k(QERMwEK&u#{BiPi!AmuGv!m7XFpLzo5Vv40k@e9T;hA?QdL zYVJ@!?TLsz`MP?!6?WMjHW9<=DvvmNlnPNB2QJvLOq)n|CZ~|20cDSr3_QySR_Z#3 zSj+9Q;HVPMh0C+khb2iSXaQ}*dit z5Hz>sa$-lf&hmCZVmxK_)~U{>d3NIjqW2DXI)|eL4m;N;lu@mH_$5;Gk{NH$^D?=v zSN&{e?fZ&s_l1oG|BTT>s`mFhAO$!(x&0RGQ)cXFtZ#vK<1lqRJu2tMDgU!A)WS|M zo!e%?-f`B-b_TCAN|GD@KvoDYGU_IlmNt$$=}~NGnkJVD(NrhX2p%=ukHbCa;QnRP zxbODS*}G4r^Eb__%0yP?8E~8ey>I@3k98%X&RAgj?(7I6FEiEEZcN?GVvg1X;gj(JLf7{@ z;PSTuTNsMqKq`QbFp*fnxAq!g3WQ-Yn_c8Pt%|sUsK6Q*&dEMyD7}3cR!Bp}zG=W! zFSPjgOgjyTxC{_+<=l+KE8baTseeYE7UOi^DUq=S-P%~NBamSt<75tbWaq~kFAMaQ z4!s=#P&L#b@i22SdcdJrK^^3bST2@d_Qu zBUi5PtxO?~5AHrqK$AiO`SpzS;@SD%6vMVl(8kT3f~=809PyISBei^^M0?~wZb5UN z9`5wJ(k0<}RO<(9{^Q85juJZ2DvWoItbc=FMDQR#1Wg}&Ih^mn3Pf-({b&oJR>(nvBy?`nQD(9&?cq?c{b?aQ)q&Jg)qX1YkBSp(3Tif@8vz^QN1X zL#LuZG0d8)9stD^IkIB04J}>XEtW6FO3RLfKIW=#xcXQgLDZlqz=dl0HktR#b77?n zn|tH2)KhHrsMsRCz))*9C-FZ71E{afqGd9EpZKRqX`DHGX&*&#)*yjJj}y?F|^9I%`e*vAIZM7R=3s*@Uyjb6=tL+I%p2(rY=LNkF9XSe5JZ3*1wv zTGt-56o5UzhLKdym4r&A$e%ESh&%jprd)+CxU~+|ntSzeq?L4ob*p0UG_clCG%?4L z=^xJOorJhWU7;g?%bd=Dowu8&nUi;0xVdqHFER2{m+rd=!=7c5;6wBVK&150L3r)r z@tOBFoP4pH%DnHJbNAH0p`cY0w@Tit%<13Xpi0V>gb!cdLGaPXVve~tlp%#Q8kKcA z&0c^c@)>{Ahxw4<`=DHysxGd%K5fC=<55sf{%EtLW)p_o@{Qxy7#0MYTxhaO-RA!q zzIdYNpm*KVhHQ`tAMaJ36Wh4y6OP_GiM#kcbbWFmQ}@?~Vt~}53V2ows!rR^#a_fC zrdp9y5WGk$hR0xfCJPqg#Kog>@|*O;Hd=j@tZoJo-b9aLM;}Gh@R8z-+{6nTx)4KR z1@JO_oD#9#C#LXx7Z(Q`f=aMyr2f70w4N;hiA__;oWw_(BXxwz6}^fWLJ10s`)TBBUav5gx8Ct^OnFkFEMLC@^gnz8L_RS>Jff0rhdCqQ^C%^yTt&1oR zo0zl)#8)8`>hUwUB5pz16`klf*|Tmtk92JUI&#f4pxHsXZ~C*7jQAXrNBAfKUhX5B zHRxfO;X>99E(k+I3}FtUZNo-~*1u?AhnB22XHubx5s^Uih}(=6ICNlKze@xf9U5TT z>Uoy(FumaxyiKVh+SZItTMgIzU+~C)e7LoPr~`n4mvfLpP&!-~8iqoL)y5&_F9Kg& zF*W?W{mU^k&^q+GO|i)LgE|2S_?Aj%T~>z~6%ovufs=bbfh`Ll1go5Txqy|uA;Kog zUZ0vxsLWnFw`s#(iv^+o_UiettSWqwq++9tD2kS!=4_(S3R$w)eLtE)^ZX4+L&+ zX9bcgit3-itv2J~?On0-K;8JuI{U+wBc%Iw5pI}kG%Rrn+1kI3%3YZ!Bqx^&|FgfP z5Y~yDA%UDMk19S;;KB15^sv(48n7h|#t5*TSwZYwUgzi~;T3bNK3(; zjVsuwbTJSMY^GdYEy}^3h_Li9XD>egQ3XsTo#M_DE!reNm0Kv}(x`yu34S`$Q1RYe zU0%C1KmyrVm9^LqC^3-j6p4Rv5_}EOzgvCG4lYge-X5mQJ(DEC3quuYMESYOfx%Zr z2zg121ZmmKD#3;bryetFT2${f&*ty*PA}|LAnA<*{k7>hGc89>?z&upm_UxEbQKjM zY%j4)<-Y70alske9NiM`fdIG<8X_MbUSvOz(`ey5YR~?Q6swpEczm#MAOXR~*-Ful zZGi}XwQqe z@jy>vpc!$P?a4NDA06=^<6z}2eeO|YwwtO%C zgxAfU?jhf!5)4N+Mjc}3W)lH^a#usL88PI*2%*1kY(KyGBVQoO*g!JkQmQOuYVMSC z-w_Bq#n)(Uu79~sS0JbZDdf3Z7;=3u`6pqG9%hM^oN`ad%HN`m%c&F}?kf=y|Ei+8o(?H zP?h^9YsiI6n%4TuM%+g`gmq-2L7Kv_63p{NeL*)32?9$5WB(r3(uXweD-j*Jpp#5p zHheyONrTa|BInsTO<+bVUVddUV-}C0&SH%=s#NI``8r(#HM$1YjnwcIKbJ` zrnzR0d0k{D@wt-iks-6ht0bIW%@-R7hfNGwp#ZUh4?}q2)h-{19TmO-Ez|ushFjA_ds6hy2{6(LM&SUf{>OPlojmmef!o>qrpfIv}{QN zRYEeiKq)&OgL{1O@30agyZUe0<=SLm`skxcgWo%*`^4)LAD_%1ZjCthNql!NZXgVd z&25mrNjnVn^EqQi9H&n_!;+{_eqc%^G~`3hETXYVm?;l@-&tVEQALIlSKV-t5~YAy zE~W!IwPYND%7wLRSR`1j9BV)Os?{0Itt$C8f@!T9Y1xS9c7k!O`nUPmMiZQx>2M3^WTGqjqeM8D zv*l}}vgKd(%~WcjQo~Lh%dQJ2ZY`X&O4XoCw`>b!df944&8n~ij^Cfuw)evK%We0+4ZRFBM% zQ+2~vh+SdFc;;tFe{wrw=b?*VZI<0slA;khr2j_H!a#97!oLd%B#v)JJf2!>=AWKi z=OWF^B!6D0J?EemWxy%mB=*#QZF!!s4q%kOAAk&h0*>R0k*bx@2#uG=B=))npBBC zOBa``l?g}B)orKUd6-T?HDlaltp*38f0X@1XRRcyIUgfVQ@$D3LPf|MInIDgpu`c` zA_yQ|iW3swE8fR}p;m$%&GNW%i5{Uy3sOmeGar)&W9|$Rp4raDCvT7wY8&$sqy>>YIH-qFvP7=H+)( z6^m`Sa&pU7vU6%tD?c&5;p|T3MRw#uc67<`;_9kqs(CJKqU!1G5JPp=?}e&s%|?P) z1Dqb`T<_Srh{iF`W9aPO@@>LxW@!L$^l(wJl~+q9oztU5^}E6B4)6b+qM(-KB>niO z#$DAAo1+SYpJPkQ>8aDxPz|0sfoFLOv)!5#oa|TLv!)l;sG3bgu)a^k1p6e1BpO98 zwpwOBdIx%V`>aR{t*VyGVnv@^6vdwK{i(f8Yh;UvUMko{?ENX&^vp5YQ+Jn`H6@eE zbfoNyW#}uXnvU;y5>NH;DcV=6hf#mOlIVy&z`lOf{-ps2O=jOf<`v~O-)o;TmU%7erqHZule#Sg3p_J1QNvnAl^O2Yl&0XhIZ?E^sX2F+%zKusRP${l@Y?~2|K%RW zNEiAJ&Awe>p=B?MQlBM_}m0nqFj{Zp0jTB$mxW+!7VIX zJeVX%t4B&&ICW%;gewYkNfE$pA`mT$nXs5{KYS^I-C`{J}naswe>wGGwi}F zpOkyr^*q|cD^ql1PPA8{X)TsSb%w;kksozng;ugrqh~qke0g*{)EFj6MKHzRq^ z(qf#Nue`LxHqqmn653S}HuzQrjYgCO)1cGxRX^d(hoXxM$d8{jL6JYH|FA>;&VD8x zQ)?s~+Iq0Rb?}1DAI)jGUiUO!^b>La?9R~ZC65!f;YE>&*4L(i5Bn6okU~9#+MeUb zrd{j{1nI|rYISpAa>Bk;BQbC$-ul<7m?z%&DY-4oL)VdLjOXz8hKI=dBbsExQF&6M z2iMu@-w_QTpQ$1_U-3B0J`pldtT!mkdqJ{W)6C1@R(n!p*Q#(BokFI2TH!P`fEKfd zkdly8#jwmA>Ig|?&I&Jiff#&?hXHycd!iq+ZdhEy8Y_i|-u$8@^zoa2Mvf!OeSg>U zqxWN%mt&tBwKGlk^w_osf5@iE`%(hG`N%7Z5!~ORGjU;Fvw(?R-isak`u2xtKxmr& zOF97&-edGK1!M30zwS6~Z$%U_`8v&XYf&|l(KN8_TRKu+UBS}qUm!E@fKvd|;}Pw! zRbl#~Qr+!g@OT*$?cu)s&4+`RnK4HoJ`!45Z7lQpuKNYuk z!@WPvK2yU0b;UX}t^%`udR@oSqiWMRAm4=>_nSTe7aF9CD&-?Z&!>;m4hB)H+Q*tK6n!(XvsCzYm(k! z2jwl$4uIGww3K7A82hd#b)Z$_i3Z%uUj7?@lBL{vtF#4!5UVzVW+iH=HZ7Y#*_N^> zH1aaD*EEjjDUIpFXIma!Y$7ybFUyYP)O*5{`0-eA$P5pahOc}vzph=S#fmx;HFLe^ zn{l}o9sj4}Sgv`SRI|=c@k95|(|E&YDgA=pHG2+8Qt%B@D!x;#yhCysp6PXw={22j zW_+T?nG?P?Wvpbhj<=z>75e;q-}4`H%%kt2;3yfIlb_5&JV-7YF9)s45^?DQ=WaxK zf5g{5?{(d-DJB@?WKKKVJnqlkLlFRi3ALr=dU^P9&8Qg@x~BK?Q!-j>K8>dC`d>{! z*7mbk0s7J%qGbkuW?oe+Y?;g%PxMG)^9_77$hAPM>m?ZAle6AdrFki1y7Qp@dC(`{ zwM^7qL6Ih0pqs>~TWCyQ7G*Id}P7;s-Hoegb5ax za!FK6+~y*A%2flaIXobWIPxpBqM)yc;oU8KPSl8VbNOjzT}0?tDb8J=@$ULO?w`We zIw+hvmy6Ts(-2tXh`RPsDjiYwhO6QRh|oafSFO@42h zk+WWrq+W107kwrYS0^#yYC->L<8GU!0#iyKTb@P5c+D2WAm+8)JNV__DZ*GSz&DrR zEJGA^-uJWYgF!@r@?jeol6(*8j6lE9IqMUhh$DkGf;0S4<1%=g*8`@QpMi*((hHP} z1`qFi+ww0)yF1XU!hO~W+nLi$KEudJ$@;H(pQywhW%Qw2v4L8K(`zdPG|9%%Wqdi` zy@;1w{i3S;)7uc6a^=%DD+bh%tSulBl*S7Uwey9311HtDU)pMox@mB=B%rOPEe zw<*TYYlaoStlSYd=HqSFw<v^E_gW9ed345>|27hu+&tBEW9+lk{5LsiC?8Z# z2-i$muu8)ddH4-OpSjP{J>S0I%)U@bG;*%Yx^A|Bi58K<7nj65RxmHi6aEgdZU}Q@ zEgUd{w+1Udo$AR|pX5c%Lmj_v5D14`LaZER9-bxQ#0(+Iemu0wbgw0=x2g!+-MKlfAUN zw1(}~_!@Qdv3mBGC^5h1IiM@CKDqc9eD;dDiv{x;rpOG-YMtn&VS-i7rN_a~z@2Kp zYBReoqMCmnZH!-sSEbw-lyJJ>oK{%!U4IO{9o}hT^1~<5S2@jOGn_S~vSDpby5Odn zj=8WlXk^fF&{kZMW4-H;5{e}>M;KhrsQk^^%n~&Abr4PVpYVLAUiEAl|xNo;N4I>T~73~W!M7s3Yun2R3?sH*o;8IY7ag0|Ue6Xn)10>=tQV4orn>S6VQDR4 z9xIG#hIxOyO3p8==BkfkP?@g^tLHY2&NM%Cv*fwf<8V4E@-{rboZY(Jn8@u`uGV${ zh6rWuobQ3Xx9U-Kzm4_r(VFp>QN~lg$Y_ibsjuY+$hr0_Y=ev_7gNO-o7d^vhoUp< zI@^S~yv%NMT7$W_42E~3h<%4DkhuvsiFnVfADG%k&bBQ}$^5kV3x-hgZ|X2*^u8gf z<;q*W#}FGo0twP)sEL)ItqeRZjICt(~JhMH>Q8p6_1L7NZr!h@n779i6;7+qo` zBTu0i$Q8KAeie95R4z?FFSR3N^JSYo! z(TwzJ?Je76ZA=P^iVo^A^cPRLtItZ9X!m#5*_sBmaYxS63C=vmlmbF)==-t9Po;eG z;9q#jBOl^WrLXqBq~$qFzNB>s^?N_GIW5B$lL_fODHJSFTD9a%;)(7t911t;8d3;N z6>?ra%&-S<(_4u9Lp)S&^peJ3wTrz^vGm8H;15adl=22MGrFhp)fVDduOgr0NQsc= z`$at*LwZiN9+?pF=9M2ml25plFxjA$afU7>35B|L^Fsmm50fXqLsM(xaT7uemMCb3 z!iagioR+tLb=W8txPMnoV5#Yl^6EbU8l8Yz%@@7cWxS_p%iMgXP5U5RS$WK1opST} z$0%R%r|~Z_aGpZOagNQJDLK#S-_<~>gkPa3{&4uVm1R*u1CJbe9G9yJQ&_L_ zdf|3@yx+cFL&lBB43wMHkHxCER_`f??`?CWGy8?gSr*f0?RAzXi+?n;)EWDM6CCh8 zhXY;Pf?BbWNn8uUl0qxb8}&-RG$F&6R^OHpeoJxO$CebWzD_Z0`*OG|-6YU)UF_vL zeh%xiwQ{%9YjLOZ)`Y&?!89^Yr?Ewc^14~AHD%5%69XPy-Ei%nfwd$URt$7Y*sqnQ z^Q~`w;wvve(Ty)SZksyG$D@)qdJ2*$Ft%Q16h>txJLE<;aQ9@))%KAzbJm4gCiInG zE*w-a9=t27R-=S4eCZv27#lVz3aSjXbYaT+H1shpuJCvpHA!+C8Ju$ zchqi<@2Ctb-cpLAKHl~(EBn0^I3#3CNWglQZC5tZs3>)rqF;a_|MgS+W_u4L$v|9^ z*2BU!vHhWxmW=hI{gU{!WlGsus9$DbK4y|Z3Z`VqNhpUufnv{-9AeauBpf9FVrQ}& z30oT}$5uoYu{VAq3lrhiLB6#hA2GG=7q$MB$AjRYJb(2hU2xR5xDGGc$4frYOL}Ni zvb>wL$Cx@ibZbd+5GzICaC=1z|F4bkO4Z=t%PnfI&Z8b~)WR8TILkPb%?hQMJvec< zGB!LLU-HKk`n$Zoho+BT&4`%Nr0|NAI=prNv^x7Rxb_4cVhV4~eqcKW8KJJ^I5u|p zOYDFM4eyV%Iz&e$dC1Ys6gV+6bR>&!S!tuM?(d}is@%=PKWDiPTM^h|0*O? z8?M(~A9A5^OxAAL*r%u-o~->MdG=7`M7#A`P&%NamyFRxf>t%z%OaO*4bF9S;n*+d z!}=-a*ibh7!RnS)NmJq@7D|2fZRP`ZDnWQYY7Fly zk;kOIa{3S&3t6rFDK%Ybz`*59%0bSAL}@(DPu!K#?s`Kqy)<0WRnaY&G|m>GVA%O2 zg-GzGy-Y?y>#K94wQB768nn7D&CAkSl4rv?K))qe5mSlroOq1=u@~cft2nN-lKal+ z{8HQ#A>Z1P*1p8*fe@9&AMnr*PT?G!%ZC&}NHJuRi7ReKa{)OnKaHZPe}svDBKZP^ zjA0#p&p+P9z)FWcsETUgMS6roC>oTRlYu0F)raD!?ai8Lf^Ee1>@3`n`S!9W8k?Wj zH}cK7b8=7dPVz*#A44;8p*e{b-sqcu>H&3$oRmpzScunD4N}7D*sXRC7=MQ{PpNKU z_=yT*1ZkjcnzK;+drkE%@%>ZnU@9^7b%h7hk~HAya)y$7o*w&=fUX>p`?=5hLz9n( zG5NDydBQ9z_7y#z5bN?}{#tp7l%=U=g%+Hg=+Rghx@nAjrLUnc*Si3;FdtJ&J*@Y_ zU%q`uqsW*@&#reDmpm;kHo=xNqTWmE4xe|o-2aC<6p@-He6TAb(j8GNP#)f79{oC? zC+_3AexHH41z(%Yr@o1R%5G}^A6Tz6q|%Li%%~ejDIn%};zbbSV&Ql1#c?LhMRr>yB>- z`8G}6PWSPAe11X{MbTb|&wQqsA&k|1ST0#Hy`A||;Aq&zcsWBxESHqm?SjSL_lK^) zu9K|bX@$DizyiI6WIf3ezB+;iF0|voqHq25#|WxiU22s~uYSWEvVF7FgmIBUadD-X zv%1~FhVrRfMEPat98d3Wp`{$TB5VPq6!f4lCJ-^e&eAnQdy~AqhE6d|QGa+HS z?V`hbm~H)vP1J7zL$SC#T*{VgrnEM%txt6sw#Xj&I58vm_ue1x#jab-SIBz3ZBZOv`rE<1D1G2rO}*6Ax}cr zyZOKO81JQYhc57O+ufvQ`Ze>|8rAGoEqHcTZ43SybDh?G{6j0?@?-srj@B}ZN9`}j zXTEOe>1XqvQ&+g1B54oJb0xfNK3kl+xO$S-yw}~|w_m5U!BmkEh&Fu(KhS3E6Q%Vo!+4#8&5l{G55%P!B>2;!r&Hh?0x;XI20pv=^@OvJxgwy zzq7k&zyKqc1%+W^)s9NhTtJq7mXm$lG+!J22NKfE!>1MyI6Vv9BN8!nL$9QfiZgk` z0B^6w>r5db4kvR%r;;;A#V+AbY2($}DRBsYQM$kLahoCL(qimM12_=F;|)hA7@#`6^8PPtMbd^ZSqUY6u~w7&S^=ztI+2LPEQ{UTww?0Yz@k56TBqkjd35h#_=4| za2UvcuC!l*~(ePBq=b~C6;ay6kHKzHOgW7W6q*D<4Y`Yn`+ zGqy35BT_a;EF@FrQZ%C*B_pIt{AWZEl!A*zXFMaV-;nLhs64^FGdEz@^>Q)t3bji< z^!IH1TQqHwuW~!efGSZnJZ81BTu=d#M>n2aa3XAMdG|+o?5*yo;;kR!Y@(BnqZvxj zw2uxXSz6IHkC|Q{3IXKya6! z#jUspD8*fiLve>9!QI_mzVv?9`~A;a=j2>-&CK4jXQtc5>3A6f%yXCd1|JVY@m@L9 z^29PD|G*6)1U0ZQAe~c%rYSDG5Gg5}-fDkX7m-d*LWiyVUBqV*?^9AqcoOpLaMz$o z%qY}u4uv8S{U!MuU1hrPYxW3qPL z-*Xf6SySh7S<`mEw+dqxaGluSe;8U=S%rL`yt8+6EV*()?O`GPkHkgKLRf3;4m>%4 z^Or7YYm)(*!_t&leR;h+aOe;U9)&-K```|PVn&(d^#fV`o@7v+omy^Hd%Cur39EEL zL3Upk<`}^;C%;nFRq*LPN$BQfYAElFq~m^)SxTCDd)4REiX42lzBZEk{)-#i(+4){ z#JpcV!n(T|Tbb2q`mo}& zr?t)YfV9%;(~?TG;@I(fw*Azqm(4O2{9N#JG#~2}Yt{yQ|{- z_Mj=Y=e@>MKwsq*jB%f-(G2rQxd*_Wq;#hewCHg%WVABHG(_dKAX%<)38;iEJSk~vOXjfJ+y~e6l7mgOU}ozx;cK6x1a&JdikCYgpI!*PA#K{xna5|mB(m& zfhO1=ah`1ipbVHfBDc#eb>ac$4^Kr3!d_fNQQ6v0&33cX_!uh~Pg=_hP)7VD*|T3V z%+24lMM(@(UDCjT?alHZEP}WfSckzEE{c0Kd>{%nRD$6Os}Wl@t%iQ_ zh6${KWibhUJtl_-=`L~s(J&^SOxu0{hj{bu1D`k+s}#07V@8maYmF` zaR1co{jMxKLcXI(Ink8Z=9O@bA3o>wpcX^QZ=gV_K>IH4U(eunBclm^e1#sEa9pABb{7B{R+HacpFC?2bHGJaov{6-fUl?!J4 zs1VPFshSUmCVM?`H0?8?U~-vhrk2`yasNFG#Kq^`eNWXwrq^G2tVK(BQ@IceGpvWv zdUI52ZYjm^?o`yW?1^XnCCA=eQ_0SLtx0@Z%wIm2NF~2lhNPt{c@4I@$)VQEfA)E8 z^6+D;->$dO*ODmRIV#=y+ibBAcVtnhG4GuFMH5hJ1U!DnKCDs^bI_ixb>Ya&e%z68 z-)zP2SM)s^Yz~VZBR=5dIfdk;{16p3Q%Qdj?edFDm(~Pd4gbwLZAd`8Y9vyuRg?Ak zrOowd=Oua6n9`!$GZvJjhg6S4+yf5W3`!ED;A|;Ui81wgE-WglReR%QW4(_-RCxN8Q5G%tuvQnMY{Uq|!WwDef3NF@Y_lNLhTn?i26qTkfT9 zlB7W%4%e&ZAsev&l{gVFT;~E5KN^?ZP#yyY&Fo=TuiBcG;Y2cuHH%_h5G~gCc{9wp zOx(}RT0}ArjXaG)yn2{Tbt7G___%e5}{kT3{02q+$6tH0D!>W*e5o?C0D4nR5skztcnH$vIHQ}on>Wt@^O^W%=?z{iW9aWNJn0e7LX zf_^4gtIQ$JB!OIkW}Kqfcw+4|lry%A*mA3xk<1`t2KI{+=<9c0>@OG*Sz$X(&niA$ z&i>2RVp9$#P{n`er;go`GrripmN$>fV(fjA6UC~pn$qXCdON(08AJZHqxpSCFWegN zocoIrUe;FZsmHwF0i&tNflug{(ko=L_j{GF?;-vj`Ny|#r&eXImT50pCOA|z)@rA* ze}q4lrJ^H6UI?ft4b2QiT)k|efL<30AbBGhzbe{CEtM;?0H0W4%U04Dbz#*F43s>* ze0SW$H0<#)xq}ha9z=qAcZ)wPwdLoXwX5Bfb?|esKJQ2?y>23!ePkCVIps)WC}3Zb zCCwhMQMO<$?#k=sqi%F9U;96BI*h1U92{dRJ0SU44KJN7F zk=@5Zzl@X>`j9ke)J-#j#J(C;=j@Ke(`doh&B~AJf?opK4zPbYt&ISn%SW*QGhjc> z6(WSv+zeG2kn+DZOOHQqHbE!A7zXhL_y~LO8`8wrVeW*RT;^GOd#XLHzQ%v>W)=0q z3g9CHT0qw^7KKj&Bb4_W(N-YY8Ka86JI|9f6M{|~c}1AfE2j9?7i_CvnvA0iggy3q z_%vLWS4^bnm|upYnBD{G^UUsQ!!ta?0D{cnM@X<+P1a@qrv>n{?^^L~cdt_7OtHYu zk7hG#I0-FcwS*&_p+0%h<6wFg_?sMTM}&_dTF+Gw3gIdtaj*|>5EM!#c>8;>LECvh zv%WDMUl-FJD{A4^q~iePWN%CL%d`mCQ}(Z{LK2#_(swLYzirsJYTsPtCc?z*UDvK1 z2pLz_opXj7eims8F!DPjqO^g~T@OFX940SKBgV;F_MZs}J>S3ixStnK_oN!S@vlz| zr1g}7NA^96UQl~v{==^e_XO3-wx-|YF;_l%+NR}ylIi8M@qUU$7rK`7^jXP<^o{HE zhA#RBA$k9lC7jR5fvLkS}G#&%%LijR__IZcP}<=;dwX!oxf z?S|0)UCUY)u|>aUv<|5Sg4TPWF``jO>`t!`rz?Vp>@qWDWTcV&EdNs66PYdWXd z#W~5awkHW%O;j!Zd~BT857J7{mrG_JGlTRomEG5_ zAzm0QNiNmjfv||z4|U{T4Ss?**{6juLyg)?t$5g-VQf)2X@)UY9xFOM?(UXYg$++y z3vn=`o;MI>=%up$X8J&?fGlVffDT(+BY>mE0Uu#O!Rak+Dp-vi={5bz*WF?a z!DNOjUV@$ne|Ya^JYoA!{)M~U%8cYS!i?Y7&Cnon+(}V1z2e#mZM!sb_-;g${X&Jh zl~_x-&Vs6@ULMU28{pdW_XW@wwMJEl$1D*s&i7a_lrBg%vWD19d=i; zVFm_0{t=((%3R(io)KN~cdky1Guc&j6kJ|&cTAW3uB2R%OR;)!U=B9O5 zbVo`CCVWY?`a=2$neG`tQ2AXG(0m*Mxd=#gL4-kERv3j(?>jDBHbv#ggqz+4v5)M= z`aOx;-1h($-#amRv2)X-rU}1SAGb>GTNbhvFytZ_e%8_P1J>DVa=BG@@==L3L6?sK z)X(zJ;3oXMUExHrFn+%%mMp3mZT8$c4x2^+s!vJg2Kb&%BQF%y38M z{a9+X_KHn}5K9s!`K3xD*19k5pSw${_O@(CD@r=ITHH)HFTG(dU;z|sOcn*?-3|Ew zAjey*khH~9bEMQY6_<#R=w~zQsaABnyz&+>^G`stOD`!DNnOhgQ@@n5Iyuy~GPsk2 zr>~-zjBL{#z7GwEXQ*HM7UQwDhzooh|8?O)=D&T-d?pEk`&>poI11tAn;s4RETX76 zqVeTD9uF13S}d`#-ge{)PxTc^BJZGjXM#;E&%V0NUwP0PJjN(m9#y>=!RdJ<6ArkwkoX|3xMn^3ekEopV>vRW^wsW>egg#nS;TE(-1gPhnm6(6D?>hkqX`B#d#**in&*PS}A9Q;i~C6E!jjV zWe8+KGoT}D5lIO$+C2B*XhDx8JR^}>yu&86i0-l6T?VhiP+iN;e5OJGie!QZ(j;)b z%cnUP`cN%0`vvaFhBqzzfeF9ujp@#NdMG~A1UaXX__EzmRw;HkCwvMW3JW^i7$foV zD7M)K!qzi_rP#VfMda1QnC<1R+lr|dFThsPvHsWR4^L#`2mLU-$Ng{t?WE(>!W^Q#w)3#L(2PSZT3p)5wCC}V|}d*{`1ct`i~|K#IB;XcSTyk z>3LacKZ|@0z5i5jGTKw*y;K4W&~nm!@^CaH?{@@mMhutJ<^6YNcD6i7NPO4nN0oX< zJcc&|!Lsm2cHs@eRGcVVyjG7G*KXu!Qn zCG#W)l5~3z$$g9`^a6UkL~1qC;;+0Muj9O(AMf<^hd_K!T=+>&<{V!3J#Q0PqN)DV zeMBU)N&}S1Y<N<&=q*$zpOHdKMa&w3%s+z@FsFo6u&Zx8F|zrq5JhqPlVy@4i-6u$wHxoT-Dx#_H__es2g5o;&*m%BIZ8!Xsd+IVG1fk%f9 z#feglGPc__FT2=Idvb8M|^UQcaw^RGQ|a_ zr!u$p4v`*yhv(}r9%$&`4piHLKwk0_Zu;TyWVP;N2|&595d#5JnwqH||dpR#*RJ1PZiZ{q!3ou1zl$Jcz)+ToF$T3yMB+y*} zX~Nb;=ma^`MbGqZ$FUxGKE21F$%Vi>Uf_W#!}9as&0^B^m7(;fro71TtZS zBM~_v_h|g#uNW@ze&{Jf!n;C0RwE} zcysL)uh|~!o>`>19S+;)Bv&m2K z^#|{f!oiV8DBUv%_C~HgkRF3W!MdrQ*5|H?>MvN(`L#PPn}k;={LjPT%5_7sp+{6h zO;w1A{yGGoMc#tatUevbz#3@dVk=ScK>lHP+9aAof=WFvhmYI&l5UsKq(AWYuj$eJ z@wN#hBEwfi^;qW?ruMU4nu;BJilimc@ON{%g=xj5lU$tA{Pw``1`IGEpA*s`VD4+E zyPtSJmW5liT7K{>E8ER?%0c+p1q)lqYFX=%mcL>AB_Uu)M0XgMC@;RHg(AV*M6NCP zOB~qCk&^v~OQBaX1+7lPfz_^yp5J&yhw|WX{E`E^E$!{hjf7UAdmDXeudp;#V<52a z9rBO;@Gu((+cJZCZ6xpgzw-|iJa2c73+@TDO&8%8`tD#SKJXGK{dW9d&tPbEDZH05 z^{j;Ly2R>>&@GcTt&O?hm)(gL-YERb-+!t|x#q@n9{C!%m`m2qK?=zJ(c#{~_AF|+ zG87hGY=3=yN(=c}**G89=eKvh!WRWw3;_C_2$U~~L4KV9-+bKP4jZ#yZhoXxVMbW=S^LLFE5*DXUQbSA^yq=P z&Csd%OsMhe*oz!aemnUq^_0eyi9N|t>Y~M#spCsfXjm_)MpW)m^^8sAkb-vUo)7G= z8V%Nxrq=rTbVz`1Z5nG}piztc1Iha9IN)P;+j9l`rvb1O$a?|3NFpwG5F*8Wn%Ov| z)|$ffP5fABqkqY8K5IXXj~jHmF& z;Jv&0#PUXJMlG({?a`Hqx-)LO`o)95**Sln_ZAS)=(c+AD>?OwA`qqfOC$qnB}uWe zO$hJoVdj(7>BG}Tvr+^9P|Q-hv{bCQIZ}1%PuUuR^x@v9U|m@Z?w>k(8LQ9UqQiPH zrD%oe@)5{k$%AE@oIv01LG?3fkjwL)5um?l-EM&A!1yZqJ-i3BQY0hz**5I=tQOPb zGgPHvDaLk-_-DC;RqxcH_12gJ_YFzphpCY?%jh_g1t>c~EqBFwZO>OH{yqy&J2c50hw!aRQN3b{ z4DK$E!Ul;973*H%XD+(8Z~xu@-U&Ltp6G}=c-=09D)M6Hj4Z15#@H+b;`H7ujgWh^ z|KkI^<_R3!;W8HZG@$UV4TYvaLW}0ljhpxu{mu;)S5A zhh}7?gr)SQbbRA;47WC}Fds&swD_u4es$GA5(C|jbzOBzoI^|;*bw|DYkosAHtX?O zER}+B$+5AmTcfvE02siw^RG}|Y7&It9>3R_V<^bKUU}Qgn$+}yVTB)UZq4>|U z9fQ}e|7*u6RIteEbm(F4J^wdnVWz{wOeSVkGNb{f;RpSv@M4O}*$!KBzZIsUFTyvs zpYTb2ah=_xbr9jMfCM_vhbEnksEEr3Ebr1!umhrDtVYa>$Fd=vTm=%Z#P9F9XN#(q zp7rK$aOyrI^)%M_?~HHBkQ~nJ7%Ul;Bi%5;UvE1R$bZkLTg-8F-Vre?*m}7GKToZs zElH1Y)$4e`xwtjjg6k=Y&FQwR2>L(xfr3hFCWvbO&RY7}b%2|1^g8|c9f|yG2VxL4 zG}>`;(aBCshKYk@Xn)3d08d&j_?0k7z0V>>lyX8^4Zc93Aw&~VcF(~)?cMu{=RYjT zVbE80hn;MhBZ-1WM!yf>Ds47zONsbN*_BvRQ9wySwlKHzGs`j>TUmGW>_wM8+(;R# z7BUa7UH0~r`@&-Lo3TRqX_JZBW|zr-UroNsEUPIyH5@f%HKcK?Avl1@wyTzarbh6WLGx4*wf9vq7H z0z!()i*cdlh&_ED6#9m$rwqt<$>S?P1#XnUG%S<&W}02c~Crv7TX%9!(2Lt50CazPL7SPtjg`I2cBf0 zeqFEINdlp3aQoL;4iWFg=jEs01XYjozFBKe>8Te5Wfgx@TUz|Ss;vn#hYGi{i@*e~g!A@mXX{FzT%TUz}=FvU#^S0kB zTW}B8eVTZc2@}#ebjM9JFEAlmCMn>x%3N7DaIg7OcF`E`LJv^2B#CmzvZ`w*j z@&y~opwF60jTA{$(}N1%ucq^*1@ave#cXjX$%jyzmFbTu&@jtQnmQ+u&`B}LM7r4Z*%c`wP4ntD@Y)T0Ci}$z-papS z%l~I|Y*-&57qrfZs+R0XiQA+8!JS*Y?2-2gSJj@$xOEuor5CCpC(I@m(mf2t#Zid( zToJ{^ZPxK)$I^8{Fb2u<$Rjx<@l&_Uq?yZO|54^<%pK`^w3Z3nk8mN}Pw=27%pO-r-OS}O&Zdz8fp~X zL@1Pl3O_ueENOjQx@#lVx^7Z~{i)}lGCOTAq~nlH}13eNKVY&Z~Dt^L$j zaVGm9?R>+S>CT1fx^~Sgsq%&;@LnDIVg_Kv%4b=lrCDYX77#W!$ywo@$$Vqb4R_Dz ze-RS8L8IKE-4aivOl~F3lr4vVpH;x=V)IvxOI&gblVm6#b`&BD1jZcy_{KI1<|?L6 zmc0Y^z4x|dHS&+!Gr(dHkfsh(Mdrw8dGc-tuVjpWBd3=FCtzF}WTFx((T>Wt=bD^n z$zi+Hg5JSYF6oby%N=*if)_+yQ(xykwBlDn($vLgy*>L?C6;a5)!}A)UT+%YHX?GT zV1$K9_73xIfwVAaGU>dVb1buC5xN`j{UydGu5ReZLUnj7V+z2`TBDDG?bsn0C0`if z2`cxGu(^QTLbo{DS)E);rh!qn3ZquATPJ9rYRw1==0U1qp zhrdsmD5!mXz7iUcTY}!3b*3nEa6PsjyH;tdudUTE`K?!G$gFro^rlc65~?+a7k}_S znX9yY>!4Wt3vk$)^i7b?a&5xX1P5+&sg3QoOx-%l2Cz9KO6t($0HT1cX3N!lMJpMA z$+>Z&TaMnNGpyV_uY1x$RfJ!%_d+H0FsT6goW`NbSMhzCiRtB?O@@F2}|u zX~TUs>!!Rik)fNjTtv8`{S(3{0IN`NMWX~=Z;xBE1YIYz6)0HS(j0MVClZnyRwJ-? zcW|~`Ct%QdUnCHWW(GASqEA4N8;@fzGnv_m~TTL^@F6(cMH;RBm%QO!`#+x4g}KHP0ZFb zHE)HM*)+5mAy3ATc7RJ@!zFyw@}V8u{FQ#30JPh{d-5Qjht;r;h4X`p687F7^`;R) z+=QhM^jHi%QI|@`jXgvCHT7qCTJ4n+FaD~?%77#{Af!#8 zydPA>F~&rG1$Sx~9GP(_thMxtr zW;BXbV=L2IVd5W0HH{uthY5w(Ab5)eQ)w96cfKzrTkIpZ+b%SKGBUnJr6Eur%m=VG zp^jNPdHcm-^*ovS#_x#SDihHH+&UDAS3Z(n8ulO67>~@5*@O&0Ry9;kqe*7A3R4n5 z5$S|xYs>2HoBAb7YVsV^S@w}l9>ySY$Pki?k4?|mfkUNH@jbGT-j}7nPhcF4O<{`3 z;h_4Y5_k#qm`)pUNRGdaf@=Z!nO(dep}ythyV0|y+B>3FGjpLc1|=xXyM~1Uc_z*! z!Co6tr>CI4T<(}Fd*w9fG)1n2Pg*W?Om$l39m4oLEOqImeBX?b4uKD7bSLpNkU@LF zhoMhBGcU!3l~7k`bFzhWV9eUYG*n}(5Ar=cQ^~+wJvFLTTjnig$UkhkEdxu!{*|Pf ziZEWYWrqh~Bw+17snKKhCH_d^f8xJwgF#A9R1MBD=sh@a*@DWbd?nGB$~$59AKM7> zj!zp<02Xc|U4asG4~5vAO}YEiew4)>On`7VApc#tBJjaP2D$xvfVNXrcnJ+WeU$g1 zCdl5&&xmY0QD+5qhwYZ#xWYEuw`mtRHx`Z7fvsL)`rdx4ll;Q`XO-RJLbYJ~MOjcU z$vYbiH5er9iju_~r7GY`x{rn-Ce*bp&=o*?H2>Gt=w^)nxhr(Mod`x(efu^kDO$+w z;droaV%+W!nst@gYZlK*+`02$h+R4*Eg~2&WvJ34WVoI;lbj5TKmzaR3qUY{PQ5HA zNxa2ENi-s%wQT(wSQi}LONHHd0(D;Azvb159^7G}*{C{=z}%y*BTmjsg#cZW@gWuf zK$32R&o$O8i)O z9AC7k(3^fblMOi(7SDBsaxEo_@G54uz`Hkt)p{qy?d`=Vw3C8P6NV9GRD+4nj;;>{ z=v9rOSXF)yWF@Z0!g0SN!p$4uPx(i1kD$UJ3UYO#O8>jv*megqs>I zlD?Efosd=Ohkru+;oif3O9JI^<==;fQQXk@q5^mv4SN5xsO$?C18M0JLNj@imy=w8 zvvUfePPkOMd?rco#6JXhTfhy{K-ytK-!n_|f*yJHkOdfJGH};Id50SbxHnVHH?H59 zlvh}|lSgt848|0D0Pq9`UjPCVVrnW|=L#CvP|w(sl*Ez}*;_Ej1*QLUc1#AH+dl9Y ze*!u(OR(YT<@ks+eHAJ5Ch52zXe7Gx?Wl|hO!cBKf{yR|zI4F?>VIv8zAnnVOoUs@ zO`@4I5NU)|>Q1%ouxB?!P1D8o+A{~rqEE`0JuT+(-p#4!m$4_ybmB`SKYKfxDNk0A zE!`fyHX1M=R_Z+%B+tM}cET1OQYe?xuY#-`M*7Rv1sIbSLdQK&y?-HVjwReJ)k4c8 zQ*JB1O2c;>_+`IgQQh3KNnNEgen4JCHXEY62mqg0|WlS*iUE)vk( zd6)~2NW;1U7;!3D&0TrS_IKzmc=7*h0j>$Ef(e+%|2m6F_3H;uFl|&iT&Yn@e1!v8sKRDza(e1)^2^g^4LEm9e_C zR`V3ck}b1$>m4Na?^7RN)$S%Uopoj|R_WnkKwiTGZvOZ4;zs(p8w^`jI7ABJPZ8P2 zgR5c2DmhD^d8K)Jwu2!TjS2xfkL?+Rn*>Y*Ye=fzf8EN2>V9`Pphc$6qeazX@wZBG z1@P|ika%kxIT#>zQzJ8!_nHdc*shA_njh%udRjgPEge&82KMm!X{(4aipb!;z<#v+ zfWj@wFVt51ZN&a}C(Xo3V52YTpi^Du$s8(sPr2dkBOv<@*cP;rWenNP21TzX)_YY%^=k zWo6BIFJW0SgYW>!*$ge<>F-y;j1Ms)rwwfOO55IORD_V-+H1G@te(F$O}~yp4Jepy z;Q-GJm^4Q9P+5-O(PE_+LFHhmo@$=_pLRRIfWBp#*eCuEjx#+=e-RCTsce_6Ynico ziBS>i+P1!(MeZtSL5Y>6vDhCCCRwnF_I!&c?3x4W6e(4~?5|;mi*qObr6?6muE5WP zQv6G$;6-YYG2YwzNi{HhJiYrCK|c~q-lONylTYTHgVgJ79r&V1p>8)>hnZb*@LI0Z zZ{|zKIU`U@|%~*xP~irrP>)a z15&rcWbgzoikO5T74Pf7rR7s%=WT;Wsdfmnec0}P`r@Fp^WA<3Y9CTZPx1C7_dCx< zp(leu)J_W^S1xB=yxq_!2_!P9@^43Ae4+Y<;G=_j{Sa~Qf_<&kgu0BaY1S$W`IB#Y z&HJFZ4HeK#ZK*9pIN-M5pqd2*D65qp`Fl|Nq;{_ux=$Y%!fjhVX-lQn8Cve>#|o8TbOJ$@zwC~o#@XcTOJH45(~qM8_Bsl=3!({di7#pfYKAtO$2_@=LL4mRPz6{Q9!+{ zqyJ6qvVD|`Bo=Bp0!>NnXG0#D0b*bFEIv+1H1v*eHyS;C*nZ<^l^0tU;hU>~F(Kpno2XRI>*Bx^UU5&06WTq4mzO91rt zLMGDEcU=McGGwE=fv$UnHzUd7q19Xt)q;f&IQ;dY^t$vQDF5{KQ`ItKRHSfMjg zi@Cm9jL_x>8S`V*qE|bsG8}-7jV`I~2ZLuF$_v=AEB0vNaO?`sD51HfdeHlzsf#Ss zJ{GV4sh_l0Mv(yCTa34`Gs@7khwx?ld^*fH4Vj@ypP1jn9;z!TET~|FiK&TQKDuc8 zqN(IL|1Q4`z1BilP39Rv(Ajn|p#$U){>KO|o=)WHBLV2Z}`n9=Cz~$?B@Yu}9kKKeC*W*@UF#DW8EIQGua=|j9K%e^&-qCQllw#< z-54m?4onhT(APl1wT*^2BgA1Z)WMoGjUOVXsBlIL^+sC^_~L5Gr~6_D;xhVfD-d|LD_XDc7`MS z?uFhpmjsJ9k_39NTy78bW8<2%(24IR-+ptiKE0##RwP~PV~NGY1jf4gS*wT}2_N71 zQdousL3P@eX{AB`oO*3_>(E#$0Yjv!TU8&?M07TkBlE;6T*$SYdpw`{B|Zl(*Wb*` z7(>BD8;2usA-lXxDqa#PB#vR}6pdTXXmnli{3-Q=88-Ywt{*CUST%ODliyzDU0Ook zrI%o6xo?jtQ`ApXpnWIEOd`TJF+eKrpS4<3);Cw3lwwHl(u(6-p;_XS#!rT))=i!3wqL&69}Jx4Pmy2e@T2V#d&_A2$O3ql`Y=Jueqqe>MH8 zA79KD?BKci=MxLHFhT17l1JHi)g_fqSI#U%1`zR2Hn`L8=GM*c{uy%CYLgny;vS4d z>hS(#-{(k7z zd>EtYqRYZ)7w5J2s$%=Kn7V?ht6#3tjmFGMturddjWFeJJ5kcxtJ%zSO`)j7x41Mc0e=m%d zXA-dYKP5Gv4aKejovIkR9+rv0Ti&==b-wHm)~`BBYm@tiVpC2Fd~g{G)XHv+o3x3 z@f%SInl_Pz=2Bl*8JzKWmyOxp&5=0nBbz4;T_JqP?BHq)3I7|sGrRM4 zW-m+>+vnK8zM9=FtGlYB-=+MOQm?`P{jivFrnAv)y*=PCMLA6gTN<4o@w*pzdT;E1 zr$uoyy`G+%hK)IGW7J&fwkOAWM{0hTfw5p5J1vOpn8L_-e5!()DDEy`{0##LJ(32f zGtPtBE;`*!&D`A=TfZm3mER+%a!A8 zYo!x#0JH*#KN9AI8!uuHJUSLN6ykvj+8aISgRUS?3ZMpH;TxlQ+GXhfSOPSJc!rs! z$hlHBil0gbLhR1RJa!4WfPHA!RYc9u2CeM;XaeS}4cE8G5Bd&t z274`YD{`M?w`~El2x}bBnH~8w_9wQjkM5p6*voPvi(}~~z4qr81R}>r^NU%^L>&mq zVG|=(X>G{#KWw=gp+tOqCK?0S#{!*}p!UzWi2~75l>tfqIes@gHXAh+R;B++#vBQA zK-Tl%U_$xWH)-Cb9QlWh53V&coz0hXu|y84GB3*iKCC@vZbNU&YUl47hfhJ7)N@DT z%IITP>P8i#55QDzhc-!yieJ4z25Q5n?4RxDONnnUFXcIc`ukGs(VyY1NgCu5-LXbvac6ePWp())mYvm>xm?wZk~RtYoui9xVyt|LHbHrZHG4C2 z2P$Bi%I?R@KE2Hl;P!8ijyaWVsvEb04g~m@NkoB(aBjFN%WyCu2&)-vR#2_!CqS*E zObBeQ5ozbS@(`g8WjNhp^05J;0|M>?59pQ=cqkVU4P$M^qe$x*g0lut9z&NclrKh} zZMXNj+HH3v(;lJ{en=-6{+d&sWe2Uh#!%0s_#;*e#K~EuiG*8U=*=~r`m!$X&>C6Q z;}g`n5Ml%V5ob*KeGkbA^1LELj$4^p91a~HE-%ff?D zgt9&aKR@<#Gc_~<{w%^z(9exhBFLE0)B)>^fw}!85*rOlK~7`W2tQ?_iSGdteOR*p zeY3J~GgtZ2gcIT6DIg3rRZ)&Rj`HR@q2=Z9KTm`wzBJWz?DCR5|Jr@iwFwg80XH>` zdjKT-c1h~pKZ6Hh8wv35M1@N?%1%rvwz1Dy zOA*U&DyD@(SvNUuYp?Xuj>^aJ)t7e5xf{+_3Q%s&;GWS#hu(|I{zL6|(lavfa~Lcm zqwtbkZtj=n9vH^L$ZB~16*&;xxof=;iZK6aP&LwX#lZrsuGdZ@2GeyCV_$;JtS00w zXv@YauvNB*C}lsRJayMXax0@ZG`{>M@Nk?2?T!>8_A1`tCxcQeMzaa7u#5i(91PyA5&Ay=eU3 z#x|#(r%yIiC{O98?KI*;(J;>l3nNon%CN4m@%)QA=c0(<-j^$!!+bDA} z3p+PEu&HpA09rBvQ6e{+Q^}#_cS_~rx=N2v+gX{l@9hq=4k>C#sA@yO z58eO(w1?pJBbA|McqprU2d2bH{-eej=R4s@ypR+E*Qu28mkG6yOZ-4Xo*sC3n7qb} zzOxbxZcg&I^t@+y3ms1OW-IW+>;Y8{G>}%R*0A;Vr$l{oz=_$%HE5-{j>c`)sEc=UlbT>y5pmCv=slo3bA?KS2nUU zUzE<|xBnd}<7LE3*vkS^32Cv@7`f&Cvo=i)vJ442uJJ1|kmHnmK}?D}W*-%Rk4Ui? zBU(c*ruaRggo*t9??~ZoI}u)9M`v{>pl3Ubvi?_@>e87A=#GN(F zcsycpZx`^XmMpR>U{fAXQTVd!)^(LN7DJzg|Pt$To) z|K;B^Xs_jE2A==BNv$3(i%0ga*xX)bD--Id|AeOR$y!B+ z+cGmTZ8$r;WrPK~7rbfaoQ8{@vGV4XA2!P+&R6nAvn1?324-)0zBfOo`k(R*f=SUK(d(aRROw`QDj; z#*u@%t)U9IPJIp@+_=d(U=WYeZKUbZy=Di9i5fEY;08gvA>5%1`&fMDp?zX}r&@AEL!J02=LO>r^HOsZA4iwTg z+|=v}{<4=&-|QPO*An)LEn*gYB@iKdUkpUWL4sGQD|Q--+E5bqX~?Ydt#C^>DUZK- z$&9;uGEiLF^H)!A=z`Y(i`07Sg4Rde ztiw#-{(Ni2kX7c*qJU-#=1uKU8~(GzclRh2%XTy{mQW6{=n36V6G$w^2qjP0I}rO+Y;QS%SNJXuc3a zr_)N1R`oNc`ebxe`pz}Z{m^K4tIc=`45_y}!<5~}5rUQtpz{606s`*YR6hR?-dDjR ziWsp&{hOAZA6(Ah8plTV7NN4x|Av%(KF*TIMWZ$fU}*C~Q_vr5|A3JOel}MO%3#8X zGr9*}=;?VM=Ep2K{vz{2zQo=}Wv2avihd)y<+I*cVcSE7Gqt*&*~{`hSY#@vW#az)KNe16Vjfl+y-@N@ zpx|wn_ZkANL!CbDcWix-BPahgBSk3uRm7}oZH(m|v_7-Q3FHTny;=sUyBF>8@-qMk7>o0FUV#W_PIt-PBTQ`HVI_F*oPJ z#^cZlx}ST7$BNkz1uT!CBv7j^)-XTH99t+oIW+4k)8*=fy;Vx~{JMR85M^oNMh@6sGCDblZ2RXEb{z`9>hr_6$*Bkt{d3oDU?Gl-xhq%_GJ>D#;=Id zcLIYD3HPOZgjWOw*;m-dzS#_>Z%l?4(D6mE6%bQ@Iiso={p!=w{!=rQFS~bEw$-=w z%$_o%a^KvEqUle#ExyNM{!NYH)%mgmK-;lH=E%TTWv2V1rCLdfXf80_kzm6W*&Y zgF_~BkX->1Xd}7PPxDH#4^!*hXWrkW61b&C3NO(7RaEIT!G$8z{Ct_-PhB2Crehy= zn%;)~*yifz71Oq{!p?CjrjPi$6C zQ7fNjEo`Q~5u4xQMRHnk3Evj|=1*)Bt6?Rlnp|_fZ(rvZ9YPOyMmfsplGQZPZ=*- z>A21p$AM%hT!nF=;at_b4ZtHw1>9b`T+1rrwtLWeTFX(kd<~K0+uyk`-!Z2OODOfL z)%=@IOGu;ja;{P?P`pxyykCxR9+ zvVn#w2O&2vK!N31#0#~C(nqm5O1+!IES~D`>k)nFgcoP*Y`gID&($$?~`gnhsfx1vL@sE=tUzH)JU7vnS`Nk(V;WSTpk#MA~ zS6q?m_I+9$B2*pJ>$R!pb;(b&-L4ovYP?1*5Y$~}I0FrpbBMEW!bVWXl5>aFbAK%& z%`&JGg#>mT;|?%~t8vm#i+a_4BFXY|bMcmR(87G;7aGt$>mb(dSftl%k@xy0aJqCc zOUXCkWn`6|t60he$N2Y5ea>GPwi2J&MinR7Hl@xySKt`Wi#VmTMJtQV#m{)=9fvel z!?~mec*Gu@J`2^HbXt9V|MdKSUpV4jepny#eKpA$Cif^4#v2-+n-6(JfIu-%T$VH< z&B?T?)nSiCN(xojR$(mptbd4D$preA-_Zrt z2o`Uf0l)N0u3_sS$1(p@o>qp0VYCC2#0ehEr^ywJlx1H1ExYSPM53SG#iPqr2AW4+ zKUoS)&-(p-pywY@D)Fbw+^)!O8$j!s+M^rQOLKkr2BFg{wJ602;~Rf}>cah73vX;J zljozsY@29j7lak%{hmw6stU01YU9=?|G7N6fewd=SoCod>c#3Kf@RpM-RHD9cZ=Lt zM*(z{EflRZeKX4sj}n;u#W?cuvlIoHb}Ee(!)4xaWR(d{X9irDlSi>8+Zan^w!toQ z(9QgTqf}SZB(bIY#}2j1LJo~WyY<;Ev*x<0`_|PX-Igs#JNxt5Jvkg{$rL*bMBw23 z_%$(~Ce_`})oj&XeigATQHJBAjN;qLReh%C>uamZii(~PS zZ}p@b<&vdjI?-S!5CnmrRJiQdVsyExDC~PafW=!7LOV-J%R!CU<0LKLFk5MJeUwp{ za`f`aA9N@FJTw;+q@tIOHk|@55EfXy*&Md~(GpTezU5Hw$D4~YFSi3MnU}+e_DTO_ z>()L`v~r`W1+q28u|L(5@kQjMG>{`&5f;^Pe2o= zoU)Aa41vy6{n>9ppvPy|8~D>96G^1mA|nUyc$0p(p2w;`5EN!((}2yi#L9!_esuLc zP~TLN3@iTUa)|O8G^4z`Mwh87p<$=p-)PVIbuHX2s+$()C_H<^V6w@4|9PfL4aqZzQeS zLQ<$$A16w0K6Pf`DevUf`ck=k`_oOHm_RU%Sq9hXuX4|c#PCu$m(@1IBPC_;b=x^2 zeva(d-Qr&9EOp83&iiKPnp5bb`sJ+S0Dtb}WfG||T#HG`pI#J&kk?L!MS~O}N&a&c z+h2z>)MTqSvrB{%clXgJecd&XB12wbO`5$vl)P()St)tOZL|Ey-e`$?=C^JCcP;>& zlh^sBRQwtw06}h|e7^1lq}abIRcK=K8EdHmdxyAI3Dy^ok$u-C5y`_ib_y}Ha&;mW zk(Z!vEY(`C?p?i1k=QKcG@JPmAj{Te?be5xNiLywcBRoTV=<>yAn40`W-FFXp zCqRRY{i<(kdC$f1C$A(e7s-EMMLh7)swC=U<)VWU@Tf{9K}6)v#_sXfFoy&JS3HFM zo6ml4X4IV0^waoC%h9pJ?I;ah8p*POTa(~znKjt&D(V$j)okPe@ z3|&>hI7X4fYlqXx(loCkR2qZc_#8MI`+&LU9hAV%mSKfa|KeozLrd-Wj|zAgG|9~# z*qCbHSQHyk8S}JW7QUf^47!=HV*qd*qSql3*GUpJ`)>XA^kSK{#QRNWutQtD_u56CD*fEo zJhdehoL@1^?d$aQvgRHBYZ|XQ?Y|TeCSe?H1Zm@qv7j0e7#Y9;F%(Omcg{Vm4JT`) zbDHp$8+YGnm~C#h ztEGwzD`kG=^QThksIM6%=^=<6bthE@JCgPiP8=2t5xL>0Q^`t(qcr#^qg173`EP4M zitg^p4SDpWhw}ueoM#vom94)Qq93!c%brE<2JiHeJZ`UKf|vdIbrH@_J4u<5bXEZZ zXGw+@pP&Xm0xgAVPvnqh5_fMptI9ko!9=5pQ#r|-UFLmKqxs=iS0*LenoR+;!3df> z_d}8#>UZ0CDG9GG2T8+na(P z2j@Mg%~mVdO0LqkbiadGl`{t3q5S;l$FgS!nNw-0Hgjq@Aqg;#zK?9rCY<7$3RH69 z(UXqO4ZCs%=1praN-?RcHnupttM){Gn?k|3F&njO3$5GLUph5sspHT6=H!dD16HL@ zftNemw_bd>V_%ryFPt58C5xK4nSB2AMX{(rZHDpZqTK&S7u^5Qr3E>%v8=3FG{9WA z!L)Kg#5f`la_;1J2@KH`Ql;6`wL+=o0#nAz!!N17TijoXT>WuL7 z*DQ6lly1heBkR?dgyi9So*u{Gy*Itn2e*!^SM27)$%03IR!ckDw45;m3OXqR%WX~D z*F8i4L&7_T5@RNu`~rNGDP;f%q%$j}=P}k+u6{NMTMGojiKSTzL9Jw$!jtEbtSE2I zl-o2?mqd;9P_AQFhNWUeZyXhQ`(bAaoTyhlMW^Z%7-l8XGHHY9Wp%-_n3zoHg#!Z{ zJGKjSDfW$_7mdq3AARfrSkr!;ZTByfCll#$a# zH&lOm8J;CforLhDh3L&)FyyZFn-cADY{uLCENQid6RW&&QMq1i=tHl68!V}^TI4bf z?^5e#NMWwzA{KiNs(qbr-66>toA^0nf{NFe_R(d>$#8wqR8)# zfAe3*CLiyU`IN;$Ja~4sAz-QQ8;-@kv+~rTi|>_1KM+X*4Yw$vH@|x;yGQN>;9`Qn zKo=%{yLXl*se4$xnxr-waI$#2y4EPQZO$X_|N8D*uU_gDLi@YW6j@SZmNEJ^Q*HfbY+K&wPDJKn<>)%5?hbm&F>kzFN8VQkvYY_vVl&(fI9yM9!Lfrr zR^wWoA~AuX*JVc^4z%Vt8Sn3!moV1WaF5&>awYG|G_&jeF}FF_&0r>3fg6IqNb9W; z9wK>mn1z<9>ImnD;rD%C>mulluMj+=Nv1+pW7rugaJm`fhj+fDlW8SH0OSHy882YTh;t(|o)$}u3HfzKz0n{&An$I z$GrA^wL!fuBHNzW&~x@o=#AD7^*1Hyar}dw5a&Pj-g~xl&(V%tR z&_s%ood4s^(z`IHfKA3&>YAMfMYk$HxU7Da{b+~@F`K#g9^g>W!@PfK4JpRmLP2ax ziN?%k#Q03W*=(cF=WRF>vyYx>DNErN4X8Rf>mhs%;k?zQu+~Hk8p~Z9&`dfJvRdU< zw74h^Un%LHdgtNFX77&mVrK2=#ZaK$P{)NEbktI)J9G$-(%Y2%A9a0OlG8;TKYP=G zSz*${g_5r$FJ~s%4|387OX*!`!o3f(-zp-)f7HC)eJ9mj=DCdX+ZB0S7&ECf&y(Y4 zyLa|i-9?(iCzl~mNCKb4JN{?6tb7F#0z(|FkEp7}>Z7fH=oma~1U$F$z_IfFXWQF5 z02P(!y82^ipoC+e3I}4H)gC(gD{NTWWkde=es5l~rSX#ZquNgH#G2!|5qYjf*<>~D zU#k+H#EhrY_2ou05J+>A;L14Cv()O_JnUJIKjq;E?=rVGl$;ENuHL6(BG$&F^p+r| zh%ug7M>}{@{YXlCyY{!AXxwg;_Z(yb9E#e($ulR;eME@WpR&omY*lhmtQ$gAPTr_k zlScz1yh4Bk8fX$9BUr-nJZ>M4Efju_w^g?vwMjM^dY(;$wEY0%bK&Y#u41l%r!o*^ zL1?#sdQW|wMHr(C3NdT6Go!D{H+0701aU{Fik`Ha)Q7x3y^nZa4paUM&#*L{A9lqY zO>NT_Lo+Wp5GofqGj7+)Mb0O-tLWi`^r^w&?&ON zHb={d?r(tCclO!F!-_)C;lrg9w(!Xt5{X5rFNpcNPrubsy*<76o^33`9or*)3iHZ5 z#iYECIx!VYt-XN)>7ttE$ zSwXH;pVHVSv@>Qbb!k3kOZ*YTN@KjS!0Ul-i`0}GNlM=+k}_yi6qSv(sL9@<;MChA zHOQrl&wa^{b`&)^J#Xd_#Jsi_RZCvk5{`6w6W#CI)Ov&pt4)So3~(%P@t^jdws)}J z0`{#J*0L=+qsyJ#aKdW)YK9j)c&~;;?H+ev?;Wa)-d2i?u#Zmk`l2(L*$fq+qi*0d zKNIieK}EU`^jTS2w}ln@s0Nf65=4m4AbZolti{(dJkT{`Z-mOtM7r;_9y+SN1`Pog z-oAwkJ^tOi2Rryv!5hz`J3Y}insh%_gH&N3Eyw&Lo$+PSOMTjBaj36j)Kq>aVrk&= zwDR1Z?yJ)R8=4Dd;lPj~?8+YXzr#e;6`szYKR&OE-ZU8zH8%faBkzmy8g^lxa&{p?63W zn0Fj!i=1f$1VJrjJttT)-hTl>jqPhenJb>f`Y3;ku{G#Nq zXN`d|v<@vhBe|ua)X^Du{XOY}M8XMd6hKq9CuTI24O+)58on23<~^;-jZ#CB1pZ@o zzTy<~*6Gh27-#K8WXJ)xr_)mDWynRh@TF!D_v;j(-(|iTEBaoysydzHdGRd#4vX`o z(hyaDiK^O#-zZl%6%yUbl|V`&YC>W-gRh%(Bp`Kmb|`dh@bAi&KD@rVvQ6>FS+(Hz ziF$$FV(EI68SaptfL}VPt`B-mM*K|2Cp;H6es1PwI`0?BIRZ7?go`EHvCc|*l6mN9(nVO{L_S!+fx5W!&Z4f3t) zBcVdj`F5yaEJ50Vjo{^sB6-u7>XW599r;8&-4rQwA^ubnGP9moPFuM%XhMl@Q$->v zgHgd2Z@StvRF;+1+v~7VA${KImRr=#rM<_K=#Lb+6R~9h^_^sqgSv5I9z=0aFA)Ef z6(^P*hXizBG4-=G=d0ko%~5<5WAu;F=vA=rYp=MM8zPa2qyqllo-PsemW=GM<#nQb z_l4|7wb+Ai%nRuGEMqj{$?WIhMmE(C*F6_2IE9yHNJ4qs(0A!dTE!?ul-}J=ix{^D zbw$*t@s!@*2r!l=mm6HJM!fl|UM*sWdtY>Xez!=m(q1F+eL=COixKnC?c6?J1L&N7 zFv?|T_00Emp`3-hLd2CEm zc9ew+$Gk@|#-J54@_z{l)R<&}2fH$!5@I{q5KKxR(E!HA8$%YT56K&pD+S&vym><(rn@Ae zT9~W$W*1^Kpbzm8%5?P=nTpds8DBLrHJt`t#vD zo3T-K4hCMN3GxbF;4F0rB`*tvT}|2>JTH!9Y1loh&uncq-&1Eb5>&=)%}5dsO|e>f zoaBV`0~pAVL@ehuMNl0bIIUi#(yD(?#c?XBy>A@6(jVmB6p|=D{9-V~ElO5Bxbg~b z{9yF`?qbIXQ29=OWUm16hoF<_kyEL?E?a8;5bxIYEj8)ekQ6y7zlcg(YyHCqX66w( zb(?4HX^HU-I+Ewd<)bxSno-QtGoF_c!igCqpFiS$7yX(PY2FER!y{i$b66*oW?Ss| zDjxUmz@n9({;R^iJUoAF-f7pWND=q!)5?W6+cFD8P0JNqaTr)yWs32qZg8 zFy5|F{l*H5!~Eg}gg_niK}{FI`+#57OluqKZ6E8B<8q{)NtlYWu_=JusxvAB3G3oP zAka{URx7X3lGgE4Y-$TjEJ35SM&A2kbW9OXzAvRsH6ClvCj~;{B6TwxyePdX28%mC z+v3|AVp3aK(%T#xjd9VJ%ftZ9ry+<6%PeWLyavnF&&Te_U)w#7i9U2QMCc@YUDy*) zCi{Wm6s}E*ho_&}`ZPQ8w&I6HPirp)VY?XswAgDRs^!vb;wE4!CAR z(L8EC;8@Mu8|5^;R0?tZutaaU_BQp-{B8qvEzDyS9E|^ikMt!23UB1o3%Qt%Ml&5W zsHk&plrIRYX2;J@e>vF_w0X+2C3iFY_uFo%&h2ONmwmWDA^OY(KkpQ_k$Z{Am4WJC zx74@>v>|+Z;0jwD0y!O$Q;U_WkxabeW>T|mx_p!?1xzZ$wlvN^2YKBBS|6FwPmR0~ zE1q|0>6sjef4Rsjj)H#S5955es>eqZs%?MnIrGKhv{pes2)!Yb!Qaggt0kF*5J-Q{ zNdp=$n(C3go(gYRuh@F=?cu9G9{81AP4Q)WE+tU@Wr|lJd*is4LU8U3q)F!5n+6MunDs2}WOpk6u_J<|9Tma8mfY#)-W~o{b$!r)i#mzu`Mi;g$LxV}w*@ViTk*x97H- zLr41V5m#Pp)uMxL8O^wCnh(I&eu&Eu;S&Ww${SKyC^0bR_M}%Cre2po4frIkJZdg# zxkQ5>JSDNYDSJEG3nS7z^L=kSw7&SEgzFQ~)ALDZ>5I=~Irh|*`JvAfPGldEBu2^) zGDMg}Z09Y&2G9;anUG$C z1cW6t+7X5N$fJMhB*8YavlGvru;8V&#;#oMH+&QIC%=Sm$MrY6P-BRE3eY{SOVRN@ zS6X3Z2W=3+S$pf-j3wj2pP0>3Yo-QU(zerNciF8AG&_n zYys6qo_C2jE`&Nbn7aRs$w($m@_LEucOUio*CVRN90z65PTykaV0un)pi`f%@HIxH zGo@e;$$X(lqWS-wcq)QwL6UVYz{gzk@2A9G1bqe5AZC68GU4P3d`o~+G0&X`!^hWg zO)7IrY}6iww>SC?#-K}m=fAFc@GL5r%ku@XbEc zq>nr)o@I`rw4My^F0-6*5E3wYV|G4t?wbwX;(y`>j6F{N z$hDa)gmZbd?0foih-r!H{KA7wSRQ#TRvzC3G`MVJX5jrAim2vtIr|SA4I6G(Ypjoum_-qy9~*}q=#y#woLNFM`-qy%_*oKG`=c@aixTfARYp5i_@ zS9rZjn}!$)Cc?JwgANP(5(ncx1q6}uk(TQnXua@7pAX)?(XKSY2MloxA3-9VlNdTp z(&!yDD*ueTfoA~_B@V#H=l&NZA^MMJBs!90RSHy-?RPd3G^@voY*m_w@BnPVmmf4F zUk60Jc9ZF+w5bc-7G%WFK72IrIYSGVW##oYdE8NeLDjg;(dY5%D&qM^b8(xMDW_|6 zfBU_Rw`&rjOW(}}b+)l~h>gD1UuAm+8j5B86CWZ&^?IWKZE5wMzw$^~%eaeZE{%U|IYm9i|Gto=bAAP#GI)`U5{2Os#>&SVwXgkv{y zNr!O8Vq*ZXqjaZbxk`NAE)C#)z<=L(AfwzEn=0YDu<_kopFX~NL6kT3yMdP%A3xvr zvci<#;_a>=(xQq>#*0h*5SSbucc8^Rq`J_0OC*6Spti5f?$dDOXXNg(=L{jY^M0qF%R?#-{sWKSudS4Rswu)Ff5e);GTk zOuuZ=%U*)|s>+^blGTI~*+EA>g)J_lmMvdh+N)z5x`&yG56<&0%wC|+&(U{<1m9cU z9aSR1`eYr{z+?g!%#N#k4}4zH&>{Is&h>sG&rSrPNGW*xx^||PcAFcZez<2DpI=!@r(uYizhk@48{{WC zuv}e#luThNJ}@C`D@|nmZ6oH8o6bVXtG)w}9gm z1N(qu+XPsiyXMH5rV{oKN}UlR{<@<|?e7n69uJQ%=dG=+Ii8(;D8!{`F^|4(!40p5 zzqI^Zb^AV@9jC))E1^5iQ2Br27}5%_?rL=4;%annU-`xWA!;o{ct2FhH}7wbHWLm6 zbRn&X+5T(feVwm)^sRuvo0gDf5;aw`R4(HIrv?)org}3sMhW~`A;9|2SED<49!gh* zz&BJSJTU#&U>DvNX24~ zqy~l+f8%OigDW6AYEdrrY_fcZM`8ksgZJ@)*@s->KkrPAYV`74^l3Xvs&zXc{(@*o7p}!PXc4+c)6ig(8wl;2Gn;6@mY8!f7 zoH$t`*T#~TT4Ns8zflZVz?|&y!wq1{EscR1D9rj1`%jz0Oy5F;=0@EGHP1m`5FE@@Wj-5-uTot=x1-d4O| z0X`RUde%gZ{Wh02{pG~x4%MpvFgFSZD)o&N8b$HP?z6pIY~0wcwTET1P8Js2&ILF0 zrz)GMf8$nKHEYxCS?7k?Bg7rV`bMyx4O^;}O!!kz$&T`Z7;qfTldm~X9zMYbsQ$qZ z`)4($j6`|vsT!_R^+lliG(>pJWra?cS$rtcn&UHEn>IZEzbrs&YqMr_OEc~CrT)r? z+OT;a6^1=)ld!AA0`{E5_u=dV_hn)f2-p>*GfLk3ZZ$3K^^UL5cjLC~@nUwO^M}!b(pV6lK2lq2BJn@!aHZBC%7j?@(1-r8_MliKw{$zQD5;6+#`xsq+H7 zkEPuP`-RjV8AN=kYB;&^X!}CUip>1juspRxgbPTyybUGtzYH)~X;VEX2QrG(r zb=)`qwbQ>^X7*rH4nW;6Le;wXCpUrR3+z#LLeQ@5o{({n&4#s?>w>^cX=ce5!(UpoFM&0}k_|~?S8jkTg?xm{C_pg;bi`|P& z1Tg9bu1fa7_27uB7-CDs$5(ij}G;2Hxxu$|J~8=Z~R+mRj$X)1A46Q>rJ zt85mvoX<->p65m~8xy2Y^6ic8j5P7Ex1moOib9h&k$iE{>kmb8PjP+;k%uq4k>ah%K`}vP&Y;nI=r+9p3xWziS`&x)wEypm5iZ>Ge4i$^9^~>Cte>^po07ee=s8_M?)03rT|RbfN;{ znGWb|PJWfZxJPC(*2yz$X;nX2=H{opSB3JQa}rJt&J+7jc> zxNpnE6Vm+mt1vk5k5!bh@07~>*PT-0$Y5B=)Y~7!VaR%#AH@F|)Ivk8Gtk(HH-Sa3 zO!DQL<0~zjjTcn0>#Ve#c#%4|tV)oV=oUm4YK9)-S%u%UMQj|LS3Q4GB^!J`ZA@by zm?=tZxBES}6vUZ*vioJa4w9^Nh^khg_o6g0oZO&g1BOqI{Ernw*u^R8g|5`|x3ik2f!QaOFcQ^tmu7L`4Dloj zZ(0@nfb$j`tSqt`^ojCA>+QF@y+OkYs!Q=Pc--<$@v#NU0P}(;Q_UQh!7VJ9NJ8eX z&0GFcvZ8l(Cunx!7m_;A@ibvUOK@?5^Lf z=botuWA*>yvW=PO50D`-hUHthL+$Pu&PjxIOw~}n7YZ>HneY8S-Hbi-prKl@+*8@N zMJ__d*z#aF0sm&{4;67Ehqe$t@r80mImXo;fvxv&B9EG#i zZe}^NAYr?Pqt3e;iKf+1^lYv8vPqBfc;Y08obEr}nrQ^|_P#_6@VataES&B3neDyG z!TX;dp^MQclObM)-w0{~3FLI2k%o9HCw>d>FzVM9~i@c$EXMMqrH8T7NRjWj84?2SB2* z1xUcNN9Jj%RQBqZ0}8Ji^UOd!n+_V>h-)*$joCE=9rZeC{4)ma*PP1hbs9V*3eG-H z@FTevbIT*EfGcg&r~;YNboBKQKaz$d&7J-|P)IH>Sn{@pq#1V{9{rd94)%1HXW`3! z*O+7>eQaa)OC9t9@Y;wGu$+J%_Isa?da~Qtn6je%$T1@CYyzm+r@E=tZxL4Wk~t<| z@e%gi+&xccs5e$dXNnUc@hj2}4w`14T`A*IMwcIKS}#^I3R$%X;bG(8&NZYw0-zRG zf*CGsH`ypoA;}{uhDNLA+m!}LBgl>~&~W4jiC3VZQ77BiZT`czsMp+wo!o zr_*`7NBW<=<*YIc^S{U`>GB$>79?M5Hhg7G-fG@!&u{kNbJDLaE zO#|#=O*)W=l3Uc)TL1Y||@eG$ZtfMfU%e2MZac1i9-ETP!*|yH5CD3$!3o;1Urf zSADoG;1tYsAixOinr8ne%C<0Vs*zR%5|_tx0!j~tPqJP>t!p8OTW7_*_JlqlseTx= z5UoZj3h*)z0)meSZAa<3kYObsX6jXHj`sydtHkU6vaqTpC9@1IwAjBhf}m>sOrjS4 zJ+b1#C8&@_oN&fa#vem;Rq@i@>KXk);X8XWlq5SO^;91ow+5BWJbsF9qn6>m00wA& z*XvX8{_)vN!(=Ed2U!?Kp&ly1(cjpeg)(b7a?wGOBB-~1X909WdKE`c@s-U?ALtmE z=R#AkrF{xdtBuKJxGs+at1d-nNB2Q9Etq}#JQv0nY=rMx=Dh1T5tWmd)@ZbL-oxe} zDsHEv#o{x#W+F?YtT9J3yxZ7k-DwMhqvyc9=pt&C&{P=SRQQ#JUxBm0cU>hUwh%kj z#>>9#c%yhjvHuY;bU2^5)@Wjcfy)2-g#S51-FgMOxmcHcD3EAb{10Oi@N&YHhoMU$ zSlMTm{4TqT!}M#SJ00oJekJo~hjFXlNBOEIVKWb3g89g-sl}Bo6y|(j>88-(lM1vE zJr4rlO_^#p@kaw}NLmRDGdw8g-1g> z8z>K*^OFV>tg$~tjj>`+t|zC|+?^aKL-yeWbKAy?(cPK2U&>0@D?E@kJ#LM_#TF!l z(%NpUYVvZ&R{SsYO?dlwFC`f2e>&5{k$%^;XAVXB3sK4k{|i9e`KWlS-$*SsAa%3}T`h8xEkE31 z9%^Q`gNA>-`DZ!Rkn(ZzcptbIa&1<&*={pJw)fLX3wM(0c!pm(Ztt@``X0i3XG?Z& z9`6f+f!dNPHW#WtI{H(wc84mSd)~JOGbi%Fv;U{ zu?dUd`X;E`TFV!`t~)sL5U6Yku9$ zw^ShhgzT}lKIBo+K>%jir*i~g-vWbx+uy%|FL#df^7SE5p0Qt24svH`hnQPc)pcmROOKFwAc9gB0y4p;xUISf#Ai``zTAe zn97DQP`z-c6ov*CDM3?CRmW7Nth~%RD;Aa*>-EntN+$jvCBtuu&EiM@*CNbM{;mGH z12dOQAT(V|9h;mDR7N5I02)j9ja2+Zg7=5c)gkO0f~5iT%f~=N-n(XK z^C`6FH;-7d>aQR}(3WUH2WuF3H!`C{b zQLGph=a_}x^FExQriu_<2Ld_#A5~spqG3A5Utd`j4GWWW)2f4I2b!99E zD(ZEOF^pf3-v3WEo0Cy364z0ZAu%MmDwZrQgIVYqZf^kdD|RgzBF%G>AWk$5N>5iN zelCng;C4c6v$iqPg!q_`1;nplt^r-13$PUMi~4HHdupQQd2J@?8~Rs^+`UMEuHUl5 znf$`VP-mo8;+w4&!>ewh^%58AN3FZINI)fL)KWf7Uw@AH!Ne2wT*Wpgg9!0*JS_@l zTSu>|j(ByV5avvy&uh;|od1SZ)#`fI4Xb3e4Mu-@#7f)xmg!>;BC;hGRG1|FC{e}Y zY|qEfwp|Pbv@0;>WHfg>2%63~$D+k*{0^m-bgAkk@lGkebF|$!Tq8blTW_T`I#odY zqUVC*Op@t>5LlW~N{Pe#YHY<+dyV^ThaRPRomVXMnnO~Rp*kkDWf}M6%H?OyS1GLq zvn7~m{L#aVI$Z}(zujMe2zJrM!_?U#@blYO=M~8jWl4UvohZ20`CL+H|%q!dM_*8X_(KT@&g_EAwUP$@TPfr zjjbIQyPX{!KQQkL`?sp8c!o=$8Vbtd9-lB|ifFs2u;`+==P<2^yh zUae%Q+jd7Oe?!SD&!bH5*=$$uSxvv2utdnLs`3|3K&;5IkPhZs9mrNCn)@{`Uqvh8 zoC=Ahc1Ssrinot1Y|EM0u1y5%gpx6eStN9}e8poH?6ZhjK@`J-IX3N8Fh|opYa5WL zUU>5r@QQ3ha6Gey^!ai@)ui&v{9l;|rCqmT7H?NNb`L5ehR>f)g{R+xCg#3*5~s`W z?O^pzU3_y((~{tMBm%u0iQoaZ2Jt0!SKs2iD>m~1Znd?$uN6@;5G6r1A4yvTwsx{; z+7FY-*I`S7Fk}U z#~~v8FD-doNi^FDxmBvvqv5xzlFWf zj;};YQ}%k@Ita1D(FMkEGt!k>a84P{XYRE60y*#Dz$PqG{vZP@*m}Zr>K8wt-zLF^ zI0@B46!#d*-YOq*q-ET}l7AE4ed|h@r0`ed&_|hi6^3{qLeb{(L+JE)uO)4Qi9p=5 z+RLnrb*OPNO@%9o4gux6iZ}@8&;8H$s?h?9KlPWkinR3d!I{4q)tJS^b&eD%xY=RT z>(BL=j%%;{u$Z)G9w7}bq|u^i^XXx5`aH0PwZ6mU%U%VpLDOhMH+_*%|afB^H#m)+<7pg6TrUt#)qXp*w2wIoLYT0pdB!W#}!B2F?5e~&kSPvfhw5zmEl zW0}ElUdn_ZZFl;qFOQBvhP5-WKEV6|^(PRIK(N4JzKbW-Ycyq8ln|s)af?`O2NqVMbET7~dlq^5`=E4RT-r@Msse8g4bE_1@CV0UD8i@EaE%V?zImmVwXY%E8{52$F(6N#E^n1nK-YAtIw!2KO}TtM@kD%*QePD?p#gdoS6g!A^M9=3T8I z+Iq$h_h79)DEL&rB0g;NC8|!)25uelDZjI_AJ5vu6&BY-czXOig^lN!DIUbP5S75M zeIXx7WuqJVCPipvsRcS$bX3B^XwRf3ogsshKPH!tQ~?_P^L-`J>kBFfdx`{)w)`TJMz37fR_K@t(WN047Mxd4Cz1Tu> zIhP4%rPd8X1Qzr;&c?hfCTD%-mln};Wkaju4cxK=e z!Vn-?5ftk2sE5!{s*QTI@=iZuuPscI!+g{;ixqEu3SJj<%N4Mhu-#enl1`IcW?GiH zs?n2tRw4g?LnI&1`ADuW!h#ABNSZKCo=b2F&=qFYW0KK_WbDjnUrJv)Z_wC4Eu3v7 zH~Z+3`$%f6p+ule(uF1LlOtG!Eh0xVnWCJrY`H3)Q5Ol!h1GbWR3$D!1@H6b`}qpn zFBJy1jEwtR+si{&7iS;WG=_?(#L^9n80NcT`Pud52eVW$tKbx|va`Gwi$n$^8ne%O z$%Aq&LJ4gnsfOSiV$#yl%!rmh2R&{CpIrJPHM?XfzX{BjoBCgVZAx;vc|0yr=+t|7 zC=zBv^k%8E7C0JD+a7^1Zj1`sM8hs7d)}*3X^LZ4suE@b=Kw?%n%VJj4Guv^Z*inMgFmTEyD_5;!Z`$X{9KGV`D2fpq#>o@qNx*|pa<&at=cqx zOl*Jc@U~JovD4V1XaO7mHs^XPYF1MrK3ydPJ7Y0w3eXlV%_|GhzeDpp{ffKSPbh0J z-(tDLph7*Q`pb)n`(jvX^AHlGLL(|)@3-w(_4;8&!8p}E*p>aOD{o!(_Iu_i3NRE9 zepafLkqPBIg-)EcSLfZ}tg^4%Wu8$FNiMJ%u4E)2smI|#n2Gx#9vJX`3U|TD4OV*yn^YI#MnDE? z8cj2^10IV12>SmVe9W;}1b1hFb7T>>IUXURpoQarC2Z+F@(%XdNeO&V)|px`rhZaVH^bHW(2Ol_)XCjeZNVOY=!bVMju8)E3{f8f^)vZ8@S>E3q_b;!* z^*r^VT2bN%mE0f(BXVU;7ZX0g%S%gZLqZQp^+&JMz4Od1h)i_ia!ipVo7RF+saeAo zCLkmrW$ifjC8&ob`~%EbKAtQuJbvB>-u#YUwlmzw+xlBBIWa6mGOn3GiG!pw#owIb zbeuF273o)DbO{Sj1_>6Rt?XnYuGTZPw80^V00RtTIF%9^)g6|oa;n`1jgo!wW?O$x z7`d=D(1GdmC#kCMfl`7cXR8;TRy}$rN58W`7AW|YZp~qYVc?{}1e6K7`2i}dPAvNzn_w$ch}0h| z9ILFEXp<^kNvxE#Dy-j?uU{f7+xjc}kzKs$zf&{{W*5R&cp+ ztj=7PLVRe?Z{1J$0bVHNW%HD6UVNf3{jMe{a!ylHMZWBIICG=MPQ-vf2{{sh*l>D8 zCiHZ@zQ~~bkL#6i89}eNM4tWb8BubBRE639$~!~913Z{oQh3cASvIMfNRC0|Ra0OL zSKvpNtmnZ1RFCP#U5M&_XYaeKIWa+93(8N4pI_Ew{Ed$Vg6avMnw`J`ALDxPA*eOq zQb9i)ev}P0pLs#NtnFxbPUgS5PD|5CVd4Y-io`Q+m)`LVCfa;zAeuS;F|KFYQuN2o zT33#dQn>47Q!hpPvuI!Y_nC7?&R$APbN4aT&)AT_2-zs`?yG(BD@ZE25qWdWZF5R$I3Lq|M--o<&aeQ8@qF2B9{7StjIXwJl?cmMdKQBU~ z&X=F}zely5{_=OOfA4htBHp@zk!ojK`1RQ>sl#DaMmURy248p)4wxL(@{c=KEnFOCdQVi6P@hvkkt;@D;JL%xsJ z-U0O6G;WIe(=A{W^*A+u3rp7Fsh8ZedtnaK;+*G}2Z@2D7r6toKyOr5RRml?$3d^Q zCT(!3A!JXWJ$8qdFtbQjwM*Pm-&FS62Vlfx>H`m$s)QESz5;Mv;nFoRYwy=_zmk% zHQ(75$QzrLmFUoJZuxoDw<(5t#>?MQC%#`>fOH<)mUu+vZI@Kz`?U1Loko$rMdl$c z4#;{C8apW`G*oT6iMH7f-k5LrRC`&ZlwW5>PZ!KQDN@Hdlfyu z8iFB@BXhoi<5zqOXBcg16JVs*SJ}vWo8tLw4%{8DlTukrG%CLTU}}$2JG4DTm}%~A z(74dL75ir&nJh*wO;_LTjQskZsy=&l+9X3aY_+yRqsePfvHL$i89u*5T-%sC{#vd{a$G83O2}QOI?(&3`9HWxk%e&2x4eLE?}DWRWqr88hRrkmP8+ z$SQA7rrVM8dz2u^{h;epd;5O@z4uoQ4r1TC3O38w!91MSQPdhzfxdw&d2|(ze@-K` zW7!H^Hudj8M$USXy(am$vu`&ucRuNCe~Pn1UzJn}c+MScMs~E2A$G+v<8x#gW;#im z=37nX(OYzMt@kD|Fi>nCVc&9U;3ebn^5gMj)pk-2wOk1%XtY$hw5lIi zc@g%y^+-s4G(}PWy}t((DCX_A9Ovc2_;W%T<;TxVDCSEt!vFKn3nnCB#@jrY0H4gI z6yBRcbF4Pa)ha)XH+02AX?8qkU$yq*R+i6c+={+Z89z1aN_d}tSPmdW3eu%T=Hs96 zBediF_&G*R|55~%WzU^Pu|!zXYS=`UY*cgG|NJ}N&Ck#Gn1c%1vYC@>IF`g@wVh}h=~X>%EOUAM0?Ge=Dm3D=$ujIyIcgE+pd}*JH>0t48fv${GINCmSTkqe zcH&}h{vJUZ!nAK@s!eFirQY%Ty9P%YhhnzYINXZ2l}y_rZ)`0^2~QR7o&#l)Dwuga zTNY(r{ZT20&Aeo>^G}iFB5x~_*TM0HjA7|`Xt|4>bl6c=#D?KD@g>kT;y+^34PUeK z#*Dl)Lho{YD3Hu|q5b+R zNl=E>R*{?Xh}kJH_64;48BQ6D>2@tGYs#>DWw=mUMOV%AlNx`^qmR*v1N{GxiIB^U6YH3?AT*CDnkH7p zfZM3SSc2OxGqoxy6^*2YV0sGY%I}z5eyaSy0+0*=+cv@CGOT0WC1~(vhHROgAqSRS z0{mf!H~>qW3XD!4`+jYPZdpQGAoeY?#_nCq^ZVOqmX8bgd@r4dvk8gb*T)}MbiuNB5Sj=7H4(mnoS;}G7$Hjj30$4X1mvXbb8F1bN#w{Gu-~^NjMPYaISsU;B_XTGe$s^zJv9iNV)}7DWAvoC`7IR?cab%Vmz@{B zAwZJ0_SY_EvsuRDgXh?ZYa~%X%~M}83WMyqYz?FhsYm>5@i0ZUG{WL4F(ULcg|y%N zbgmuPjgb=xfzCZ=3nS^DZAW&t!y^YWugoXO(gVKMBfVY117%^LVq<*C4JdNK+hx@>7ugwhC}R{b3*%_#a?1Q-E7RE z?F7SBHd#vzv{e3&+ro%P@9c*?&5}5^%IV%ICZ1n>pr8`ML*wp-@H}MmMQG-`9RDAB zQ87tK2HyhHI>WmjF90yji@7n#wC(p|7*!hx1eRqlR$z8KSsqJ$ezNOQz{--t+biH( zK<0WSLtly}M}(IC)`vL@?wh_Q@}hea<-#l-zH{m4ozp9$>8UAd+Ye813E&4nS7O^A zkC$|1LI1$A&0fPWS$_jfr*BcrI`MFUf;&Cs;-}g?pWRX8#)jha6#Flc-_J+UD*28c z%W1NJ2M(cE$9`%O6CP{rQ`XZ2VG79UL}R}jR6F2c8v@KX^m|dq4{BcLL!h{jpmTaKoF~DX9Mouv*WotQ?vIT!Sev!TBNm=|!i^*PW6-ESQlCZSQ>AhrT z;?8s>nw69hAS`tNm0snrEckp;>gHoCSUafhVKLrZy~sUoZ}e($scR6O&o<(XorjD4 z?Pc#WJC}}JTAXNmE9!C1J|jT1bRBM8iON&Dy?fkzB`vJ-Q~>lJlO}Y6F?8q&Mut&lwJ z`6rrnPVG$`GRQGQjq6_8`IGt5&AyCH&CL1b zcRn2E1Gdu)vyE%~L5xNb`0ig0Fcs2wKFf90nt2LdT%mP78Sqiz0HW`rU$N?1oPI)w zL_<=PTS8<0qHZfC1?V{;Rrlk3mmRc4Q@t#clsIRD)W)dJg3G1O}t_U6^od{ z;y``?p}2R}X9b%HY@3JW#bRPlkU&q8NLzp>jG+aTIC zb;irGQnR+EZ&h{{=VbF_?IDq73i+M(GgQG;)>k=CNxU|AO2~bMC4B;}H$IlJqY)s> zVph7MwjX|#V;|{_>D?ACx4TRUPrb7{Ourr7^%+t-D%YWD!MM=l?Rqsd(%34Z;>for zwCf-~QkQEveJ33}bH|r+;U}86${;g8OJn<(?B_>!BPjdgkzaXyqWB1xk2BvuyP&yx zz|D$C7&gi1_Wic`Re45rMhUtkXDo6B>bahr=dDZ7TAzQyZwp}=lu6eFQZM$X0pE6B z6eEfDzQpkEaH9_x>!;S`-=nlP?h^yd)#dB@5*_h>j<%3HFne7%{fJZPO}qzn>Q6NB zpO-pVTzI(m2vl0oj~;Zfmlx-T>V9v0yGNGGGS>P|6n*LgCr5yhm5-=)6T>*B4x0eY zKcm%^u-&ysNN2LngRAQ%kfRtt9UKdN6gZ0043tbSIm5}g(W1`nH)1BnSFJb9Jzi}* zk!JFpADX(qig{9I0y2qOd#WFp+LLRBmvv6_y7!Hwu$0g9%!YF!+kLHZd>Te%8Z~R* zoPocBeUAI=sC+#G?uDu==bKU$(Hj+tJ`66`NUJ7_z%w@7@orou!w@#J}0uJGs?c?ed>46M>$u)JfGyfp_CYv z>fJ4_X#XWmDe*-G@w~80#)gnv#!S|_khwz&r#=ZwG)Pg+5CsBMhyw)PuiCDBOA7x6 z>kv%V9c#b3+Mm9^A1Wv{sB?V1xL0^wbR2k9WUy&h7WB7q-(4;rHTM^+0?;qxFLN1K zIu;eiCRXY_G70PbO4j3MBp>(Jvb_$kjO*vOU`4@9JMriKWorv}DWeB}G;?Qn2TL)= zzJHQ?)6J{V*J$)KbS7?sGOCk1iBW`pH&AAnP#u`)hP{lvn}1zUGF02%6lhzuALP!B z#neK*0nY#35eSUG~0D7m~QNlL@}d#<&m55nn}cc%tNVp6#NdckNYZw{%2|EdZ! z(J5Rd3RE?xlIE!VQVp8y8JV4O=R(eMUB+{0tr++XE1}=(Oaj=%^iiP!B5@CDo@X;%-!+}!Jm&0?Zdw~09s&D4)dvxf5ZVzU zDi!n7m%9r#2*G*}+B`G)_Zod%fC-nLeB7h)8oHz~l%C<`gbNj4BvZ_|j*geCi%``C z+LJ-orgOxIAIbL8bp6T{H|G}^mTSXmUjhe0jSQER?-Nfk?&*dC8Kmn+ZZATR;6;}u z=1wm{BM<;M5<9mcAz>X9DyqMKmt;tw`8R1yF&s-3aY@}0OM$!U1__x#WHmoq9OBsE>Y{i0(@R$S90siOc^o{^ zb(tNrZI2Ql>lRE|&z8p}(n(snPyTH0KKT-&N<{cAI>fqZ~nKam_S%oL|ICgB^ zm|4nA9g(i4%09OLIw<;L`beM5wYj@rj#37{hr$906NXwc71?fILYP5Fqrtm=(3{OW zbr1P6vmJ^vSPKbp7oz~bhb{)^ua2ITf1U7dHLux|+R`a&Jv6{w(~8QiBF>)Ng%?h0 zw5;+O3lv;1xn%8YGumy%Q-oj0@8hdajSwlr;A(-aHV~%h>1@WU7`k)-_)C)zwz>Bg z3y^<;Qz*wzUEGc#5rrx|M+@%4*+K~KdWc7}y3Ryr$f&!kjhN!kp3eAIc%&e5!w_P= zmUl^$b7KUyu`enAl)gns{(|O8$tE*!4=&vWHmLO_uzx~`WqtANRfG5>(ncHg6jhOg zQenCeFoMUF#MM7#pUNy`drq*aZz=uhZKy?Fugl>RtQ63J?t?^x%mRl%P6z| zEXs3pk~gOPK>qZr7g|U)<;w!Bzn%iuDWM=)^oqEUJqPZfT0Kw2a#h6DQ@Z*tiU|!JR|s5JM&gOO1MoZ=l=Ezy6owJ7lH93P1BGx^A!c( zdwbZwr;;vBQTMFD>);xMel|K|S0!7%*nM^}8J#L=@7*JYQcZ`GJ!|TP^0P#Mo%?gt z16~+o*p}6qA3Brc zu&)Ir`FVKvJG}^1`0sw>^GInOr@lXws`0n0{QfIP3HMb1GmDTD2q5d9mgVj2Phs?NW#HuJ?!=`fu}(L<V=UB!(oi|SqdwpR=$0(ZGN?)E}}M>_JpB({7t7WwA&@*SZ&Zy%R_)ePPZ zkzr95Nl$D0P$)PeEFlB6Mw8n%NNkL{JTnLcm=^L>QJ>5)DOitbYk!aM@OTa^$4T9M z%(X2Vn4_rl3_D^y_dcZZr1T%K&kW`2vAjcjJG9ouU31idmP@c~q!51(WBIcV+a&yk zcXCVk*Jg>gC^{6R|$A zPds1M%0pz};(8ga$cx9`xu`gmb3?Zd5I@NxE;MDsO_6HE#toA~3^CbeM^ZhZ_WAfZ z;9jq}>nye|*l7o?il$2)HRRssntsE0uEh}cqR!!@^y=x?0FgDdx!-iPF2+g5i^^Lov(F zlkg5sFkK@<1hr6T=ondLA&cKM<8&}cY#t3U=A9X^Y~MgXhUw?}SB&Wrx0IA5(i_Wz zL<*^>DZcN0GqnVN;v-lz&Cho2oKKA@k82g$WR1ji$@JmylRy5967;Q*CIsrw!Njm1 zv^|?8dPkJ4XFRGnEdfa~WyJ}RVX*me@2mS(OI)2bI^{6T9$NW2w00mDBvWyS^LpDy zjao!uUhiX>d5?Torpj^OV9dcCOVVcvoSC)|d%EV@rs51+iORFaGbZ+)WFs2FmtlY2 zxum&6?%BrXc_oT_>3^L^RcAyxW&W8}jf@h2g~&k7x5TK$es34b5<8Ct`do&hs43`# zgu_DIB|t!L`{}v}76XBUr=u7U3x=1NMQ+WY zsqNES*fG_-#kDp2ch5h+MG;2UwHyc2vf65ib1e#l=Zm#d@1`xXmMQ1j#TSj`Tr?g6 z>XeU$;nS@NXCo7=UtWGHcqa>PA1-EG3@bhy+KR3nmz|=s3aAUDZ&Xkr6c_!XK+&dP zh`h$e?UgGAm#<;jv2jqs@}rp@;Bu+hd4ny6^oc` zL#uD&>O^7o_MerKq-6BI%DvUris8xbvuMQ^_il~b6VW7N<~^n;t(b$kA?3uY#W-VW zUBB!Uuu?|VS)DhUULD1NaG5lbgSN@En7*Z%EKxBQqq-L{u!}7>(~k zU>+SpUaxzICSx(n%%lMTEK8ZFUdUyntJanM3{Sz>QY>G>Ead^U~aKM-iayP?{{ zB5nVv8!00@E?GeGvIvK{=|imyuAUJ>M+xtz{XYS1wmIOh-`J?jtja6A-pd;Y{vLF(8nji}Z$e}t zBk|Zu)92#jeU*gs;f~nB9TXLA!)zhotG3MPgmhk_X>tK^?kxWTX{K!5>gbq_HRSx< zp;%{Hvv9#by>CrS*Ak;O|6FHFApx2DNcbJbPKVb%I%5TG@YfzIYG_|Rd`#}s+OuPU zh`^B^8}_9KXUt`C>{JD83W)%wJ*cBM_otg>+nK4`72j%6XL>Mhvj^$MiT(2^XIinq zr4ZvUA+HXO^RY_dbh384-w;%H4fFX{%L>tV=o3S^Jg%L7eg>?cM!sNJx9R};$LI;T zKIc4V#IM8u?h090Rat<6pZsd!5N2NCBB5ptBjXV741enSl{c*Z$I!;1FrXF_!i)(?qy%pC>l zAGKrVeYyVnE#V;`gnOD{F)D6}!^;2rjsCzM-tWJ?lseW+7=$YpELI|pg}vKYq%DO@~< zdNzTL-_nZ-+!Z{AY3!Q-L4?llz+;LQhwimXO)Ilgf%HkKZO;iqn558y@=Q>!Z&hE5 z|L&xd-qd+hCg!vVlf{|jMoHjSgAg6_@$QV!cn_exd&9;Fjw}KFCz!WO%N&*;ztg)Tf z0vO}3Y(z7I*fQ;=8BNgM>mB?-sM&oi3xNfNdid9xYY4wanYaS%-0!v<;j~aiwCW}E zKnr}V*ATf+L3o+#6*dG}n*CqeDjYdPQkVhhi~uO0R#miQtp@y6i7Kxo=F3)-4+pNV zLL-#In=i~PA_cd`1|-OcX9mHC2+18{l*k~)TD85n_crl`?pP{EEYg&h^rQR)nWIFTd(-&^4T*A7# z1za3Ku>7ZmRa$bIKB!X)6K?yK?4CCmCzery6)5DH$fFW6VluG0OfH@~jGlV7AG$a&PyqnG(n)In#WO%HSv{8AKLBu94x z?wP?vXayEeOgPJur^!Pv>vnHdAQrFSf=#H%&=J&Wb~o~ySRUvt#h=bAs;}|9a2U)f ze!-lt&h1-2K=)T!?pN{{rXbC9pu~!cAD+3b>2!zlcH3$!(Dfo;>&wVF*xa8miQ+vE z>p1tsVgH%0#*~5;ZB}Jaj8JH{_l>B0@$cu<8xDE`oVQwO*4T|@*^hX~ZHb!&Pb8%B z6lSbadjG!`pkFB$S217Y!V=;Ilwaj3rThX(Mup_8ePmc_`SDEkAbp#ik|;TzQJP(h zSj*Ugm)Y3UrQQn^^#LBk(VOYsh%X_rv#_uH8D{8UmZoQf zV(t$92@XSc<9jn(qIaS@-{w>%rx2MU$8A{HD1fW`WuL0m?}cST+z_c+j7HeUiz2y- z_o4lt`U&2jMBPeYa+aNif=Z$VFlt6rL!i$Qe7v(47HSev>?ewUevcehNgL45@;S?} zfo5qe2$G)2C)hAcET^%1u-4A&wzm47^5(}ny>7*R9Xev!9~I)Juvq$FH1>PpyU#+_ zHw1+^2CxiNJSW{e_vVT$Bakd&kOKg=uU+*+W#k0{{SU*cA84X@<-f5jFj+%GdJC{x zEsdJ}zK!dOG4+K7^lQ3I(|Bg!8W4jKq+@p%JiwjLM( zAS}C$5WWUAW4`Bp21I_rg0&LqWtlwOx2l77VgCXiEOdnOncfqCX#!Yxb0{27F|BF* zgC9wsV}|RUP!*S&awu)h_L2S7vdR{(3AS2Z7L(bJOVaV&+~`f}X-T>X5>HfXk56Ya z^;sY`Pk)8{37u5`XjnT<&I+yoRC=3JRS%G-fzt$Pq0ly)hO?>oEM`ZS@6S}*rT@Ne`a@Tb$blPMX@P?hHP&Zjy>AR|p^(g~uRR%?C#e5v z@L(9Vwhft5e57LErn^21)|^T|&+zJ<3iUdi@k0RsCEK-~6y*E4btuUew37K`Wx#xV z#)mN&k~1$yUNi0?XE{b$p*WF((#{J~h|t4-_3Cb8=Ri}!33A?s{x<|;%r6Wp{KFgS zbAOP6ySJ}kX+Xgf;NrP#tGrWY`MVgR4@l(E8Kg*DnMxX@H+5K*vibEs&RuLLQXVlV ze{JgHd>h;YWS6xiH0!3lOHEqD@4+0_BezJ8-CY<=VvTSkWAZvzEP(giNre@B;Ffj^rtyh=(^m@sU>O=W*w~s)d4w4fL9Xj%3Hs6xLmA|q4QUk;pE zTwqTGF#vr?RwB01py-w?6eJS`;|b|CsOyLD>~{!!o@Wqr=|{wgCVWi$HN3{4Km%C| zD18!x7Eitt^9O@hObGyJ-mLs*VPTLq2|ZSxWTUta@dH5_&z54bA!=D|R&c-ZayQw* zzyR8^;p7pbCfd@c(w~%(x@Gr4r15ZE~?t-TcZyobXaCFhS7 z!0m)zAe4 zmW@!2Z#?jo1w|QN|^5zh)ns2Mp0EMVjxU+ zbhz-X3$;q_stJYl335cmdZxsQO$o z_{>;)rM;@d^3pF~+_4V^+NGHJisT@pN5BiIO?OGa$TSn?x8J|xBVEqE2_2N@2xmo`+z~KNW1G#iX;R>qp$q!1ks35`uFJ85B6wP8FD! z4C~yM+Qduaw7*5Ws1qrjQV;H9w#rhIyAXom46lWjC1Dl@6e zGBRoL&aEx9ccx9xG>V5Bkp0JA<+wr|itBLq&ohg41*Nc*HKoSWjR+WMh=a0?Mr62z zy=j04nvi$5L(h&0Le5m1gYe&l7T1``o{W1l8amrS@w2R_Ck)YDm<%RYw9%iO9N|0) zz^Tp};gG_{{<9GKqAC?Ff$~a5kO+b01kF6RyxAt>!8X(D9`xl5%V&KMC!;*e-e>f> z;f60yg~Ol~BNHeDP$%<>n`X;z0bz$cQ7@ox)_pbq<$P;W{EQ^dDc`xd+QS1jbK=N| zf0TU14j;q%pi!gg?Xf;-;Hh%>ZIe!v_kJT6gZ~}D$P-CloW(mm(oY|tneTzQ9b~`= z1Dj}%U^%~;t~#4F#+WqI9a;=AxKsCSMU~>3WJIW4qlcg3(rcdy``-EbysgV4T0Z zgX*yP5Jp%{NQw${dSC@==%Kn$UHWQxX3mo$H+C@5x%49HxbXEN+5OBc6yCOQ&B4_> z(FMHG;0Opp`;PFF@Nh7z@3^|4B=Ia&ZwMCvzWw>nXYkeFXtn3tQyzE|U~;eYrpqIb zAN!Z&((Mv{aH&%6LLkofaJ>|kcCGnS9W`M|aw0938x@-VzBaxS6GI9a5{mC=J&a{c zQ)NAy*a$*DBRJ7Ktr>c^82rJpxJP$_*Z` zw_vuF9Ii#Gfr&6n=f`Tv&~s7Wrq$u)U=G*D`z6MrvfL?UIi|n&Qc<4+80%}>jc%G; z`zC&V0VLJU>A{txqgXFrJ48Sa!yA^_T8o3A&sQXqVoS$v8sXKjTCuqch3Sxg+_|s? z{_PLZP^w{%Vr}r4m21=*6NKyM)0b*m(ZO5w6rBtqlA3vl-e4@HMk6>)^9n{Sz8OSV z*&~$QJ+riN9^C_bpNQXDy7Db%C>9IF1Vq@;-4cUupkU+MI4`q^V_QF@ZS`2=AV?lT z;e0d9q|O>|O+w^8a=|3TND|T+g64@fL3>bnQ7Je`C|tZaJb?3Jw>1N@;oaPbX+z!% zt~~5+5fZAudWRZ>Mi>_jUHnjrFKZOtdCYD9q*H7w=buAdsjuzTVcZkc#OHzl{;g0W ztbfn=4t!BQBk2Dw0SI738glOwGc`ANBmgmn!~By8vv zRb%PrG}&fPMxSf>xDa*<7tM*sROxuN!8$h;Fw~k?;f9iwiKfW*(uH0aj`x13yFlb+ z*VcK;I=D$>kbS#s*J`f`iPve5(6B>?S`snszq;-akm@08W8 zd_Trj$k64{DY20B&3~?I5Wd64{v%Hu6NrkN2E*ritvzokc4E&uOUaWly8?xHr_Lxz zJ2AhfRAeDFLi8cu+1i|diaWEb_MH95Nd{|E*%8IO*eP_=;9WZ+)LZ9s*@>HjD^>OZ|{mZ|jc8 zKP(>K!Z!~sI`j6JClN6~5f;6f;d(i^Ja_N`3J&>0c+35LMTZ8$Og1GSHbyB42wA$< z;h@%{A(S!EzCymehz!4XjH>0wJHLsWMCR)<-BjK)Ku6FNly!DT^<&yTNczTXvy|w{ z=Yq)QMba7P2ULzA&G2o2)S(F57Obx#H?a~~pHZhCs^on)Lqg*`knV9%5@g9NN=byy zb#tzTqF(8sm5JZX+kD2Z7XBt2LX!r8ul+<{HHd4>g@1if>h#YAMxphPwpx%_d=#JP zT7@9>txZpK>C?GGm;+=5LB#J!Rm}{2UGApEor}M zQi4?z1(=1&@<$6aF5AiF!_?{JcVZew1A2K$={gXFkGtkb67HL(%QY*VoOH#{yD07K z>a6HZ#p6CG5W^?8%HaY{#%tZJ(*F_KDDx!|c)urI&KO#-P=Ga5Ex{(Fnv64XXlux= zko|y%6bMSj1HtD+A#A!Ibm(8xuE~-8Ir!eUn%497>BzgKA26gPB6FypvedNjH`#N# z#Irka)EN)B2;D4^DU>7xNplUasoMr3)paQZep0QgJZ{I!AYT$T^%Koc2{{5|j=2>h zM{W!K%&{aQpJRVZPPw>-(+dAca)){6%%cjpGXOxWKBc8Xh-^}&`ebvpigUJvM4ag_ z&k$ac?A2q0enBQF91-~SXd(r^cvFa)=@}5YKbIdt$c#}Ki+z`!{Awg1@S z)Bh~DX;}s0}g(m>J!qp$gTk<2a&oGm0wD#Y#(HNn)vnv(oqalY44j~ z4{?%Ar*d{bewG1+in5cZ7*a~sbg)Jz z{ou}AR#ltoL9o{0LQAtqguLKMt{XHBJ+(GZve9VyX7`c%zB%f2vArZ~pY`{!B>lG8 z2KEcO(tUwFl?&g&Qsb)3IoH8b&Z)z_5Bqa?^A1`x(={kato|Jg`OKrKm!vNos^0)o z#!ZuZGXtFhGl1?f!66DRqjK_yUZK(!+`793cen`cF3t!9iGp&@^+ZttQ^;Qqy0N=& zB?}A#3M~7cT^J8}r`}2H=|ys3sP*QZ{CzW{VIgDzQzGhjd?A6(dBu@uSL8+MKKs6(2Q~-nL{{3V0A_(EE^uY? zQ$g*&9WDDYR>4pJQ1g2B%I2>WQHabh^gR8N)B(=fJxQ9sGV*t;$Sj1N`0{3U*OYB` zfaDipJAInZnK1BE{R(ZR{!+i8!quv#@w$Dm#*UsNrOd?br%TW~)q*YK&$!>@!awwl z7AWxwCJVTYD>Ai=XK$$)sA9koB_J0Rr1M1N3#o+C3X6QeixYs2z4-TPcE0*Fyw=`+ z8o!7GV6K(nhq#l2tZi%SAKR-0Ra-%~OyUJ0+0`4RhOM)Ja~T?BvR6JJ3SOcf{e;*f zZ_mp%cQm@(5FNlp_K62Ee@LsSFtBq=6>Q>CxLONok_-Y-is8Z`;jRJ7e;Uj)RfIh$ z9Wuq=lxQ^Z2Yt;46JhmK$Yydt6$d2676RSHoiGzGa?a9&k?gtLTB?Z7_mXHF$AIs( z*IOku4M{pLw^f8yaw{qd`2lt<$q84>hg;+i3}{~6+$8P@WoqbKY>;tLo%?+x5WB(G zo=Qgejeh0!gxb*@MHwlN$)Qm_sOtEgWNoS+2vyG~aQ>IJZbJgexYK(@mv{T2y;kZ< zaY$|;bydZg*olPgU29tg8}!55up9X>BpX(`Z_ENh`|1q=V4pHG8jWF(a5v99{N>5; z>b-X-Wyf3Rkuf+!mZ;s*=|=I6-w_m9-I8ovY|>u!sKCFdW#+Od*U;LGy+_DdtC7bw z#!$-H>=p3F6kFmv8mX2VHG%wTi>aA|nXccn+HSx8Xztj3fz3-b(e3U&A1{h_U0FcV zQ=#MddaKpVW%d5JgkM{Gs!Fz!Mu6>uveQPgt)Nqi<6<)wu#5>P=sCF<(c8X<)&#_K9VbZ$NnadD8-=X29JrmOGL|q z`H}42F13c$?L$oRaOvc$0Vuws#-?VyxxGz1_GXaZBp^hxJo|?%v>?Gq3HtGa3i?Zr z&urT)w_4_^D~&^>&~7W8T)V!!4^6-dDZ>8;9Fe!bakcH?1~Bv^km?~fvD66?mNB^e z)C-=k%`PO)${c_lA;itlwW+Stkn|=-UJ|;b2{{@o9@UM)i$*3<*+s89BZ3lvk0?=( z&1fF8i9#z=WJqLv)&7^jxL7!uy?0ZW6ijLn#`bj5*XLqv?M|W|bo>Ya4;IWXUWlcn zi+_AYLSG)UA+Te#OdJ9QoT~)98W41g2e#1Olpki(Eree!1RCOE$vZuD4$Ihtio7U`ThJAJaf{}@TW}RvtTer+PPvN}K?Soc4SSmN2SbOG$$u^Y4qHdZu zbibQ?x-aqZD^~{!a^!HCI8?!!N+ooAVSKm#yu)vRaF=@F+5fD_raqR%daAw(~ngsV8AI^@G82OJA^G5|Jh zDRIajT)YTsFzJ-nn1d%nNEk-T33!aoBJ-0nla!tnwtT46ZQL8zYl>_h6>0PbkkbMYP{iNg)6LCOo>J*$%LCV#IyI~13hsvg9Tsa4q)yto+vAk zjCF+WN5ex>LrQU^M2;&Q6TX%($;X9$QISD_g-U5V8!!|7PfFx(!PBy0F;MmL%*MSc z>Po>8xCTa4Ds=c)3CL_q`4jW$3)V7Korlah#~A6r_psifZA9QpQ=dXgW9URi<1JpOZ* zp}pBj7&y4?2s7Y*RA3Sd-k9<&tyLtIhC{MklGRv`n}B)VLCvl>%Vyih!GjIasq2VL zNb#80zhYbLZT$>$ESk5%aNiLKG6aH>`%y87*(nBp-^#xy+GSn&xVnk{bY8LX`E~v{ zFG=vB0&Hh&qCd>oR&PSHyn|H^V4g?Z z5sj#D0fOXrLcQW)^`+7O>SD6BO$M7g#p!v}SPh~%u>{V+F)(jL#aVjxF))}Eor}cHTcJVNY+|)%gMKTSkyM$mU z?qKYqx3GrN)zOCeM0bd}?Qigtn-7;`NE;qG8l1{Wvmf=+aRk88X4jm5QVw zOJb>vnMWvS_EzS!B&_f4bo3qxc2C8>3V3l=f+1D?!kh7>X^$1iJ<`R9hV-S>*l*fi)`$<#6zZ&l^2k!*XY%%~N3IYgsM`3| zzv~95Eg$$I&-#6V%>*qF_^1LQk*qS0Q_dad3T%|Rx_v6hZruY_0BPIexIyXkY^()$`MRjDs^nW^W;*dj+k(-pJ*r5uk{|FDF zOdi6MZ)!6s*`3!)|G=0*a9F~Efl_>2kTHbBNsG->1c>d<-k)>o3gBu1vGBdnoVfx{ zLgTei-rA=jC5XmYpVw(n6_jLRxQ7Ww+AkWD8f6kGC#R-M0!F%~JO;qs*Ys*sBwE?c zE>007f=$%HgEae+rgY>edm8@8Ad(f_d_Wr5hSPN{6&ccXukyfYAd6?B4%=p8LgK|MvM@bza}|IF5^$$vk{wGq9~g z8W+$%p^q)w{#+ny)zi5?U>o^$)r}s(m4`7-@a1`H9G4Nsy5OJe3zya}$uBOqPecpM zE!iZ`licxKk&;b7?O>xll)h<(Arc?0{&%%8S-MQzdE%fAbbM7`Pia2!EW=f~s5hma zh2qmS0qJ`c_OEkiUjVlw_l3tBWV_f&oMe3sp#sIA{P^L-Z6J)YZ)r1P`x>)lmF>q| z`i9el%cD9WNy71LI{^s@^x|PWqHQZC`KT7&|p?MRnsR(k{}PAvOMQaI#KzzO=p&>Hr#isy20=I5Co3O8}D7 z71Ojpl!mc7(Ee#U)`z@q_|As>qD90=Q|X1ZIBBesfW!eXt>~8g=ug{i1p8G5TyqS$ z&~KQ&r0d7an<4PPOdJ*QH+wu;Bao*1t!d|0ug;0vobIeg=Qp)aGYQ^5!KhWs`97y2 zk2toOmi%)Ks%E?t@7Kw=+a=Nlxt_liDsw9mBXhZ;k-I>WYzWR@=Ov`w zA1OKz+NCca723BuUo4V%N;j1JGUvjKCd+bft-zQSsHTP5^b;3T4wqpip#K7)OD{!3 z6lApvW!R)C8w@H8G>nHo9PiJl6;~gJM6bo4xO47L%GFsAK(+|ebO#bfQ=_dMunE?t z+VU03bFm8_heCnCS5x#=;(%b2nsjqb+XfQCX+-8*{2oy8OC)4rJcpZsWpJv?jj${PY2e1Q5mY8Bi1 zLKvbhYt7>S)a}=1?O}e?0a@93PQ(gLtbrUU<-d{C((k zZ(%ew<8npC-8^T;ccCrSw;ZWl_ZGX# zR_gJJFEk8j8j9(Fi8~e3f!6O%Rkyz^ghsvZ+UaTc8F9-2`0c=kyS?l(8SwLL!U<)r z4joBS7hbyl^1uBE8i#Y1OS>%hX<)Em(4L4xTPbWB+d8 zkmm7#u|nJ|cesY``u|?(n%Pflomz(G^O18frDwg%pseELhY72fL5|*(u51pp#G8R3 z*#om^37aCB5w8@8pnK;xzjGQLr-l+@e~N!-X`tDAFCj@OM3>g3Ox%~C;g10bCjOq# z+RS3|pN`M|^~SB*R3rGqMI|LMGY~7d+j%rV@#=<3IsBic)~xh%W7e>O2Mdc2l;34$ zDf)ea3hScKArcBtOj)#1e7+-oK#QJF!O|vgmG9+a`itU?Mbrel!hWEcrc}r*s7w~InE3XV!ru0%zF7eb_qT_Mt;V4b| znP;MIA^?p(gG_VMm39dnO$;POE?*Hka(X*(iHQ3L?*8-L5-)u?EKez~9~UgQ4bgqN z20}x5s%~Jsq$T{n5Yi8bSV0x}{eWz$Os6_K@frjR^G@bKOJJ-mQwxlZ#%JrnYPMYK zBpYzM*g$Ek;)(D2sGn5u%hXKV+s*YKG2tCgFfn5qpYE`6k&e;i^OZZA`RTz@Sw?A& zFPJjTjhFKKov3`oEYdjdABKabOBz1M!9>xDy4n#s1gm1bQrHhSg&Nr3Qe$)jxv@p% zs&P`7uohA(C(^zHvs!sKa^Ht31%3E;@YXSdCSDi2(bjkISN;O7ir%5+#tn*J(Ewc{ z)8nthwi96J=z-EBpb9VOwT|uI*9YFIBgY);!E9;jmsjEdWOjqg8Ud1y9uqZa7TPFp z;(+{O23dIdiI)O^IpSait4m+@v4Mj&d1&&*9K3hD^<)4V;TU9I_kPoQhRLbO-_dL{ zsvO@{8r1;AihC$mXr68@%h766QOM8}34(rRc3@*xng62F0~he>V5UmnsAwS;s8J=~A7f%Sr8l;bto>0nc_;Rc$8J`}lEQ`Qd2$umCDmU}3D2P`q6O9qCF{n!AXV{uj zvUvS@ZX%VBnw#Mf@7Ln*YAL;E@@=_I)s4?&JskYJijym_Me2FXdUs2Ry1VjT9)cjK zix7AJsP1rMyvz9gw6BzmYdkPieq|(1MSt{|{|$$~MiYT~5jj7B)3+4vMtKkCFUvtb zLCi#XVAbYYx>3sN`FFLfa)Gbvr0c%*5udpTBi+OwnVpT($ygsPiW+Sdgxe49PQeqG z$L^H3UhT(XJne%^_eU$2x4AOH&jRq?$o?T6Fw(do*aQ{JNR#-x5ZlCB={UJbv<9-i z6&LqO8DlRz`s`S^r{BFA?|vwhtbd=^B@YMN1ZrO)FIkp>dNPsKDe8l`MJtgU80r-BTs#ZYl&|yWJ?N@n6#O!xwd6OzEU(Ra zV`{U{YfKiw5*czL%4+i!0STEKdKnJ&S@a!+?BgfDkGocF(Gc$cLN(0v{FZnZfc{5;VEh+)&@2 zvuTI_0mzjf7i&UWtCJ1C-1KYffGjbm1OoL4=LTHdttc&tWV>vFbnRuGLfcoJH*ah4 zUy!DfX9ZZ*0scOc$_6lKKd`q;ktHQmL^pE6dI+}kmjZT#akHreD;&|KKeJc6(DZ{E z=AEzVT#~(352^zLE_yiw~04hz+ zA#{ObhM#Vhn$w6-m4$Xer)`GrL|CBOSCmyRb>Dnq=h8)@Xv3081d(E(w!dju!OQ&z zf?PwQ#x7Df-JAP&D^2h$&dpyldjr(F!*z@&e-Bw{i|5F@x-U*+?a3zem#!%gQ@=Zq zQ3C?JKN`Wyk2MV6ibkFRe%9UIL}OSd=mT)ND@(p7QUrR5ieJM;3~EioEeKg4BxfH8 zRd2du)FQT$qBW17ae99Kori$x8fc_uUaxb=OJtD@Cu*3&2;T|<%bu09BUlzI%hx%x!>aj|6 z@G8iTjGUnt*udW)@QEcGZKAF^RR*ya7UQjZ6bSrUmCWvw<@{{!_3u`w6c&G1Cdv8S zlU<)thaRlf0mY+e>^4Qo4nbZMpNftQWr_7VtQg;;5qcIYnW+owc z)~p{tw!!EVUfPy0q3L#lkzEtdLCY=2 zstnlLlykQSX96ez1id#8KfG(zcfG+X!JiV~>V8D;96oIx$Rqzc8Fb%C%SgylHEapZ zH@gds)HR8Ip~?00_#^N`8k>$Z1p{8Au|pIv`vp>)dc51?hZs@2%ysE~o43?{pRueV zDf}bM8Tn)#r6tx{%#})3*#hnUNPOWi<$@rPi)wQ^>*nP)`1D}l*ymlsqaWot! z(tr5#Vl!+_*J2j_>U1=F_!x-+z*ai+@bp-{YNf72K4y1a8L;y9ctkh4h>RpooZBcQ z7oaFIN~w8FSTuVd+LV=r)lI6hx3%p#aL~PumHYPdOhYH#P>sJ9cHTr+Ij4L3U38}lsE4I;9;iQQpI#DtjGNC;FS_lg zTfHJRsuIOG3ZAP2F5$_gip{si&@9w{@qms0ysn#gQn+8tPd~KGI<@tzJCKq!`-WMt zdnbp}=G4eB%U!)drU&^K^k#3k*1?8t9pIj)9_#EByx>(hmLKjXCxdFA$Tv=oCk%Pb z(pM&gv`RD4VI2PLuq1g1(JFKrIEWzpyad$nW@l=ZyKbHxVuTdU!hogSrzJ{aPO)4={8p9*LE zfbnmmew!4tZkAlu5dY&hb)w@9uOEi}iS4@tah^dfs z>wMq+6>lW|4zlYLF*YyxbGpn=ugt6+86Btw##6;^2LU!#lDuj-feUn3%M8?RQVoyG z2F|VLX>LER(o)AGTIdo&c(PW0Gnm4|yHP1(^E@DtAf6z4V>K#d}k@%WaAOp$Wf4!NP!*vW) z3_f05tEsIUyYd(qvt6X%&d94WR`xVk^Ji`NjRI_VQK-P5)OUjzXV*!QL#=Z=$_$v&S;Jv3ibS(> zAl>zD=e^flMyqejL3&Nx{@gY$&U1$(LxvbcS|1-l@w#yA_OItDP;>XRIHtya#nszc zW8s;1KdxrJXDvu5Ad@r+Ptk%i7RhXdJy8N_uJ3v_MbLX94;-hW$ofUS!EKU(rv;au zs3*;&{CB&o=QGEbCf5z26R5>69~HoPyQb8R<#9`=@_<8Ii6UBJ06w4zHRdwKH=D8q zbMvPyGh&eu1zBNdv0BT$zi-UnHyC}Y4ww~)c(Ux6C|e{~kCW)JKFf38C))^mWn7Ex z+Q%b|Gtx8hRXl`>=E;fTSrQ=&0MOAwedj785kvAUSQ+0+Dp`&2>Hhp=GS7Q$z@RGb z!a#$!2eF=(*4Dm7F5v;Bh@wmIUW8E79fMFqE7OiqMG|L!%qf9o8aW*_-psy;s9}k6LNi=rV)YUTdDG3nsO}Yi)z> z7m6oQ*u!g@xf5M%kdyZKZaT~_2hTj8Dr_?Mx3VaCuq+j%D7CIG; z9_wi5eG96aE?U{&FnxPo)9l=*zfLyjaf*g{`0>A+Mj@l$Pz!lMYW9C;9Z6#S1repi z1Fi6qGhdu@@k?!M!mW7O0ijQmytx5)-O+=KIEm{16XlC^HXJ=rvLmlukwuJ!CFpOw ztut)dJIcAvY3EMpOCj=iOG9EPH7!^U_t7nw`h+j)&ixH1(j87jYvhFmaTQ*>H`sq? z-{bq`aIA2E$0m-PcN|FS<4(NO|8)wD{x|CV;WXXB#>re(8LvLm{5)GG$vZjggN?65 zpSrHiw4kEksqat|826~U9VJ##%v#|0$*=WXLX(%AhYcXuBh8%vvuR`*EgV78y9 zJ_r@%RYWS1@8_w+>k&#BVM}zND7x-Et&zQ`kk>6kC!FO>+}O~E+Fn-NLBiCIwle?; z)DHYP2f5#5iDSZ&!zCYg5&wlLH*BN(x|p1a@0Fq$mTBx!p*`RsGQ|-~_c1wi+B-E~7HD&uhd&Z?*4?L>4IDw*5$X1ywQyl>MFi z=>7VuTXjR0^TbPL;+V3*$0%nEaL)KMz#^asru_JVKaq_FE4T-}e!YKhIPWV%&bKb9 zP8aR`){yD3oiZM-P6Qm)l7^pS)>rs;v-E6+bF(PAFrvhhEk{VEAJH}pdiBw_>W8HvtEdtBn%sekc93F%Kvi*neRW@X6#{#=5i)i6AIDZ|=W%Sk%~*_!7@v{c&n&ufelg zmrui&h=(QS58Y9ls$P6ZVWpK2LwD%nHGDkC zptp3P3&xj}c-)ySO}drGk#4Zf4n4P-d7DQydg7+kD6X-vK47qTgtzJAe+t{&OEnM! zC|uSFywuC{iI?;;BZYBy-pzz<({iIF283_la5-|e@@9|^p~!Q_Vxt0~SW=Pl&Xum% z?FaZ9oODku&u^{8-h>ys`iQXIkLdaCnj* zpJg!(SE&-%ZgJ|j)BOEPw2tS~{HU6JkXFm6p4}=Nko zlL^S!KdcZJe_gwNEE*9_ThhpsNE#O!9Wb^swo4Vs62)Hu7exF35BQtPpFQnS6W z?=qhCNv z+|8CVP99WTf_qbF#j_h4q~GH_;sc6JKWn1@g8hOx@ydH4KR>cH-ybcG*`Q$*VB*`e z&|0Av0B-$2gZgC68PvnwXxXp=jg?)N zmMa8XOpy1+E_YD-ny#mhZ$?^bt3NSDWZdl6@AGCue|d?P&&Z9$HP`O*6LX-%swsCT zAYmLK&CP&E*I-`pCtLmaU_tm9wuTV(D`OZlZ@!5d`2KH}=2M+5(~~Bk&O=idjX9j= zU1DE>g4;tzf~)^c^2tJvc8fuGkl)`ESn6o&QFj9*nO<6UCwg5Y=bdf+!sp|j-y+m^ z#ByWH|DLR2=HT5bIm@e`i&!dLO)}aJdb+bgfItoJ{uheD)pfd7cG0uT;lA&U&Q>5 zBZ_+Xi)Z&8oYJOPOB*|m9Z#h%)LwH97di?@z2GHxn5}~#>-%HKf zSZ7CR3IE?;#eZv29+Lwv3yliG#)jhKJ#p#_VVHe% z*)Mf^HIJ!-wnh$7#mB*@-Q!*mC~-666rSVn7`y--N@oYi-C78hkd4pq2MOA z>2BNdBqyLq4^#%AiNp9|1M_=@_WuM#`gcI&O*yoOztANdfzRa z_`S)dba!Sny>^sn`7$B&k(U>8H_)Ag4J8Kc2Z3aQOYQIwLEKKSkgeXX0WjWR+6UC( z_&nIvxhga$Gh&Qbvi)(X7F7{390)nf$>J!{5Sp}9(_^$r%j#{;$F7SwHO{hb zArJ}yKC>anpmPN0X;?&R$V6769ZWiXEQaLyUn3%0q`!m#eis~tS$^BK1Jgr>COZSK z#Wz?{)VOyf0nM!}j5Y}$tsLd4XiN(7*{jHJ#lI9Oh&#cOvlw7n(A+=V(xj#FZ?fr# zBZJ0Wi16@&9`@Eovc6th0R;+lBQnU|vc0lBhOyNtm>j9mv1Lyv+F>E#SB+-jD2W|tgM1}J6aR7N-a(sHAGPt< z@Z?L@o0_oIQ{s3rbqsn^`N=|pP_91LtS$`()PmsshCy`BpGo5{;6f14VG1&jSkT}H z8!rqGH2z)IWNAcY8Wd6a4PKTR1s?M@CT)I(f?8EB_Fp1SO$OW=6U>Z(*TPY@x&}z4 zLkE&&$&;zx_r3_FcnP&Aeum|OG`{4>7fKge{6ZJ~X7ccHJ&Iie1CC2p9$rY$tcdYT z*lkeg!QZ-jLp}52Sl>mJ5^uf56)@E?xw4JQYFW5eLBI_OQ_7Id;z!O=y4Dhfd*kAs z$0FGZptjNamUK(qMlNn}+umK@lqS|K@BNDu<85qK>3erq^T!+50_3BwWDb1u;zBP( zhfWnCi)ar_tY2#(6VMMrh@)2icDvbmz+R#174tJ>`9mjk_mpizP%1koXr?f_47Wg8 z_840rGFDfar=|-=G@&Djk_Bs-w)M2RdG^2g7!Zl-I43_|^M{YUhD)`-_1>Ob6bxP2 z4hrOHT(=?pyhmrKpOCBXuG)?GKdJ5f&FYqx5a z9^c{hE{(xy@T3nnlsRZanH)KxMjWj1Y?^-LuHE{)dSzH%o65NB)T6jpWN%$;i4yF} z23>2$yFPWqVMS4!KQ)a^b3-L`e{4>52=>CsPN}=#3GDn&7;)AESZK+meWHnc$&>hH zWkFtc7H~$?5%<-G!PC7ypa|1@;`PzATV)*>erKm_soYJp53@9!3!< zk92&*Q>CcrPHE7 zuBsyk&r-V3mCu^ahp->}Iy1CdGo^5GZ5Zd6U_Nz`E7{3dQ>%<1Mxz!gjufE9!Xn9e z59om3WFJI{8 zGsV%6tiE68=MOFWr57DE6vG;XId<*Fm0TN`pY@Oh6HG@-`r~@Gg%68`fzi1?P3`df zrIm5k3lLy9W%!hWl+loxN!uCL8PWhL1klLdSGS#|j3m_y6C?r(9d4sID!0qtQ^>z7 z#Oqj=2$$BNmJeo`*piQ6E-DfYJ*w7r4&~O@e_pFQRtE&x__r=0SDz!KlyM}N_U=6;otk%B^*^e$ z%G9v>0FBrb^}^^>*8GWU{`OZJPwR|Jh>1=f%os$$o^_ zDMdGuwS|c0b|0m#sHL0>2qkVHco{_ZZm4Z^)V>?<@9~$CIH`1qs)^D?3K02TI{EEv zO3BgqB1hZ>#ldol<+1I?rHrj|%c_!h%d68Bkxa;g0PdOd_i#d%Z*w6bJ5!{yckB6Y zCS5iK6Dh{uQrQ>G7?M0je!trs$@Ay%H}$5;h~sI;>I6b1T9+TZR=?rAApZ{!TO0^a zJPuHudtvN#xq76uAmw;2PG&oKpoib`)LZ$EyFO0Z#B3(pGT=oUQS|DP7%AfH%{_PMWdy$k?f?tn1G zn3h%rKhUzYZhtuXVWJ|W?`-8^WtURDt4;O=g>5LNzs!)Qj3p+E&Ph(rWHaNMv?E;%{~KMooQQ1Y z)5I3HRkD%A9#F^QUe(Cm%Xt#AVp8+LiXl!$w_~AsWcTo(xk^?RPCQ7CO-Sj5(!B+0 zPv24hGAW1}cnHR@Wz}@~TJ_5A^QILIS(jQqLWwka-s9#JYGn`e_uwUGOIQLb7ArSA zX~Rw%dL*}dZ<{Etsuyn~JRVk+0E0*XQEh4++`0CgMPb*hPu1q#Qo2isH*!N3Q9Z@H zL(H*)1{sq~=z&O&KfhuQ*hg3dlaZeo+Bv;z6MJgljGiLARj$pvA_2ai?(pcQ|BS`fcW$@zOCa z_C*7-K;E+F*YIGW+$`?XO>y0&$1~@@HD&g(-hp5I&uc)VC0O8%;ss?~`jja@0^1L~ z+>j@CErg^@k^1O;%og33{fuvqUfTe1g!JMT?H=Kgz}v1QTm1}>XG>zqTwW6$O_8kQam#vi zM4om?+wX#KeuCLw9>|Q01##KhNed@KJSe>$=Zpid)4m>E8}M)kok_{ad&M(|;bxba znA<0dp$erGY~aD$Eb^smL7}pirl+>IM#@-D9sXV&Lm?yo%uw-NOXi}YZ;dkV6vHw> z?fwt9N#3HhQ>rAV6MuS6*6_3^1sL>4AS*{3== zyIyIJY9j&5L%D_buvw+<@4}P5UE2zWk&_y6!Vjy{5Lbpl%0Es&Y#LXknWK*1hexLp zBHsI$n5)lJ_Xa3g8&A5IP6*2TUjkkEq%w%(eiF@FAZca7o1*p_j`6EiMpL=U*9_-0DsCF1ml8U<31ZUY_sl&I2CUx@`1-S-;cock49lN`ec)v zY@jZORlTHyv<%)Hz}1!55nR|p%i4!d?BYSjZRc(|q^pJChIz1FEgs4vUel$H+Z;^% z4tM-bA2~}nAqic-C=`{Cj`;}@w`4D#v$u}X8Pv>@6KHv@GfdM7t0m~Y_fXe66%){Z z+Cpt!>tq=k2x;pdMf+h#{?te-R%Z`4i-&3C65U>WFe1ZB$GuDyPrOn8@1^dY*?)JQ z`;RVnX>Dn-wOpySV~CierKJst^0=CjS>Kw`V|U0F8|20?75a@X2R$BzzwXO7KAx3{ zFf7sLKK1p!ejm^#sHc$lg9y!vV(w=^Rlqpq8^ysX3=Im=L-9zX{Kex2Nz^7k`+XpU zT(gLlK0RqoJR1^d$0nI&QdOH*vF!B9$amAU1XMCxlhmOEC#1gnD(7|!KRD6;-o7y{ z7i`1Mf2x*QG5KxZu7}TTDbVMwc#fKuUtmSM7FM_QySe)E?e99MKJhBMxCpD;YAj20 zd_SD%nw6!wC9b$Ek9vIK+uOC3By#}-xZ#GTfH<& z=PK%Pqw7OY&;IUP#|yio!|Aa;vNF7mggDz)GC{lh1-ab_aB(8tMUh_^iKuV8TOR_( z4oECXgJ!VCb_9h2h6ir3uV1DoWvi1P_J0*GDm?^xe;|~~+g5J+QQm0afuE)OPW1h* zxBBGE8zdq9Nhj^6gx9FBLG0LyB+c=cHxhz*IqP~VaZE?!MT#L7HEt7!qI*loc(`=s z6KLL(bUqDHHum~PDw0vIf*znmFZ58Snqoi(`-We#UA)W9N%*YJ^?2%dqoB9vgF4X@ z4fBBVU$4l~SOYctNp#TUJD1m+0Y#mT*#>ySN%~~1{Oso5S9*tF;*OiP=^&AWs#z!xY^R>@bvMqx)eVETBKN?PYvJGMm>Ts zF?T|qVkXT?&~4iiZ(53VL&aZlmszbYJ=2S_!3Lmhn3hl4;~~Jg#0{-+*Q+lK=P25Z zx^LXpYxLu%Vu- zP!ED9WGVeS>A$!ZOO(cwtvgmW;2pBbLYcq$KZ|cwIB2<#74KEsGTmg(t=OXGxa>Da zxdS@1V%JR)m1$#tKMy9EI|0Q9sc5OXX**XQmb-Fn)HMz zP$WZXXrUR~)7hhhnA`ldm^(HIrRnnWmSh%^uEwFKVEdakS6jGms_qmzG?8E>~tE< zEqpt5AoCe+XXLiNdTY=a?8oRZ}#c6N@;g4Y=;=2}N)t>q7kJY2K?Mo89d%cL* zPWils)H3{PiO3j9HQ(0M2TIECjH#lSQB+r6(o@@;YY>k9T8D_j;J}UYHIsjE?+(}j z_&UeSd-I;v<+P?JHR=igI8UurOC_8vR@UTE94yV-H8ok$={NMMvxbGeNNN!SQ&M8c zMa}J=bTFqAQ7__uwRIrVu8alR*Nt@ONpgMsfYt#;_`y1VNY_1D%TT!THOVpPbeP;w zIb3>30;lTt&$)lEw|Zk^0ht+W8{P@n#)!iVn|StI3b8mi!^kExt>eiu`b*BINJi8l z@ml(}Gc}zbPIJ)y=3ed`+5#6(Ac#%5&kJ+_Ii`f;apg;Q>tD63(DmH8*3Qn}qd}gI zpvf(0&<5=J)3a>~9o}#iU!iNcPU0F58!|^h!0ok+SnhRK_0?-kK*oTRCr(o2zTjfy zcjKGaMl6$F9sCZ*C!!ADi0G4BS*Ln9Qz25a6_)dwE#j|}C>3@CIp1`ZdhJ*s!(8$2 z@1HWOKd;h}RID;02(h}>rKQN%5REyj-ZTdnaD->C%IhZEFaxKw>2dh-@Mb5Rl_7ue za(&EEHZk3DoZB~qjvK4Cmk=Q1_g$HVuFI2|F`N#HmQVGQaf`5Je_s80Wtl@dhp@ZP zuCFa??1re_bEics`w4inOB)->-AyU;$1qtO+*?x@>9!Kosk3%IGrg->TLhWAzK)$rG`okK%@Do~KqyxoW6jEm6C&6AB)-_aA7 znt0j_TX+smA_iw}^{bFzk6(=bL_Ry?u%PjH5hbBYNt2m|$@qTWo=kSd%dP5%r8Ii0 z=NMayPJ3s}|N5tT2%Am<%EYLApP_GUtoskTR(wDhO3-Fw+`ugY1+{mnC;73-Cx5Kr zDfJxrWHI=d3~v0UHfxnojcQu|?Vbam=NS%En_Bfm{jNc+*l^}oU7vwvHt~~XgBr|g z(-+QsfQ8+`!?yAlT5};W*Wg_~F8jEUCjSnaE`O*KZ1UyyCPbY8EUl}~VsR(nv&Vcs zf)G#}3=Dy+n}~aLacmKGYNwmJ0`T@t8$?s8?u_(W`EMlduwsn&MqTnwvAOeF|0XdT zz)y0Bx)A^VBx$~$Gu>0FGh2S;8S!s^vGX3|*F7Sq{zoK{b35!w3Yo4cr)$51ii7o8 zYuNABXhZ#6CtXiYr9?q}hZyFW8v3PBMBevgs zwQTrdejSULK-rgf<^%?wgMIX`_`cil>UXDK3hOp7Y4}+9wXN7#00aP7>o|#noee)p zN2X^M{1hs1#y)=+$l)qxoxV|^Q^Nz+&C89ufCKxOJ5DizYXKdf_+dZpE!D+PE*!J@ z7|``kbl6A3;zfFz<(~bCkjS9xhc!H~J(t&4MW}naHNKj8Yx4Ck5BySVaUX&EnRAq< z;x6lZD_nDkqm>{$F?ewoJOsUvo;!hIk5AQb`aRiHl1oda(X<}9}Y&+QN zqpwW&f-o;Oc8iT%4P^tK5o3}Rm6E)J<99!4_f(y%a*`@y8i5qtX2H@gBoSO(8l#nZ z$Kxiu*CTPvbvZ^HsMqEKZ_mBF7eT^;?{NTtgZ2WDNV!xA!YdR4n6c3ME1| z=7wWDm4>y`Qk@*84&l*c`yR|4JGo*=U6OrcapJs8ptj!SgU~5RYyQhw;_mu1PwpzXf~oC!RbT(T)BYlf$<-JWEE5?{zav)jkgSz zL5}(kVdA>vCkEO?CSU0S8(QLq5Nx@rLfPx07;`_C+^irk7D)l32~;dtJSUuMtfA1? zsI)}D!vSHPpTV@4FrP7SouJV?r*bu>ynQ#t)j6|~vkFdEx7b*Xa}yaQs&;ji67F>m zGD+wCbkv2|=x%WV%i|o9`aG+OE_id4R+ufFq*XYGdZE4+;2^R41}8#H`)nRq_>$uW zko&Y+a3X!DsG3Y$@p$d*5 zH%q4X_e`QyAYXX&T>rJGoNRx0GDq+IW0>?4O~NQVgu;BXeb4ye0mN;?GPsp?VN=35 z4UpN*%>j?5q_9~NY2`@Rd?gKZn*YWa*@B!aV^+QIr$G9zC$SGCnBverF`%+M7vTHU zIZ!uq$xmsTK72cM!O##FB4mNdO=oMjNbnNLNIdv6m)AMwnP*j@pMF)ADo6bsJN1FT zg)3wns^tQO1Vs<7JyBUj^2|SDi^Mkb%fBLsF)QBa7mZS!Xm&OrT{vHJ zVj9_d+};zS{YuzMOH!#`&hzUq}bT{*3qJ=2AtV5BQf71=Y?Uy*`*Y%{jcOdCd4= z7Rd6WFP|nlw;OX}Gyy^q1-<1Un*m}|a6P?6B%ZraJZ?(jmJ4~o1&%beI7x|(ak=%0o=pz$G*Px}s6 z$7NPu&jR|H^Fr4uxlF`lqD6~if)FFyC0Sf6Yi3U-2-;f=)LixI@Th$@^v_uv-eEiW zNWF0iKR#}^?JmxU-+gz!oidy>tH^D__gMVKvwmnSAkDM!u1BO(Ax891^`_Bljp(F- z;V^Uh1E}wK{AmvFd*+&4Av1x+Gzp`H%BL1Tjd8a*i?h8`>UID8#HfdRJ3*vdxE`TiakCZ5-ct5BJTM+_pGF;mKsUT z4(7?6ob*J`&`s*j{nH<{k0(`sQ}Tx^4_~5&Vn>cuuoc~UvR6k5M)c`qecf{(^pgqR zD?DjLNj$Tc6iDR%&>h+F5cr+a``fFyfA!A%K>-Y&*PW%WMj93M{`hTnp84&#Ct2%D zjGe!Yq*qZ3HgCdVhzO3nxQJJ<-zS9GA=6m_Qxgev&2(y~-5}o3({P>Unf2uG$ zoA;18FNM1n-)Q)&oQY^FUssnq%mkMn!kPG#9zp!?U??I8CfQNRfF0%=cI%*^fcUxDuiyY5(}S)S{DBx~_H_Ps7`ae0)| ztV`u$Dg;EN@&A|}k>q@q7xg0D8P<9DMXuPaxtl2b*%uNy^zg*3xN%L2qDZ$ki9FZ- zi%ZqI+MFLpuwBbkbq@q$6Rn)HQIWw-+0_E-WSY#H%EdE=-gDYa>C2@1(Z+64b71GxZ3v7A*MM{Ax?{Ds#tdmX5^m zt!mK`Xc~s|&3crH!0R|LjjPSL_n8i)5Z4MwD*lMe z`K<}jzK!O6W^cfx$Q`fd=DIT1@`y%o<+QBx=OZ(kd6z5mtpEK_@}^Vr}~LFu>X5^CXxC=d`;JXIhg}#*zIG=Ha0DfVGpdBqg<~?ScK1RrdOURz6W)Yg#~tpvpZVxU>k`>nV(Iiz zkW?NO@(1&rp%1^xKmWD&2JlY+E2XC8 zsU_?&a$}v6{5GoT=MK~_L`C5gKD6Nv>|A$U-e`mEV}*8nI=XSap=f`>jd~$Gs)v(= zIUjO~$#*mQ53kfMI$rC?vyy@6&t7gXD>L3zF2CU@VtS6MjZrm0fW_C8*<@n5HCb0U zMxcuc_QktBV^!Xr-`x)jRyM7=ed3jot=^kWyL;UTY4R(NM|%3=j`XHlMVw$R)eGU; zWB+Nr4F`>>VV9AOCxL%6pcnOXwLd-eI7YQ(c za`mk)5dTkUQP4p&qfo#X&pQN6|9VDGH?Lw$+$&zIutDHMIQLVa?FZ4v;;=6G$$IPI zDXRnz41pUGuT(-^&sxQl*Yg(@m-OU9sm;qb`neYD;5&SS2x02dBa3q`u5oMpl{kT`&FjuIgcj;VdE5UxKCpK6U(EiLzmU1R@l;BZK7NM-MPmC*Na2X3UTCg~*LH&sK3hrl$Cte~ z-Y+_^8j}b<3R2kXoB#cn-j#!!*q$C`nBZ~mM}rv*!`Mvxo!z}W!bhO>*p-2K_1TZ5 zyKy_cw%t}5$j`uyf9R%qn*YUD9K81$W>&f3j=)vqluY4>$fJn`WurqUD)m?gO>6b$ z-D8rqFOC0J1XrC9QKr1cH1fqsM2*A-RU&Ysv+9yC(0=f@d!@b~&@4teP{_*;^LUg< zv&Mq`fuq2{%D%^K|CfA^BF>?UmfM0P&9eXOMqY>1+o^77R&-xUZE4K8A$3Bd&IQ`G z;f@g|z@ejzwXO$tnh)q-2pVq|#<)M8VlC0X_apUZ2KdoYC1ylB$N7%`!k3@|s!HwZ#rh{-f}xTEf6R)i6V!^9;O-`A}*BTEAHuO~JfRlkz1FFV9 zS21xy_et|&APR!+A5NPs5b9P50!;g_atpLCzj0>QNTukdOyWoK=00OP*y`LKaetQz zkU4ULV-tM}oWBGVR~a43B+iG1@>d+L2>J?LUOC+Ek}9%gD=(l~gCba^c{t_agxybO zQUO zLNknXqWq2a4)dL(oM7tz(Dap2b#*E$;3V zcXzkDpZAXM2R}J`?6tF!nVFfS0EY2Fk%q^GT`@D(zoD)wJ3fkG%tQeabToB8n4Lti zsD+oQT_|N9^4x(jyWxqV{(v?<2!eFJs%Y$bveQX`OMR|{2s|!RX1R}^UV6Hqi$qq~ ze^x6*Zp^5J?G_ejuQ=Jy$_V81?Wc5K??fZW6$7e>1;-=t0SWy4+3g+-)x{&D(|j5u zQ^PZE$(|q=V1V?uR^Q8?7kAC=#MW;4TA5Z?H@*#VX#|04BWQA5itEY~El*ARtQza} z*C0PP9r_5PEUSLqR-;j?b9fIAJ@8c*7c>v$Q;+2BDfW#e71HPp3cZlIeAXbHiADC9 zHErOU;IBjdwzd~8%Hcb1P;*9_ZeM!K*wP1XEJ_w63!&BCI)p_N&Hrfu$_cUK|5n^q zgGkOkt+!jqO#W2E&z3ia$?H#aoaE0hhxzizHWN0+X*QsI;i(=GV0z&bW0iWyA`T5D2RxfwfWl@YYYU+sgzfK_px@ zKAV-S_5z)(3f7GIEos;Z{gUwI_$muL%wz35HizGlsH0a-XJB-BKv|vZFPRn^= z2aB+L_e7^w8~YHJL3Ps75H9Za$|2Vtrp8LEjR5K2PM^_w2eNn9>4bVa?E_p+Mmy67zQ-z@ zuRA~o_X5Ac+4R&ZbLGVVnX5K&*|!>bkI_8+)eeZyT?%9~HqnygGhXn1>{+e%-%G1x zzNZY;gCpOnx}DmZPHetBkN_C_>Giy^4S<%fVs`p6skVoC?dh_CH$Fa;$p<1E6o*J2 zc4xkucWte9FZw0Ev&1re&Rm<<2QsK4yxIvToH=c8wTypty7+Pad2STn|7EJCkCXjE z9**A>jw5v1S@PsMnh!B=f(9H*2SVyVg=rvTwAnn0P9vIH#>~#i+ZxqC_1@J`rw%~d z3eM~w(NM`uOG!H;f$z%l-T#&gQVF~hZB)L6`dF$x`~~9k88L-eE8!GY!?AHvpUkj` zn3DxRwTEh3`(K7$pJj5_CL3=(n=;`A*ghCo0$D6_mQChZGqo-?UA7HZqiWG=U&r;G z>mB`Iytps|>l-Kj<|3mD{8q>e@9zRaS~J%s5^lO0)j>rP_CH)-_BY49QQA%97XJ#N zxV5cQGc!qbo}2lje4q6D_v~w$sjj{0 z%T%zei`&CUI0Ad91JrxbyGI7wf38e>kLI9~yr?mxFhat7t@=Lct;B{2)0e5Ko&oGg zFB#I1iIH#A(jD(>bUF8if(W>)`=sIEI#xWG-C=)BQ5^eSAE`Qj^F4BH`Y8Xgs|8AZs|l18TRBY;K>5=a_#rhv zZ)cqBrtx<$aSwb?79mia;H`D=z9=QuT2ZV_LXS+UXvQyelVn+niR0}s!Sc1I{P@s~ zlwfV8_5eA2h)<2_`^jgKutD+{+jATIM>#Ft`+u`%Cn)A2c(mrr1asB$W_aqJD{w0h zck6FM=T(7S96))amx$-GS*%be^Ce#GmsG-^HAYWj%Lk`U)4Z=ACOT>(G9{N$H2?AG zzj`WHW{a)?xNJRz7SUl6so*Se@Ushf>Ecfi>NZkypsO9yxsOh0(_+za(bKjA6gM*p z5MPdJzj#7|3P%_BIxJ@2LR}sRUe|t}wF#Z42-uMaS=(v$pbi>Kho>g=5Ak1~xatak zGGE-6?)(Aog&RFXsMF@#)i_6D1;<(&m(hy2fGp1tT4I7?psjbGDaOg(*kCm&hencx z6!jVc)NQ&Ct~XkEYR(v;fSQfVvxg2PBeCkO;itztp$a1Xze&?gPUmNS!LRgtWW90YZ{at&x7Ua?0c$j>J(u{*rzh%Ff0R9pI)Xs0`PW0b5N z<0wySHm=pig_;mer)$%TjW%D?GtxrTct?{@=G9#Ck!Cr*u8Gq3(3K&U~88lUOQzilrAG&)qIiG(u5gwMH0cc_HL$v(u4} z-cD;z7fNKLtQs?+uCmh117B7oQMw_^$ylE(HI(ty++kG{H1|?^o+pI8(m|RBRfOiN zJ`T#eup`dbX%!(322x+tkLW(7)x7@3vI^&_vmD9*Ql}20Hsx#{)jwV4AsPd{X=$-G zXaC+%|DugJi-c)i6P(^Y5CVT4G9@cP`Kh{0G)ImWl=jY~96UvkvuQR*5T^$oMQ3ZC zO-`Pkb~nvXuFc_I)zH^#&F${qg~^W+Unnb}+TQo(`&D6`K(){KS@Ut409OHijI4zEY$LhWm1o2Xf(QfTLAf?>vvjMcrk4df-dc9_`8%x zT*dp(OmXwBHTRqi5y%l}Jc?02#6r6+3Xr1S2ZB&jCGOWZc8Ht1R)sD-L-KSPkNWG~ zDIJ+K5MqPaW*uwViH#c@zFv6*R{g!#;S0#lUiAik9Nm6{8tq86TTn&dFz@tM4@yt2 zCt=#1wGBgp8jX)W0PHR=>_^h@*TE8)3oPKDodW@yj2JA18A?J=6(0Lkp0b?oXRqDD zMI89eO(2YWh7p5kR{9nZNGfs7H+*OSyMu5E&Dg`~KQ4t*b{!kfswkRxaXTGJgnPd5 z!G}P%R;)uc{uxKddyH~x=bvaaxPPPRvZ>*E3HbXp0 z#{#3vf}S*rP(h&5Lodpn9J`NTc^~dqvIF%q`W04`OtDK1x&1$;@!#1=;2GfyJJc=i z+Sh%=uViymWJ!1$fv8^)1tchjsr`4U(66L6k4eSWDbVWN?L*L#Q1Ct#vAZz(+|zFI z)n#O@1QU&ZGUDx1`Z|SH-f!;cyao*_kk|69O(<`5BXhsf^nF>dYcsjfO2>GK4*#Lu z_R6%#1e90~JRr67)fO4Q2OcN#&i95GFyQ3&cjv-DNkWwBCQ!6QgW}=iS1HII(86zr z#E2+J&LG*-IWfnlWKn`+-ryhWxw$JNE6-UL`wtO==b{X7dJ`xF>Q=7IDdGKgJy(`M`SAvA+HL{LB!_FHe1t5fEQ`Ma&m+t=e6iJ6vL`5OeYY?e195ST2 zfO!K`GNfL$<`Lrezbm8>MS7KeO)L-5BC%$Ws`UG1V$z%g17g) zv)H!?iWXZtZ3IqE=x+&>4~!5%b+DW8wZF5mvZm>vD$3w6k(VPs>6kR@_>)L<0t7os z5?$Rc0wf4^c%IUK4oKEQQ7uBDjrov&m@`DEzOEQ=&v0L6$-BR4RX_;0zdJDII%3up z|3&yD+^7HPWNbQuY5DGPM6B#ieP|pJY86e|_=uP9fTo5UHqr>IfqmUYns2>yfpX7~ zhRvt3%cjJ?Ag03N#)%NpulnzGOcG#aMUZOB1~Nv$X~x1GN5g(?Zx49CF`+e-%v+!T zUG|iv8nj?2Yp@tB;%?7-VuDKZjpu*RUezM&U2L#(ufW%tel7KR(mq^r^}CQXKS1mc zMDCaMeOmXISSLlZFxxST0fB%b=_lpLiy9O? zWG$$&h-}OICm7^jii>9HtgI7F_4#u=eu)dR-2P84!g|iL0V)q|ciVNh4}*rQY)W)$ zLeQ->ZI=Aqc7x`|6)=IO1+MYW#X8g|VYWJ(s7BU}X%)mKPGx95_4{z{vzVh|Fi8bs z(TbPtt5J>lbE-k@*zbqrj23N{98GsG7O&lx*1RlhSx8jlyKw9tViI%O{_@SbB%vdB;@l#LNQL5)UnACN# z)kfI&jC6@1a(OSNew}-imhN{=?HZE|l@}cMU+BnbHzU5L37#Gsp{YYLOf?70LBW6| zQ}UNK#83@NHHfzFwCMLJv$ZD@3dBtA)eOZ*waoJ4IKKJnZ*r@bzt$_6$(eo&te3URKPOI7FT)UW#XzGJBJybp%qe9eV-VY zM_{WU1mvxx>ay}+!3s$}P*lfLGb@-b6H=#?o?|Gz`{Im-Id*U+`nNMhzAS-Bxhh1O zO!PY?h>?R{0KRTTzI;+o!|h3CbL{F9_ZHH08i^!*0B~rAD0086Eq_pSn_Rg8r22K8 z8$UHo3R}{|Qsh_<#Wt{c^I!e;gyPoNZTSCAYn;#v^&3{&UAWmMs0Qo#w+y3hOg4W$ z?(uB&Pow}a6J}H}eXUXsL}NnF1gUgi{I4T7einAkxyX;1B}|f`V-ebMIjT@0gwtgS zF>yZC9)}Rk6;nkcVn~qkCFw~*g6`wi{LmPTx#RQ8$fwJ> z;LNC|vYNz^fT2&6xqc|1g`A@Y}{Ag6wr9(cR&W1Tdhlr7nM@?1kf; zVJfrHM)*Pg97ah>B{b8G`d5OMV%F!PnxN|4Hki|_TrpTG_1Z$}G}-8h-T6~9{7gh> z4f-ib(%Y?o6otQO7^IV*8qOc#Lr90xp$LJ=M(LV(unsT#p%17c=QeKE3lOjz2wP)) z+%>7hfWiG&^3qg{shvNDE?Q`r-}zMp0aEzHn!vS1qtwN#V*zw z@|;XB&)v0vQ{K&I(L+e+C8g;31<<{ppu;AOl@f2n_fnYp>dLlzav)vu8qqX&QyuDlKt!xbr@whJaJ#SuT#j#kj{BuY}T0d9ls-kyJpy$QLWB3AUGp)MR}UGd3bEC+`)6 zBtu}U{$WC$6Z(A(KY&DaimpY|SXGre&~r?-w$XvF=vn#glc*}8$nH2HpDpbB4|(wG zz|7)J=?q7?rEEC12r*<5d7N{QaP*So?H+aa`lpfMG5I@gF`!`ipSLqal7Tlucw!<0 z2zY{o{=+@|(01HBuxVgj`dwMda*lG1tF~o|sPf*2;|G@};!e^!!3sYi$`DDLzI#bK z7Bvl8%HI5qBeU0cHf1M8QBAzSnK|>_F^q0b%m`kw@H%i6u`c&hLOyoaa&95u)W1O_ z4e##7LYnX0hnP9J9)BBptWe9$ySD7a8J_e3VVMv^TewSWZe1oH9$^cQh1X#1M8c~e zI7-t_jI9_xnta%9GDoXv2x;9Bt3O$22oOlej+-XW4XTnz0SuFI@}m$SjxzJV_)24G zUDh{p84V_?G$g6w$YxIZp)zIN>OU(J*rI@UVmE{PA~Y zBa&OR)-*?tw-b-YyS)&*b1v$ZWXKYAe8PuJM|wBUqu8Cg6hiQoA!nK>r2kGfAj*NDXU_}AV9elk- zpwxowvf+eZ10yh9=6nYIZ67QT(*Hpb@(~6(&Ms&IU&q>q;3!9ttd8}lq_T<&?{BaB zsrr?Hj>fP=C_rYHwDLzW&YK7g8w=dRM4%~5aAIRvTi>qv?Z1}%bkA}gTG6=Vz<_w7 z@SHbal6_FW(xrcQt>lJn8l+swb5S~aFc^<%xE}x1EU0`?!MTj6^Xtd7WLyl ze<*#SsqbP`W_yey+{K`8p}o|Crt;o((?@_?C@$UeaRRVBbQqE{>U45VrYZ!Uyeqk6 zg&$yoWHBxF>Xz*Miue<-{duL>1Cg47DD$J+8a(1h-L4_!PIwN-h?Lu}$`=gss%-L~ zgepqE{Msi)?&us3?QTtEs)MNEQ#LhOsq?~{kPUGt+STLY{?8aN8~)vp$EWH+Hez7f zjT~zxY4b}Ulk0?;p+8*`_Zkw$k}wA6r!pah%6VacCAjM_J@<@2_9jp=;`!KQgV})F zZy^075;yPvUr+iE?0i~OrQ_vcchL5pr3Syc0iMdl{3V0&7yIFJo$j0?#lGp)sQFSy zBYvNwNt!7qHUMSNLlph_CBSm4)~d^@@2+9MONYK!)k)!PAj<%;yNI0+&=ayQD zY2suZZ&k$C=fHG&=|);3M>#?-%jc3~23&4^x>O11q>wsUW5+?6a1SUa{20s?Mx(qIGF5#_oi;Y+Jo>9JOV>gb|#Mr%Zm4W-$B1L+o*M5~2I7 zyQ36BGA_zBm$o$(E*E%rJ4Xg!hl#|N%*!5H5RO`YNz4|QQ?f$1EWRB};6{Pa3Be0a z#PP{~8?iqty5?G4@VfX{32=c7 zpS>85L{w3L?A<0iMpj*yYjv29EC&Bankgw4p=`3D@A{z=$&fVKu&l2oDIW*iJuFuI zJ7{uqoKDR=NEi>s3WP5oou621)79Ou6xE+KpHCck4eMz@!FggHFJ+r@cBdER5w=H`{Y zSyUCLc21CrUE5vo|H7_`9+Tx&mPMQyCAhB&k^3kUz6+B_R9Uz+QJ@#e& zEDLU;EUC&@Wk`yekvg#RHk#VI@I^f(%(lc;>B*;?ES^`lCFOhS`gIJb*1}B9gs>-m zjt4j&3|FziMBM=9s|clpt0=5eq68@XAb)c3cEHb=EA~GwQYEG`2Q;9|&7ooEcC!9C z{DH&!Y8RpU{2*TPML0cJIC>X=jl{FgMeUdvlei;g3Lz@lr^W(Rq#P*jS&BxIUp0pC z^2S$dF_!A@u8fJ|JN=Uxj1Uj0Phk( zmwib=^P+uKJUrBZiuz1XL=SDj=yul>c9p5NSYLHjn$WLOZrGwj{l}fxEk>T91Q`vE zpA9Q8RmFzPXA3F`Z+f5vQ8-;xcf8$=!{eD}^F%W9SY{*_F^1$n584w*{fiM}08nSc z#`(JJ<WXC>vCMoi0-mVa$D%E5miKrnN;F|S5m_k#A#^@RoN_*;_UrAwDeHlFwmEG} zFQ)jM5As&G7!s?51l49YTCdj(`J5ftulEdN0|e`*X_%lWna_iQ#_~pg-j&HDXQ$0( z)P$1hz9*9GCy~ui@vyWmjg!>Uyc2c<;JR!~DTHgq%K{h>qe&x6$@BpM zlWqa9QiTRMbCP=DnNLAg^q5N~0cJJe#i0OLoIYd;8}+MBfJd_b0tM=wFm zx12#8yQs5>EnQY{CkUm1@3z5vVK|+9*INTn3q4gaxw(FU~4)#Y2%J4ZblGap@l>5>J zA`Win%*|-xKWa7C<={ZxoZe@Yxyp{u>s*k~VP;y3KOX`b056h7KT7NJcdmt(Snzco zpireT62eHFf&6wlFBszk@y@weEQ)~t0Eu1#847f`H*|!3BmJC+B*_%OPB1>zqlP8x zWm>CYnnJGdJt!-aRxzY}w=^JqVv?%r6$L@OHO3e?-|)SIcN1RsGX!o&X?sg+WIw!=nFAQg8&SAPfW@>ORs)dd%GgsmYgDj}H-9Q_4p8GK{wDglE+r3itbBaDQ7jV= zU9*Q%p)qrc$Ov4SQVTn06t+|A!(CSz95p;VK#!@%J)Kdv0)12Ohh{ri_kQtfcNbnh zqW%#KrJZ19)lFy(bx&flzFyXDP{xcK-s#0!QY^I4ZA>cJ%Tk)%iY4%2ufj}6qRXi& zqFX&LMJT*LaR{{h%-2AB6yF4?-FMkgk}pW(gv9F%$;t(EU?`h3BS+iE81j&?WJTjV z%pGHz?8TYfb%Am7oIq1Rvxj2Q$}*nrM@a7MqANT&Sacd_HLhWm#RutYt8-tYjmyh% zQK`Vs;INB+MhT7e6`7C3Q^)5K%j5=c#`Far<65i7DBS*gy^$;PxN75|zz|Lk5sn@M z^vN5>^G;Zqe9OGFa;hdn6KPYwN1|lK933wt1}%&$699>YBc;Q$Mrk!;9i2=A-SgN; zN70Sd78|ot?iF56Bp8xtxt?&TURZ-i%-_N;IkoxjYJR9J)uD(2Pcx1Kq3Gu5irP$R zQT&_Ng0X%k6#2jKT6E##zo*UC$XvryFap)aHM-)cRLX_O*zt*Y2G)95ELoP^^mDC# zaX-%jxr7^Rb?2Uj>0%=gI}1VjnK_>CIbS+1qp2uRg^xo56#k1S{JOtmzn$@l^J%nC z-?0b$`QK4{G2qAB5U#eP$NPBn8_pW;&fl6qArdah$~T4xsGoyWF02(8N+=dsJ=>Sl zGkNu{Qcf_^&@7kj6~=`w9{21}z3M(1{o2^z4Uy%e9m2{THkIbvS+RItUSK&)@l$!B z%LoJU(&C3kbB4-~2RT}gX8h}|nUx!I zoir+0gR6&Uo3J$}P1~{^9a@6@M5ykoA&@V2(1we~@rLd0cd=(TKeDPnz>F;=f2LL* zZ-r}^pB)+qP7WR0(nlyc*w=d$EP}mf<|4r?ty{4-XF0ts_VdEz#-JaFW)3+pzY5&WI&)sr}bxX(4nPt)B;5Kb`R>DIcn(fa^A59)8xp}@Ua(1 zQ<0Ozb)tFDmT;IAP`8HC@0v?31#W>mw)1f=NM9^6@6pL)w*%9>j@IHksxXbbGr#>& zxERZr!zO5eM>%L!=sj6rGLDqDV7%@IaH3It%&*8r1AioW(F)z=c~gmA{&|^t5m+jX zg>x^|O`JGVA$Hu_0dfzR)m_pd1O?@rUThJG_oIO_B{-*b=XGmT)kXU1W!$aQs^r^O z6zlCUFbl7DhD-Ogp#RV*S2s7DKK?4>$?nZ(2|+OK$gpW4lCUMIO2oT9#eZ??z_nze z6n=)`n5FdU*os_B+Pl3~RYBct{L;Z%{nH$)oRDDBr&VJ!Mom?dC$jm@NDE1Gx zpzEqn&Ejyqsb#}RhOE<_OkirY_{4js@ZIo03A(UlK!}6V2Y*^SEA&Jrq*eUvw81Cg z{}BR+lUHTsP@7cQgK7+_jIc$@pNpug12*9`2TWZ8%3aI&J7P8}3vZNE9=$va7jjor z28j&Jz&}ArPW}QU-*H9BF%;5{smTpA>)2 z4>>SF!GLda^w_2)|LyF{z=fYBsqG#sY%wOxk5&lG#d6fkl0?jbv7!ttRl)>q90eRC zDb%ygr7fF%6bFs|AhQAiE4pSII|%^Q)x?wpZ!>MWY8{Q zn}A^s)YB&1>S5e&8(;rmCT$IcKb$Dz+v)=$k;*~(c(-Uu;l|->G}!KpKqha%%Dl!x zM|H+NX4xf>R!$eb>o!U_x}F|~+4##e5{DoG&%4}_p_5m`&WvFg&W3xJ1+Kwerb}#FkBr`_zSQ%IarF-IE3gp}EEzSDsSx>Jr zbKPWrwx8^q+`B!n_h^h9cUd_MDc){7#t3%9_MBX=0rIXhf6Gwn_=#j4>d{(K4}O=e zZ4sB}2hcYgCrz|IJZaJ8VP+slo)onSF{waK(kL6_ZFI(h_D=&Huofh;l})=U<>JEG zOT>ksPKI`|0UVAyDnN0;m0Yin{0({GcLOJ>H(%SwZOpN8x z&&(f_u15V+9$ zm)K<2KL!Hg{%&Tg`Fl%9&!P5+vJ;;a)YcCs_6G|E_S;2}{0xP}$-8~T9x%j?S-f{# zMNW9~xp79Lrcre_XoQ+A8&xB3N&Aqpr$RP{0f0%DHxC&&ZZjDvTQR^a*FdLltgl6X7812&Iq75rtdip zMBc^?znFPNuAV_;^}<(~cO#zhg5Y?%5R8IpnG23mG)whuRIxa40ulWxKKd3xaq}sMNjiF z^LT@01#SgdIn8@d9$tq+Ah?0b&#m4adwW-S@rz?&#}uiJX=6)$ULLRBNi$w+;i9Oa zeK&a@I6%Bg8Mkq1MYs`Q;8{E8QvI-^G$NH8{r?FhgMVZZ1!V#Sz_xjrb8`tm--~}< zw}$OO7U|B89v*24KY%uQ(4J1q1rxN4c`6*xzj>U#el5b}yCPWe762aZCS$OKD|pJQ z(e5?oybnC>!?qpuc>~idL?j&%=Ij3KV%OJ{W+w;tul2pXY(#vYuvIuOlTbuL`mCnw zsrT71E{c*CjDAR$oAkLTYp zuUtvbi(E=JhVa6d|1OHLCED)r&kk1?DUy!Pty&F$va@H>i5mQ?Yhb<3W$4Jenveyh z)bU|+@Qd=*dY(q$ZPmSt%1?Nc7_f`yfG16;9^F`k+aBG9P#%4EVe8Y}8#TGR^fI+R*1Ub? zvrpqUrX0fDkzfjn@%q%gId29!ZH-a6sJm{_$r|IU3i?9r*pAxwsr~hj^(ftyS6%aE z7w!WYqilZ7<*DT9Sfu{*zB@;7j68j)(o2L6PhowymG9?ojt%1QK)SWtE%=Kn_J)d9 z-ynr&Y(kEoFhUSZ$ki12zfbawd^ycdJG%3g;POOJL8l<=hpkV@T0MQWRf!tf$VtFWt@q4Z?A6KGi46)(fFgA)8-P$ zx?1{LLb8<1D00Q(K8XRfQ>Ct;&HdDuR3(=wBbPj#q4GP>i)fN5XVb7kg^sMGF(M0@d@;j*vOnitDS6ArKV{lAk9zTB$r&c{ef{y{!N zZ5~8m^lqmgL>@*n=QL*3%V-k26^t>cTwvTpfixpxEHkXs`+2Zyv^9lB3{XV~o;npa zO#HEP_AYy!*sU5=7JX_Tw~ONdT1xJm-8@_KT+B*6)P9vZ1kha!CZ>j#B&w}{FGH)O zjs^$>z@LxxrHUJx>8cZH*RM~?$|<_rzB89DK^^=PoJM)a4% zgzxW%_*a(JD1kY8?86@LD}Jr}E|SG@zv&r#f4-aB!@xAxykxWH4#=)jgW7nKGIpT> zxun6BGNa%ah2NMJC#w1Mb{Db4!5YX5_zJim)hi8eIdTOsBzNlTT&O!2f{({MjwKd8 z*a(3oz`uX$bO@sJyqvV=MYC_-k;2R89y?jy-f&@}tD1zCXxBIf)Fn`ZM`GvgGHrQ5 zhv}*`SsCufFHw6I?fy0RSUt6 z@ogi3Twwhv;1Dh8J^Fkxa%oaqEwD8N`!`c!?5tI#)5w-QuijUr%%{VGMO-ziJsr2T z`PVId_tQeS2#vM8Kz+KscJCY+wZ?d%-e>-_4lg8AHnp6>Z|*X-8#WaqaAuBEODTMvW|A z2x#7iAvHm;YvR7T?fC;sr>~plFWjY(b<-TlQV;1$kB^qk-uacJ1?|ZZ zg^vRuakft97MX%$e0o8maE*rJ()MaH8V)lPzjt~f@X0ks?`67h)A^oF0%tzKRl{pg zwx4%%ZlXAB4!_GrG44C+cC=e-+$yuA@CtprdIITkU^+%9$rl{u$yn-8K|U-YUqtXt zX);k?Rkc24#)?7)f;2Z-Wyb zh9eZJOf$5+(U_A5O{HN*s7f~}PJC+rjFUMQu6uFuCNmFg>`d)3RBj{a>FwdRHOI%H zBQWU38Ngi(Zp!%?s{>Q(MVl`JR*{2*+)7@`BA1l;4>Bl5Ycy-3_XNCGG=qTLHcDdx?Bmm^j$o>rliSwuOE(LO# zUarNYyzwaCCnvjZvlDb*6#^4utWl*k4XzCzFR9Ukf8pTGrq!{zsLvP39&=Q%lAn&n z&nL9h&rZGx3y=F0kuqa0|0-=o$BoH+H0I{xKtAQSq$Cd8Rnl##O|TK$&C*=WHZeIA zIqaVtymlmp&P|s2O&UgyXo*R+BkIeA$LER(z9~=Mo+y8-rI&Frfug(b=3x%K@@ZlK z!++;clYZ0ts}=+%vmNGh+nKW5r{4V6+mlJ1Il?L3qX(rBWM*`!3bXlOD-4 z%*d>g@MY!Y)_w&*ZZ7hP7h_6DlnzXV;pUFibYfo+@g@_zBf{WWY<`f_M{Ufjx&%R@ z5{EH32sNF4wjPCLE|K|sl`1OqoCVP3*={31^*$lH%g6rxau6d}9=>lEBgIEv+10Rw z-iaxC9?((CEpXF|Vk#Xjw*fDTN_uU1 z+|%-eEtsWNhx==NnEBxQw5J9ko#StvlF_OO?C>`CG=3eZp8{+T{{|DErb2=83q&>6 zGD*^(*SpVoy*WR=kSn0td0H)lF|qE32wf(3>F#s$UjabqV@t*Jtc$=)mxMO>4`=PM zsXnc?LSN72m{HEjG>MW^XbDcxJ!mQ+YcbZMlv}k~{qg(f0O%wgCq0 z)SggZ`8kA-xqqeP(ZxNV%K7nWFjDpl|+k zfI_FsRKA0sgQdb?;isnzCCiTB+O4*!S!z9mk)5Ef#mI*Z$J&WvCqp@p^M6xsD9O&O zedaV#!X?kjt1>6)hPl;UgH)ycM+yI;Psr+AH~+(iI-gKO6M5wjBwhx|gUHh}-p=J8 zmzogEE4n$Y!|=A;oXd+ux^MLupqg|_5d3svPE$&^XhkF`g!oKxez6~(waSqxhR*Ye zaq_dPgta>vY#m~&bf`l%5|EN5DvwafjwYz2nIx0@4KxU-n9!(14Afa}A2Dt0ztvHo zq!as*F#KmkMVGacCdp!uk7qGTMfH;IbykU%$q$v!K|cmPq!K1vJf3}s;N5`rsdc=l zAfAe%7;I&OL3>95hJ602!t2b`lJc;9(?O(i;}n;ky+)-I-QE;6yx5TQZ?lhBZ2tx$>{&hADh#6+auYaBDYdZWOyG^rNNc6GAs{wW11h^7Crbg|pQ8 zPkP+N2HA2*z*M07g$x(tJ<=daN}ZNC zMoPm?hS;kWnw^1y6N?--R^Cr$)XdE$7xHZ-JHjGi)gfl&_=pI~IzvBvb{uwhA80tn z+*49R-96A0vIFU(lpr|~(OpI(kN)$tI;7NwPPvVb0^DW!+8EfNTDFsPF#s#&x* z0{d1jm!`kTK;O`VgXM*X`B(Q=ogyiQGYI*ymq`wle?|{7d)umi%+H^lG9P1#^a*dBN3K_yXj7V~LFnAhO@sJY^)K56}Nn zO%)l>gE~qLe*W$1o2K~!HQM-tHvY#hw$BvC5@1HMj=1NS$?=?T%w{!!eDK$dHjQ|2No{VDujA@UXIY`ejXULyc52s$YItrZ(N+PTv^j;t z{)H)06>C&D)-|Z-Y`Kzivi92~qMH(O5{(I|dhR@n|7bm;z@+?$|tQGHN7(r|H&|7vYb=e0AIvfSt}Y`Mh=8hr$QtovwDh1`)KG&;So&;7vsijuA+s z5$_>cNMps%)?i!ujYPQ{@7WEB{=1xxZ&5-Uzo`SMgxRXcDeNhXv^9W)cZ& z8~6}gz>Uz&Bm$CVYYILAh;3=zdJN1_p4Ex)-Vy(dc}@-5d$C`vbn8J7Tc^A3v8Tky zZUGNyWLt>AL#)aLn7~L3cLz=Z7u==0&KCaK%v|tDh&i8f#a4g0Kph@|(z+UBCBeiG z?RB7c#WZ~A<#dCj4$nM95PNuB8^R31e4(QOM-Lpus8T8}l`*RATMP8OUAI8GLZPPa zK$D-O|97AM{Cd4W51t|j8)XCY{#Lo*J;VMz3RfKksySJcZicmU3NplCW*``5oba)k z7s9aNJ3Ho9Ak?f!wJ4}G*7NJ<%zVHHI#Z03Zrjs68o6rrID#a-qa*ldzM8Xh-4Lge zmvq8;=@8Ldm-&n&D{lG6ti|SLZ+=l7Mk|lfFx}>%XL2P{+kRT_Uic$%zumo=5|p&h zwnN?RE?Ci!#d^S}o6%F0YjOj8n%OlQD5BWY7NlRBIEG|8QG{(cyw`HTGy!Oqj*hH} zY0G?gH1{>>PN>;zH7>1TPkP4BWRkuASx&)LAzQ~TwDU#d;@WviyKghl$R~BE{@SDV zr9&OsOx%Myx?QO#I*iqp67NzI+N4VHt4_p0lk2Hx(qgTLyffh_>Q>*U zk+SLK@(BRi){I6I=Eo3#H-KJ53NFu|)7Q+<-W^<{V&~YeddA)&N=1k9z*YOuR&>-b zj}qz8o&Y0;lkE+c^|)y~)5TP-;PHj_n2-}G_4hrrd39)MCwQjzv&AEcwPFhSusH1! z^F#>n!8Br+iBQ|92weNR+Z~in5Jz{0CCw^@zPtw7kp($LcKkG^%+og(O$#4Mi@@K* z0Yw=pFucIV{~J?@E@y@jSZk6@h#GK%_EQu{&v~0Dx}3Hv^(X_I*^^Dq%`*QwM(w9# z)8}O};(|vb%;N@Rs^mPB8rf*lg}O$2pLD&=?vUso=!27|SIVOsTWu#ifw&Qnq7>n= zFCp;mANnc2Mn{iaK6k|W`MC?2`9%P8;L%a^3Re1gc5i2S(+c^b#*1W?tl|{3-2j(- zkQ@^=3QHMOhtaFWcYm517PV2=A4kz*15ASP+~m)xea_9l4#7>Ss`VNp7}EC>2HuK| z)jrGW!Dan>7$&9+OIz2}vIg1YK5>IW578K$1 z{{>MpKycGb}1~v4my;+C!RY z?rCZ{b|;+9Tqf_81(wOU%d6<=u)IDdC{BadCb3qEq)^ zs+fU6IMY)qPRozgbvvhgr|3pMorX>b!=$*#S>D^H6vZ+sF8kB0_b8m$<p!R0J=u+LJ)XSO^rw-AtffxN6F(iM4pHFNz=9*jo;2a)#G&B*T z{LWGBPH{1u+jLR_F*=eSh$><_TQJ#k%|BWm=>8^C@otJ+!Mi#Fk*sBBCNu2BEpQdc z(YC(B*Pu=&53kJmp0#8bp^)Ya8_%K$WgG8=h|l|CCPl4|5|}Ztakg>GD^eKKY8W#YZEGHGRqL3OB?n}7 z2Oj*6d~#npzAh3k-FsN8VM`_FQ_uFR<19JEw+Pf)eHObD<9BPdTL=k6)5Hvy?95Ey zRh+8Bty#3q#hS8lm znRP7f#_Gn{ny6{)h?ZtowD%3#g2tRggcA>#9RdEiKJ9%|0*{(m6f9bf!-F?I84amd zYi)a5iRV%hfv;+$Q}OMeIrutb&8|7(FQ@C*wevF%iC)8&iC-=J-Z#tP7r^jD1V2@G zX)$@HfFcMnE+>JcEN-NvY}*GHB4Aq2$ExS7J}{j3$EotX&c=Hy{+c;x?HdM(q#uD4 z#dqnXff-4>;e5*FEqiW5Fg)`P&Y;*B%HSBWL{zWA=)F+rB5{lYw{hf3>2#EMCT=)1 z7ZPne^e4#8fJ*%6^`<7fhc)lA>)3Nk;~dwC;Y1DRi`C=E(p2jDV^tH?Y=N6~*Pb0* z7-U>@Kex8}>r}f+ub0^Lj>?}na$oz8bW#gj7@HwC_xj=faW$&-d)?E%>swY-7p#8M_Al_GSU$4xc{$rl6>6K;nI4J%qaI*F7K_x9gjDzBiQcT2 z(0y=EptUxCb~N(3sa^jEh-?ux-VI%E*!a zP>EW!h>$^X8m7)22NI^1KT_Q(az>7(DJMgdjj()Y6Qx(l!7FL8A;Py}*-*5(60S>~ z*Z0>=zMdsbwa5h_n$w{wfCVANgTx` zx#$)gA+PkZ25n?lW<4VLGJK11N zwY-o`H4{>N<(<3gp}{>{x6*z)NL|qN4u6d0Zfq~O-IHN5BYSe3bC<265L%=DP|xko z6N|5*|Mjn%vSrp`vI$A>eV6%NnFsv7n0T_i)mxeM@UG%%moF>bE*YX#4-$b<&FrOz z(Mb&W(=4Jx4eOhcl|1hFnfNsp5`KShZbLL06krJ&PCh$tZ3!!JesAta8e>DRK5C`S zonBp1xBUm)e4APw#(5$1Z}JY!uKuDy@1?F6$NRB92mAN^i_tKAbkikL)-TY?D@X+C z&=ep>7|x`}|I-36W0vk>H{pzDnN6SCah-Ek`Pj7bHfhq!`Tluy&M1g9;9qL5b-qHW zvVA|yC~)Hj@qUWLK4t&(Nj8NYpUb+=xL%63nSup&kL%Y#M04{rYaa31E?KDleiEwm`;O#y5BM)KmT2 zER{dZQK7%|zabD9I>C**GFNup^F81#GEv1zdP!a}9!x$S>y}4*G*Xa*Je`^S3>~Eb ziyQcVJbiUoRA1EfPy&L0fPmECj}~bdKw6QMMo?NoYUq)UK@bpeL}?hhLpp~Tx*3q} zj*;%J@A|&a`~Aaz!+Gw#d+)XO+UuO7Z@p$zbbHG2m$peHlzIh6TZ0mfyv|QTBFI22 ze~*F4@5Jz@#`}M$W_%;FId_E1tQ@(sdpWUSd^wK2JYc;e(~AmU^t^bIx_9bcoRlDO z7alA*BT}GLDc|BHWoivmc7q%y=qzKc`ooR)F^Jk><;$xL6d_)MYX!n zwz(}~U01MAp0atI&!ZFbd2{cNear@ z`b7_04*13fcuDQVU{b!P-dpokI|G*n>jmM$Yk8MAwM}Uzi^?o2?sZ81rpD{Ty`AH6 z{Q%978JaNhiy@BxDi>y34=vQzQLSzj(O-ajv@3uh@{%fjW#$K4n@N4yq}CX+)v$GmBlAN+9-9yqt%`liYreM10<&JquF!yNO;d#ny)*^Z$P1)>oKW8 zq8NNMqJAMU|Cx-*HRa7vySd2QrYhLMS&9Ai-;&USH1Y)&*tV>dg4n@46(8Pn0vL^)>j#ocy@g;bYCQ#?=J6 zl!K^%<2PI@=5_N5- zF@;Dc-_y=<$r8)+6MBai|3QUXW4k@n6>9CDMh`%vd^2O#F<`e)jMM8kG&FthFKl{orO)2ehde^f!^eV%A>l@W*W*{i3D_@Hrapg z!wK!ZY*i(7Qv^o$ zzgZtpl0S|=L=%t+P%7V>Nv?8gXgoax|E`G}R`-E0Jv%5JROHgQyKKkPOZvVRG*S{# zId}Ie?*l7!C&vvi+)GJY|2gbr{M|Y>DrB`uwJxf+FgqJFfCs{d7D*apviN??sXNbS zA^K*f#6&e6G*`3m?snj=V(R@JZ$%b~sQb;61)#E;N(f&alVq2EvT|jW^7JfyXh(3o zH?W?nCPSGmISkoVBZe3~#FZZeTnZ2^pAIPEQF z>xu+3=bnW&UUznUrvK`XdS`p$L4QVXa92)0Rx;M7I~XFbca8nQ8lWv?=TN!pcTiNd zckPl{Uv`={WfjL|y6(DLj8fW!K_pyykXn_a`T%6UTwwiV@6~fKUTeU{KqsYnqH?x@79l6D0O)ImXN8^VA`*+urOX>YUJE9DaT>Upj)D$cYMg8bLs=NH=98Ze$}rqp3M`i;AS1e$*>X8I#{+k@-5KMrB&>h1=qAbelK8vz(LHt` z!=*r`{vyq{cy0sZioIGsr8CCUji)x%Fl4H7;v~RXRJ0MIuM`bYEZ=-j1Kk{!>Y8OrGF#YPg+} zl-z4PSX{WY`&6oCyhz1hKE2*|elA>KcF6^KF*LdT+c)a`6_=yGczy3dtOIjbvSbvC zU%n_Ww~@L@TUAuGe|k zaqbv`b-7O4W72nPb(E^1V|6DCUaw4GuG4wJJx zPx#d*Xds2!H$n1RzsDFA*;IsPH;Qh?I>rqAowD7wR3qCd2W^+to=&7=5Ve=sT7HOM zL#n^YXIv_Pkrp(&;9?bW*HTulm&5PWDez?lQGCpNY!qjFC5^Y7E|lag%u?D5LaUK3 z)r(^yo1j49r|xi}QiqUozcz$ah`<+4t5iQ3(o9;|?%pqXiKn4z^%G5a?$$qHR(^q= zwCG5h-&0pkm2r-IqE7zr3#97bgl*EcvLv~BT7C9w=6Vd#PZX26JMHDUE1#N~21$bL zXe51Uq-q0Hqy7$e69ynjmH#+~xJH6O0XqYmjgpcRrUfy%yW^@Sxos>@X(-9Xm)UlI z*X#iaI2L#3nOhOk#A~k>tEOVIWA#EMrP4J^g+kXoB=D4Be>CtX$!WJ%W(~@##N`CK zmgijsM3oT0;Zx4|1m6FnaLE8~ovMeH_?L-J&f$0%ec91rE?<4BME}mUOsV>n?k4@X z?1BwHFFVfln6cYZZs3QC9W;x^@~IjwD=|`j3N7k05L>uz+%j@%w7+JMLhxIJllXoTcm+Fi z3nR3@*4&u=z#5I)&;P;&@;tc-|1WCooHtu{m1*UoIaYYYci@yj!Cm-`>~2J?M@bW9 zaLj~tFAUB~)VfS7E0i&|aM2`%sdm-yCMbAhqzLti>ugnp!FksG#G@n}9S zhX)p1V_I_B=RxZ;9t;L%1oICUzc*E0gsHWw5Q~{l zH;Z$Qbv=l4D%GC&*<~?e-KMH{hbTKfCt|tZmpd`-VdlLLPZDjZ9BQX_Enu zW^z~{Km-!WxGpp28)Mds;4qi9dU*ASQP;w)d)cd`J3a@S;ocaIvfMHyZnlL~BRRK& z4%BJd(A?zIZc*c>4EObXu4mFD1RR0#vu4xw{5M-_JPSAf`WU#mecHTN%vL#Ad^ zQ&F#46 zzoDy45cGB0Pz(J6QCD|j{NsRFVm`w1P(Glh?w?P1(l_Sz_<_1%l8%#T7h$$NAO+NSERg46F^^MoPgRZ7%`2)r>{y4O-XvV3;W4BR{ zA5+bfy%`LoX;lZ_S9})7lNz|Q-`38c$&ByT47oq=RSUQN;MDd*tR__KrFNyFyNHAm zpIJFrNH48fLEHYzQ)goq2ZeOTjr|K@*_#9|uA5w{&4u)KZ|wX;_4C3FO{9)u+zjZI z1QD794062Z(?p6w5Q;8nkzk-9L8rs{3Awj2a$5A(UF1BtL>aDH==z~|XdHK?nEP4A zk@YK|=%?^kxgK{wi|XSH0K!-hXAR-eKIswo`t8+EzfR{-GZTloTR@L!y6W00lAKWN z>AoJ5vTb<@Q)Un}4&+Kz*Qz#G?K|RQ5Y1DlUN^07zrlO10-075i=_uDY;^9fzG{`Q zHbt`YU$f7G=5*vWV$*77=-R_ZS!3JzT9MT|6I^zsYK1S+@%z8nxw+G;c;%uQYt@S8FsRvnU*3TrahhOfeok`Q;O0v7LMOhmLi5u3-#5Nu$}O+ z!%^2FWB7lh8OsyhWVn%*quYB8{(e_Qvgo>t&Iu16qb<2DL5;zW2;%a;=CA|G8DbSa zkR{r{L4fyv`GLP~*~9zTWlGOa{@gOa$?{BMwZ8OjKdzqDNPNr4_rY)T6gPC7zrN*S zZj{nZkfsXG&V4q>2Lh=GZ5G$Wp^pbP`{0#xCPw#6Bb+Y?RqkA5@+}uus>YK&XtyHR z0chyzy2T}1FeZx*)YVGH*STSu>`jbaL57Qiwf^sy9?JTO zZ<0?K*6?b*<4D1tUC2!kUeiRnu#-&H`7`4>|c+l_kaH^ zJk>EAEaJ~3aDq$lgYAFHGKn$dMKFj$O8Bl7PKz&p;M7IO209qSfNzJ)kDXm2VLA>A z_;I9-)UR!$FoYdxP+ZAfDX&VUou#OwK|d+dR`S)ksmwr~x7-Ueji(bVoH|^$Yc%6| z0d~f~O+B-)NNpkdqMBV()JW~Ej>K={l9)}-%+hnWA1aw*+q1^=ji(ni24*)EMFWQp zOB2wnfLBqzuEbfjkO}kNSo2Z>U7bTiyamLgNMD&}RLaYk)8V3e1dkbU+y0K7tz9v7 z?4XsWBM$jLO;xHly+=wVn7F7oOa9OXzBE=B% z+^CcSdq%z76a5bg{f?!~^`q^;p&u6{Yxu_+*;`?6N8 z|Da~h=x%-OWa4h|bfCUOunF{PL!@Y-mABmHQ-wPobuOISt8~q(HrW33e`#;=?VG}` zTd34T8%^A@RJZ@jLy!FH;y$xxX!Q3msyF873>7&}-PZCYZf#$#83+9_YQzp1rCv8gt!IIDk%H1&Kd) z1bAoD<-l|yytLA1M}28Q51Zh@XkFa?h8%kIgRo_fM~lUPTICmR7r|`c!wq1>d{j0i z%sDs*3iyx<37XIIIjNE~yDzzHi&y6pqED3MM{G} zALR3~ImaTI_GL4lSTw2jp(PJE9gLLl*zG})q~^zA{rSEuFJQit5VHm8Hyx~dU(FYK zc+A)1yZ#wqZ|Yu!On&SVefUfCNy`O~;p52FuBZ>4^`+|EQiiBoQ$%2Qh^S^HjuTElJON7y16Ou# zWhZD7QZSMH~*5N&kQg|pCawmJx%-H8dt(n0SqsXKAKvW}c3h)oojc_28&DjiSoNO#M#WS9;H`+G5>Xv<#n(a`duKbqha9HxW7h^+dz}HNDe1-C4+s z-g~b=6v@b|KjECY;5$_Q;dX9#$N9B@s$xB6e*MeJ6glavb?Mj97}NMGNX^FN$4&|Em$F!5Faq&2Sb0_Sm?HoR(R z#`9)(_hf>8?&QIrD?vzV$Vl+;Jr3GC4u1H(h&O@mta|(Tx&9|$T88w~Ftl!ASo`OFS)aMi_Ipqrv}RIb9!v21i+}IxfLqf% z?le0TxsC+HUb&$3_&mO0?*)ug8Oj=0ydRn+eNzydlPl}H$q9$$JU>eX;lJ6V_4xkp ztrpD>Adz!1Vt{De6bgw@_J6GkLx0_};u_#Q>lw=3pL@2olG=B1*?WA9x*+%SF81EU z0+WGE`LgOL2Jf~3O!DsKmWM}i!#wkDbu;fmyurZGnC!&5iv6ub9ISGUxoe~C5m#vm z7tKqOe?k4_@_3}_!1@V(YJ&M48PmLp&rS`{$m|B1El*ifMPqtIsf4e7MGwgtda9`P z5R(U-=d|Pw-c4iMST1`G+;8?XWH%dcHk0}9sM5T2?pK%lQZdSKih*8XEoL0EP`LVgnO>s&#Qe!e!cy> zWt4SqTfXNY0SIPWoFNWL4P@HBppj(R`RF#Gzf~O|ZQ8x{DVwBT3t7r*n*Qr_NAc+pDUVG+00^Ej7{M{F!0>CTrsGkdsHo z{cDt251F>m$JqGJKb;{@wquxVm-K3$6zCPnzz;2&&|1*&Mu}`tIB6Fc8j{IRWm`F1P$?~*LG@JR-C{1bkWLv_johm5| zyIm-WvxeV_|DC!m^|8pTxK1{j*}FBTJG&G}X!x4dBn}^HXP%LIlZ^DcUFEzD-x%&+ z_{_q!cH&P)zq@UGE9>ZJcKJkVlgCy}&lQrL4(ATom!WfHQGnXmSwdFXN6vsg#2bSw% zL&i%HiuOmlZ?00o25&J5z1O+D+B+8?bfYDQeOFwMItz__cob|Gl$lxS@1%|82o*?W!l53=~y$s z!&Tj4_tJ?-gdx4QJ*krJ#Te&<34~U)6Pp5v;$}6f>6*MS`w}iWUktWl>zM)c0REbK zC{Nl<8n*o5H`RN&f1drerOEUYQw-~}-)Uc-N+3y1D&+Go*GYUz^MZ&?Wp;Fb%r$!6~^tSOL@I*Xe32isNZz$4+Zft5La~nih8CVXKg(&Abl2g zF}=)Ln4J$MXZiiE(|`M?oX}sgX#;m3xe8i+y^5VY>u}3S?pu+O36)0j--+JzLP*sh9OJb~LwePD%2wTXkD@Ot& z;@qhPRPCH8s&=@+jn!Y48?#|K)3V{mjlv=qMJ2>VpnJSxPG*P|`AY;0#6%90 z3Zpg7>v*)lzv|o&w$y5n$Qq|Ux1k+wSH+1q?530q z#mt{}oQ%(TK%T3qZ9Lu|X)`uXJF)g%!P}@vda!tj=t5zO9#<+($oxk_ek(ff^zcl2 z9H2DgPSTS^AB_~ouU$#p*!H=cK-+7f)aWvEePxF9*VCdYl^aGgid?Kz9JME_M#G)3)4;NQXUrl{xA)94Tv#Pn!MD?#{ro=XO9v=mY$|&8 zxyc}GQ`Uo8jCFPjb=@R8NyNTExnZ{Se)_mZoWUae^P5u~8;LjY$2g!2I}y>7?R@Z6 z45~M*>0j5|V7mNJF6p~rviy;2W{sO|mDg6}a$ky7^3liF7i$n-XW!g8eD<}Ewc>&V z>%vi|J)*8Ca;G~+P;36-^|daHRtBOgc@btPa%F`C}Y3`o*-L8ohq@S|b7qX9|8 z?j^?`iNI&oJsp~7Cm2zP#wNJyiq9+3<;scR{`UXMhImOd2pP9s;TWy)XaDB~NaYUB zzPr86x73tN&Pr9I+!m3?4f86wI%#j<@H%ED@54VM{yz9vy$9WG4{BlUES*~L-$@=b zxWzqv4ocF6stq{*D8@YQ_K~-wOp6rZ-igfe`fDuPbZ#-2k|ccw$6J>U8e~4y`0)Hn z#d*@}K%P}_u!U8sbjtJ=YXI>-SO3EwXyZTs?*3o!&eB!3l_Lt}ZW156d(bW1t6g+? z-hV;PKdRCAmVeMUi*ZZ_)MYOS4C-;d5@yc3`jq+r11jI4w?BQHFW+yJ|4mn+u%VIm zrA@19iH;T@#n;s{!Hp}`P{YU{RPd_g{9<(r{Ljyd`c1EO?jYPb{dQ7`x%&?c2fxeZ zrJE4r$%J9s`dae9^o&})STX5}DZjLJG+JntM|MS3v6hW(pAO@J`#L#D-``o9%|<&qbtQ=) z%&pBzQJEq8y>(QoRP5GsZz|H;>*_k1-*Gr{R$0YqCa^!nqRjnrGzxHo#3UTfF8pXc zq$0Br7x@~cT`y^G=5*#!;^;9^0?gOuDX*UuIIft@ya=a8);+7$lCt~pBpB1w11;-- z{#qNtDh^Fe!DwkVtxc1jV$fRLZ)6$o4Y}Nmp)CbAOFRfMeKUWD2V) zt@Q6O5^gP8TX_nX}Pr z82DdXGdR&#kxCZi{A5dQlKgw*`^>2YFN=!C>!7vH6DYZV0(J8O_#_O=<==6(e62{O zWj;RU*i!UlW5otzRihr%I@$iw{bM!Ene>d0Y zhy1lvIoe&d+Gpc?REb%Sm^nPMf;-=F+xSs_I~#_m-_CJj&%1^9u=J^3{^|aQ!G>Pz z!K!*!=FYG0IxKK0$d%@@$IZ`%0TY6bhJ=rL(#D5O-y>GmWt7e}_l7>7%$nr~O0>~u z+^cVX@4ET4%v+m%i{ClNQ2v@kb^dS*blCkF-#1>l_3I{;M=kvz_u(e7g@=v0q>$a#m&swf14$REDOn)zm42mzCmPQB0(I zR1+9ZD&8Npa~ zrCEvVB&AEOAH6YM)+t{8#jeXJyN{Q6F{P)ksbiUsJe3IPU4*80$Rum(g4QvL@U3;L zt$EBq>Daw@A;ZI>D8-%!u}`=!)>*}>6?{yIi3=R@tUcJ9ei>c=I`=X@RjPc+xoJI+ zlq7TYqEY0`zDf_C!}w-^sRI-2Lg{gtIZ(8l=2kehP=^{aMR8wWvhY=@NNdD)Iz&{4 zV#wahhWl{Fk2iZPjdC!|;^y;mdH~p!_By{)jE6skh^Tqtj1kJI& z3NU~0S}qPQt!W}7Aozw$iWxS}^&#ih)OhM^oIve5_HAQ+C#i)_+#9^4$cQuN-GU*# zn*=}v**11Ni0jq9p=x<@A$p=MHM`w4H`Dn3%DukH2U=h64g=hXq!DN{)rd*|H$Qqa zKisr;Fo4QaoKIRLrbZdbOCngFN>}Y)N2KPZUQ8K!UFNp37>=T`c;76=H%kEgNACEq ztZTrJ)&cuavN&@V3@=t^Yr$q&rPtBrI`<3!YzQhTfVHvI$ z{l_S4Y+;07o@q**){o7>=+LGWJI18q)^%r|QjD)=-3`Nlir z{W#J1;s01{kTRoxmE+ig*~B1o-BbJ0t|D(zQl%wer&CkCts^m|-qnm_1F@~cE1^rY zfSq%fbmey1eAH|!Vj8;R53{YP_r|+977?gqd&#l$pAxm%3?+3j$(LecVk2CQaw@cI z)-P~W?6t{+r5W>SmsRMz=DEDybHST)Dw46Tl>9eV196#~Q?73%bnmN1$Wth!>^Xf< zj;s~_dbQQ2?NlVTS?qSNC?t*x`zt?)cBr!hw>+qCix8&?z za<)DkJK*kgqLEpTiZT6Qs__Ty-m-oNg(#rTZ$~qjv$wcyuIXuSkhvP`DJafc9;LO- zo(&ilTM#}tny~?k(K&g|&6SF}Bk?Ev^l$;-Ywn>g@J89~xd_60^?eLGV@S+x$VG`c zXb2+xd#t0nR&J|rb*b(9Nb0Y}3^Q&S4H(^%KN4g+v=1d7FJ1;;X&_Ya!kTmvml?kC z8$(`dv!A^CCdTIT8WCO)K~gQ1w@R*iw37j?LZ;+3>@mwEJ>~CDPVn0dp6U&Y7*(yp zs%oEX+)Q7CyId;7HfJ}bcbtL8`QWnUr zjZ`8~>p%WE+FBtCF_Jh4v&+9-$u4!hZ9)0TCw-r8^Q;y8e#H=^4Lq4$NzG+_A95#V zCV9z`>J$y$o>7+Y(M=`&3e};%GOG4cc|ZKtzY6l=uu-CErY`KDEFpIwIWO7Er9kTJ zLzOZ7$$iz_or*G9WzfBUk`36yz$a)x=jb*kmw_CecDhJ;EcL^9nGzax*Q}bV)cDWxZg!?BRiF_ zz7;AL_5k^nB=arLko(LCWHno;lB=ElfJltz5+qrny&_A2lqHcKJfSGBYG{M|&OR+W z>)YU+ulp4KN7yIwZ!U3>)`r-bU`{`=wf9}fWi<*_+kQs->-gAe(05k|_k1*(*l`9w znCgp;R>_0%ykCCib>*E@n}s9&-@}-WY4Pr?onQxNu0D9F%{+F5SfZrrE^F562tfoG5T(N$^cy6btr24WR zbL@KU5;)!)iRoI5q>?#|3YAh9da{H&z!|-&XaO(Xp1l4*`z~YmV-(Y{*bkPcm@%-V zsDX)RgMOm-Z|XPLzV{~z)UoSo@4W;`GcE*(tbI*?(*Ov)>{-jumM8j6slLr~lD@NX zXFjiDesiyQ=M*vl$c1x+aZtjtNA+F&#K_LM>_r3pyGSmGU`~(5P4e}($=Z(d&^HE*&cHU*!@`6 zhS8BTu+nXx5;mUf<~7bg78!S!L~a$ONBIfZ(#rOA4krDW;49afn7oGf7mi9Q%Xb_= z%s9fqQD^^=vAD7gv7Q>bGeI(VNCDoy zj7*MT$ty+M!%sbVx@O12*YuLuAZNl|Nii9QN?*l;huAVV)^P&U$<_M&+zxVprap)IUnJcdT8hY9p zE&jozl2=unec6|~*`>z{p!bN!O2x`78xhM(y8_JiWQub!z_**;*eeG7(Xlo4NTl;! z-1K~tagL}=tqOD}NT|Ie^IWvKrgsgZ@(s8s| z!6)Z{^1Frcx2PI2F=J?NY`Frr)J(pFs?yf89SE-5(jwO)#gj|(l6K#%lu>a z_v6xv{rpd%W{wBHU$b$g`7{!tbi>7&{D20Y}$=p-WhuYQq2#`_9>`YS~7 zeyg3HTBHrpQm`eJ-m*^Lo`Vlz7vEPut@y{^tO6{=L>QdZR!H2=)iqKL`e4MkgzFu} znO$Z}J|ergmiWbOtkCI_0}RGQgOJTKp8$ z?!;KM)YSlt;J&aJtTVlK!8%lb8ws{mIiTT`q?CaP67Ip z71OKFOm-dRq&SmnU!$0eT@Qn11f1$7GhMnLVa04ehSAHO@rmw4OAlYJK+F)4c)NW9 z!*P~e?=sMG68TxZ|ONQHGa1D2s}QC zVq@-bkplcv@=2tGbK1F6^xNCV_mcUJ$k@;K-3?VCt-%rbuc$CD!mX&H+e+@K7yI0Z z)WJZ^Op@M^&&*4&#l?$sTt#bi)J0x(K>6-C))w_{#py}j#4Uc!cpqPz z{eGY-setOTJUPgmg8Vr#Tjp))#P*Np7*lx7l=mGiL|oZFR-HD-4axtU&n(ItBFfQE z3xN-O9GPjeD3FpAev_C`61`QiRtjNwm7PzipbG*4BvYGWOz9_Sl&3gddyqS07Z6sb zSDB{PKacC{=Md@~`V*7S2CRqwQrO|KpDi%iqoXVh#4Ug6+8!lh?r5-7(vqM6n__QQ zfYbP7=qH-yDa3T>=oxW^W?u+A!{AeVk*65PBMKBC+B)OpBnFvNbGpz{2GA)ofdIF& z{YzkPgy$q<=gr)FUX3taHN(GeySZyGd;SqZY=~M@RY^HIv}L=>oVsS4daAN3;U9HK zxY8Xpxef9lNBI4@{OjY3bbZTb&^vNssFnOQ#!fe;^!cM#G5MfKz@k^R=x_D}a6D0e zS;L!6TQBBb#t3Hv3qP(&s5)t^V4hMH`L*m%GKpxYB1Ke!v1XH z5)1Lidcucq4S`}r_Wz5~(&nO;hUl3CZqk>fBzvRsUoibFmkT*61suQygq?N8p}f5? zb{q-oY#9?r5%zRn?PqaFe7*SN?u?VF>8eE^$78Qif(dgYuB`-y0Rbs1uk09&g~mji zU5SfpUs4&D5sPQ=A&4VPo(l3-*)GxRt;J9;QsQ|L=vEJE<0OqL*?vE7{79UWg~~dY z;}J8IbX>WSvQ&+nsmN?OE)ht>F5w!iAMmr({Zff)&d z3l&@1sf1{zj9rT;rUm@e!r9fe!T6u{zsAWYx+BzMMTD|qn81>&iIbU~>WyNgNa^wo zm7B+WL5dcB1%N1^4{4D`942k)_K%81GUhZ&+^ zS?fbj1*wU3C1r~W`Qf;8Y1lzx)`GLiRf#MnvV08UUy5*<{WA$OwsYgpmF1r4pK>fx zk2@|6_wzV$k+88xjl0h*OCZouhc1vi%7`a^gz+gX)8h`wx9h6&Llo7i}W{FKPd zRqo+VG~W_L$4*Qh@zpw4WYES=X=dDVhiz9a&F1|&K zI}JH{mIIozS%{A&M=i?bVDM;v#KFIQXNnPQXa9-@EKPpL7%*-fKOPN8bq#6<0$qKE zaAO$L$9lGub^FAU2s9Y|FQ9%5`+KCxea8ESzsqn`*^V97alK#G_K@mKWf2_|IlL}h zaqm@esl;P?&X(BdUx9CX{;bGYKAw>e>2cCa<2x|zg~gxQ4+`(mK0G5u__)e5HQyew zJ^DU%j#!a)Sd2E1RJ=sv%%^(jYQ~G4kX3$ugpR#GpNA5g$;NwD`A${jjmKw>G$Gr5 z3r1ed=PaJ=G)^dpoj_Z!N!%Z7Ef8a>gyA0loHGw2h|N4siN3~HKsx-W3WIV>Jn4Bz z zM7eBqzc~tbQj(d)CcjkxCr5iOx~F-bfP)>iE-RI|G;@a z{`^_Xh>${MXPoc~2x$+}{$OaQcI61gt`CHEvHLV1$&8@C(p zFCqC-poYN-kh?zyS4C|46F7H4plD6oZa!aTU3$T*W%W@3CdmoGtZ~s&xs$ZO+oRt8 zXPOa#A*}BBsn>%Dre}ELF%+JZ(nHxa^(jL=cge#XEfyua|M1~i3)Y!0rlOu+7PHNo zqpJ+d8hTP~7814nJzNH7G~`NSXp%Ora{v)nH~;LQLB(I(4bEp8vr0`3C{_0pJ%Vg! zuAPsRG146dj1EVGD9D2a?VFs{6mPR)v;=4;6?*;Y8@zl~#aU&|)xN<~%kR?zaBg-; z1pB<`7A3jb^Pvv2E{D-0iG-+5o<=dPN?I=G)qj>!EjjX@uvOB+4dq3j1VXZga(o3e znXqFGLfiGe{X%&aK}k*vVF+X? zU)C&22Y71&t}Qf=UZd`vLi|@d+XxKb?y^s5V#5;Q`6d+soxB0<_&bqbk5u|UJ}9od zwj9>u#?)jna3|*w=j1^qSX4KIVsjn#NU3)yxuip91Ru!tQLxL#n_&h&NTeSZ@XCK4 zR67icN|x!_zERd%<^CUaCDIXGbIrK=<%^sF~$nc zWfn40|L%saU^gR_bFC|Dah+ts@3=J9+M#af&0gK+hXQ`%)O^8}v-JWeoNe#XQB>mD zw+mjyv(~|-)sE4GNOA>4OE72lS=T}QD&Y!&C5C@m<7> zt=IZ0hqN(7PWy7|nS(biej^I;RdpY8FN~ zsmbbSq@Qxc^Y!ekvisMg;97p+nNLC|_OqI#yGiP%n7Yoh^^`u01JNlztNDUaq_+8{ zRhVr)W?OP1XNkN3^D2iO<^IdoQJ5bqYkU5aUM%=H3B#AwV6*w{(*R~r&5Kf(RvGJi zcv5_e>U3np2hRmZI5ccoq_U;tc+RfT=YJZis`kjU<=0w#n>I=GCJjVBve8+IiBIgI zOZt*dHqw)e`yYiWDdH$y@LQ70T9S58I_9$E9#?KGL*IL`ZEkSZr~9*31M=SUtFqhC zE7tL6rG6tF?8<;?OqGm}c6A2VfAeUzBJ0-mN1nrX>i#n_bMoTSAFZEh9vN%5P}jJ$ ziRP6Pyw&3#qAvAcW7!~Acg^O|irk!)C?>BCVvsx|bJ(Gezx)B!+;dXX z&`Pr;>Z4*;EBmvKj89v&m8GPnTZv4sjJ6~Sz-orY9sLBWN3s@@y6h3R8H9)&T8v|K zNDL&ielZ!xZU1C@ndG$0BbfwVS(&g|e;!V{RM%d}=dR3SmI#w^RY1J+c1p8}lk1_V zmNiTebW1#)vQ1zfzQ<+cDiuRmyVq|`QG+=a zBP@MVt_Ov-N~P-M9oazi@z$O>4pV}WmFmUZK9R4`+_EOiqEVd|pbT|rMgLZ5gvLRd z#Gv_~95R=l2^jkM8WM|o_-#dvH=^zm3pz|vZU~?8-G12B2a$>OH1yH1sId1PKqUBt zCY}O*;|Krz#`k9lAw=SDHEfX&)tN%*Jliz=AUCA6M5yQ8G8&=0HiEXmx!UZOdF|h+ zU%O}^99|PXie`1F4{`0soKZ4hUr(QYKNi4~iK1oar2i7xnspwzqP~ITNP1~U@;jjR z2TZvl;C`jE^T%PqKP}Y7P+Xo={3Pg~k}(&)Fr3XBwa<^ zf57#)yysEysAgMu_PTZUL88!V1yNg1Fe>S9AuD`Bwo_-7i&L%Yv{c6NiZ9JG!KmNKNPG^?@Q3y9GB|V?dL_14HUrH=b+)l z`?Yz3usw~DftDQWd~~*u`S53X*kH@^*ySBPCyQiaxg!n(thrAFJ#*A?QvQT7{GsYh zR}fiPE*G4RLcL{`_ZzvfTVPMnFs^uRkUH7}@mNqDK@c<&!}omX71nlJ;tlqgVco@U zJI6$Hhv$TExXpTn^wHMh1%6=Xjp$X|5X7i`gWQ1WzeX4>L*R_K*V<3C5$zpAYUaB3 zr5nGUhRG_G7DK?Z)X~~3NN?IZxMmY@c5(Bw<1-1n zC2^+v9yJ`DG>>Lej_4pC%u4Y)?y3Br7r^#ns)Kp0r3+#RGtFQ(>1`z3lny*J{*2po zuR}2px9f4fu7hM8g!`(Ej<{GPll0$5&f zd&Fo}tq7Jicr{CBFYf+kmO0tiNN;@_=O4+d+d7|Ry5eNQs8#v${B65lC6C;D`Zjlw z?S~4ipiASed@ErKFC0 zogf5&amI_MN6K2}^jeaRZIwJ^fdF>?7yb;P7Lr$2H1{a!dJzU}qjdd}u73C)85Os! zC1erBO0mfj9S=~z(w?6xYS*t0(%K8(ZT~8qJ@0|03_h{k1%?CRy=df=1H|X7cHD0`)ke%#*2!P?EL-!LhaEZEa3i<`o-o%ji^`9FX0dQu4S z9gcz=p2uzRyb+3M>>6)7~KyUk>ce^Iv3j0{@I5^Vh$yf*QbItz_zA zMe8~lOAuWF;w5XSs`$t^+c~O`uTWm!}!U~DcQO)z~U#2fH zCbVw{)S8bXo978Ap8jn0Cfs6i#QA?MU3Xm4?bj~N%u4OC(%hA~axa{rW`$_D%g2FQ zR!&@~iGpR8R_30$2RO@-XlUk4aO4&TZc#|hiF@^adwwtf@ekae`#$G7*V#AR99mgI z%_RF|dp9n~N**_F)iK>fOy3aAl<)C@>XgC)wXab7E8}EN2Ut8S4<1}Jj1nI}_UGTW ztZ7GzTms%M!P#;o;Esr%SVn=s(^#1Wt5m%})|AtCgSfpmLVG@LU>8`E_@QCS{Abli zb0}su1*3C0vHUzXuU(2)n1p!^425|+#y9|Zt)LRD@V?L^2c@RJ7R@wUD`gc2iBG^XBIRP1Yj@Bci-Vr1cAjE_h?szgZ$s%k?co)BN_^V)zVVWYNCy|@+&M~N?P)$i_x==~E)Wkqy)|pS zk7OYV;YQEp-X?eqezaUaJTd4LXuoP=y7z&~{Rf z8WFbkxQb21eif7{N-k;7WB%{z~38w;NiXvwQ==(88&r8D32mBs<=lC+YDUMM{zPL z@)O)&EtHrasXnyS&I-8wZ56l_Ae^2f zpMmI*FlD>KKre1OK&%a#Uz$ADkn=j7hy>ZD!;|%vE{*KJ=zXLy+`s2*tLE~y3}zT5 zJitg7(Z>wvQ01xhf_El=b|iz*h4T<(aOEkhXI@W-yswI~SO%`9!lN$WZ{S&YSk(%8OLcgX^Jly9(j%Z0)S!}71I|Lm*=`)r7a-o!?l#{Kp}SgSJ` z^5137<$QJiqcSPkTD`;EU#%vG>zBn;k%IXubRbh4Jum*|2E=*~x)&(0O?v(x!U5JP zx!fKIh8XhgdBt8UhAnEVcr3zQC?pnh4}7)Q-HslegayrPZWyc~-LIye9~8=(<>QmT9@1%y>wb4xfM}tY*BQwH4B8v?F+Fo=mwi_^D!!+=Bsbg zAj>q~0Z0o&s;fZxMPqMVx&h-cBjRT$<KrUGvp; zColr6c1C$65B3nD_0lEs_iXL*TBHixaM9}0l_SImCnKG9j=Lc2n>`d3>fVp2@SR?o9(&OGME^;}|~f}kTh za~AqDEzXg>ks$$GryRi{RH{bL`bvf98QhPvt!1eS*xpkcG>qD0Hcg_U*VgMYAV!5g zY@e_I<>L<)HcPvtudn;|(kCyC``-d)kQuZX;*amlXXA%(0%hj(`+~Fs0ZG$XyB5Un z>A1`P-gAFf0hPJxgV_D9kKhvy$-`Ak`(P6#E!E?QH@@?HfC4ZS+^FU`gg7dgi_)}x z(uRkQ96P(mE}zKfxSw{%5FtiHgnLbhsUC=G_y0@S(IF$2QMz%0Xm)YKOIVhV77u^! zTyC6v9>w#RDR;2r%mw9tojLl)p$r7oyLckJ0K@Z81#J`w3se;Y9L4vL3NXlTMYp$! zYs%#)S!+|?lB88KV;L#iZOD4Cmj95`e8b?olu0J?B<=1P>jjnu&Do3K?|X_D#Luv$nb~KvnCCK@F;heMn=}B%|Q##&= zX_(Y_OQVd3c*9a@vf$ANf8b}uqckn++iJJzp1CM1;}Ntyk~T)KW|me4g!EcdlO+)H7t!Xk zd!G1DWV+x}-e$$y8KnA?N&Ma1reEGYWf~KNhTR_%*}DezIdxm`wOKAkr#%vS&~|~G zKZ6qHpK}ez``qZe5+5h>uEBev%9wWhgH`^v*fnRQ?!8L=MFzsR7>G+Ww*qeJL(QCu ze?S!OAWA?6f5T@%`%u(bomEnbUr}U#d;DM%2riw-wS1Pxj{Hk5Qr6$<0&h4+{=Qgb za-eFeKfhYN-*;{D>J|9KEA&D%YwJ?F$Ek7#R<5vuvU?#qZNR&_ZtTVeKPww3_*}1F z`f*j$94_IH#6eV6Y!cWXzR$%D5I6-j&4Rx0{+z0=R7RZ956lm$J}H`hQkXUl<#+md zY|iNV!KOCD@e-MQ)-9K*j`x)AQYb_lK#-k9Kd;8w|zfz1z zGkI>l{A989w~=MUkB)XTf;nv7o5Nf1&zN3T2K)zm!x};98 zPH(pJu#V#$b@7%@hTSh^dVTzSDx;R=8|REW`iM?ZzS> zSAHOi7Am?dKeCGsl@_q|uDi-&ql1UmiLh8$g-S^}PY1lEipSHKc-U77((eh2_o8?z zjuR#$@-cDp^RG0cw{q@<6$YgoLKp6Om|uD@+!l+nztD}`K$<+2kWo>*Q?(o}FcWO@ z*FeIZDdKF>BK_*_HnuBrqc;qqfUHo3x^<0uo4>wev^&~Wb0bMIQebqBezo%-QB_b7 z^>L7yosmw%zc*zXO*UrT4COz+iNNT0O8Ymz@q~k*HET79-=LH_$7+`Vwk0>Mo)cfX z2NxYa%TeXK@T0^q+6W{Yz92}SuH4z zPv!{p`8)4iiao9MS4}%ZxuTsxYJ|mac_-o4=V=L8W^5%d-|^h0bu!WT!hBH1XYKwJ!t>l)UxnqDmHaq9Fw)PPeo4sg zc~q}5wuWMe=Sy1k%id2LK8a+%pgb(rXO{LZR6-Bc@z0KJaYMjwfk^L|ClV2d&Z}-6 zCrZbDM|DBEgVr-DwXK0zld(pyjm<;e<}GQ65ZkXjSqRX0%r?f|-tD}rd~y_GY>4!R zrCngnH%d&Y4xu9AhX7jSG~@j~3(jq(awr=~z6`o0y{9nv-5qJXCnk`!@BU?AR~{tv zbCGmnWUD;Mc)%==Ay)JP2R6a{m0gDqHk{^xgF~$8Q;nhpdI&9pMB6N7x;%b$^vxf& z3F5q>ElAGm(C13*#>-^^oEyehE;}$VlWG{B@2)j8v3qPCyghGepYiKUj63zg@@a{* z%sd(e{aj4B#)1JJ4C7s~|M%n?l1`0=?%Sm@r!&ukz%w9MBLaPN{}Zo`&R~~1j%Gtm z_S(KK0|)6ovS)kC&`D<=>?U_rKoO;1-1^&_n6= z`1NOtCWhS+#L-4T6yS}#MwWCdsv04RnR>x57A6aV{>JAzgJ*? z@6WTl;bdK_LEws}?5B{u6JG_bRHi`gQ?%~gNn1|YoK6sCSZC#o{gz?(fI! z>-G(%6xD8z2frFf97kDVpc961lAn?p38EK(%s7)donpItTSU_ZW%A^0pcol4E*6>9 ztecR7HwHv%Bi_z4UbOpoTI0EMsdwT>X~5n%xMU>=DlQzwNF55;XagGLw_F2#S*ebq z@V)%LeJuon@jZ-auK&YzGNl$sT(Y{3_m6*DQz>=Z(~5>wn%Ngt(3{G@b$1u+l)JO z1tQMHE9aokQT~K(n5Q}vN$igqe%;9UANXT>X`O*oXb>2ee1c2YPmkZ zW3lGrdC-%45m7x#A66yMsS3_0%RDKwTaHN~CT3~bwrHi#-8011jqW0t(I7Cdj^wqf z-kF{<{B2)fKy8Y@M=r_6BR-dAUrLkAx&lJM7NmXdS4A$B-x40^*Nlm=%Ok(D+U+^i z!a2Qk9uTl%e7Gc6yCJ!AT=qEsD8bhi&)cNgB?NRrRxe9<{r)e% zHw~635Mu#N#x>;#xbi?=2Z{yPM>~FcQ^v?qSDxCB6*yfQO=8Ko*CtmNX7_ z0TkCpD4W=+9?b_C5g)z2UR>QH;C1!c5aUd_@_w7@g_dEYA55~ZzMO@JGW~ua$Rh3B zD#4ERluY8_hyq8bN2}sv&9cO61|Ih*cY}3M8K7%3aS162=Rf*c@+!Ir?|IieJh)#p z#TDuO?-P9~ZQ539#atjNjzPUZ0i%2~tv}hJvv(H-hQ5OYKdk0dFrL9FybGX9A@syFnkV2a`&+clq+%yMhG{htFUg;h`R zwXvq`s(EHsVZs*A4L{@8zBd_Ir4!;9`dGvwgv#+-p9<=3bQVm|VtP>Ats9g<^zykk zI&A7cYI}Rae(~b)Y75hQPQ>zwFD;*EOvhBRB|?hKz1XJVWk~P$3=Q|AjrqG;s{!>Y zO<*1eQzXZov~4XgiLC3)oD*4m(3szI-oa&^p21sJ)CzI`tJd(PY)Y8JFdp0g5maIQr*nD4>k z)M9f?GR0jhcjmLS)=CgNnbYHEbxnS^+hhqgTtzDk)lZ7{2GYqdvsM0j&Qe$um8LES zu3FF8R}!9W{oMWYV0ym@p?N+g zAh!Rz)uH|JOyI3E2s7aEr7hrj7sXri_-+;Q@;{G!)~(#2L;n&ByQzX9;+N1S4Oa_} zw$N$dSogSd_xWRoROg2Q&2p)rBBQ=kt^tb-jRH31ntcMZ)D&n;si+_H@GRtk zrw?5e^WHG>{72tRMbRzYzn7@Mq(%U=6};iN#HuP(j(6!6^d)pekLFiFtZkIpM*B7e z2P`I7QGbJOZJebClq{-qgql$KXv(L<)u8Dh=uzK?yRX8&!mLZ;85=cUcH#X2g|*wZ zXS+0qb`{3aQ3KI^L%4b`Y7unrUCDS!;!|+Zu><8a&$m{=@rKd4#p=D;eX%WJ9aWF^7csO!EF;CS>qwrxFoQ3g zJFb4HRI zexh!VXTSm;RH_rgWH5*OboP>(^mKsT(x20s zn)4(xfC=_}7E^`wLidFH=FJy)tAqEO#TyM4q(hQ?W!>bT4q&V{uWlXV)P2|qf3bQe z$GI3wBvk=#0dfww4TRp8ud51V+^xrB`aZA#`D(9&;EtH>^v(NYDZpKiKMIW$CyHu6 zv$3m&GPJs`$g{uSzGSWKmky+dtmYwO;y_JVDw37GzwTSx>yn9SjunlS;6bID3YXun z+1NeP@JVGw)zXI<1zCyW_Vjs@^VYiB;T3+FL~FiF%aRIemJDw~xwo-Npd72g=~!P2W%NSz#MsN z2VEL1K&Tn~DL5RZ`qL|m{8KRBdqON3^nJ$X$=)glp$uHDFO`?7t}=$-{^4(u6`Ki5 ztoC+w2%?vQ*~$48*TBIrZefzxk`*EmVdoAGMRbc!_AX+^)cOBYFT}E>En3)Cm`B)Y z9tD$(jL>^{EMt=0$oxd*3&6QR&XM>Ck=z`HS1_PkvK;Tk2tGxIJH883kHS1-lHXWj zn7q>}wTVWD@5g33Ds)L!QTX6mtKp6BqxZ;Fh{5kFiaO*Pkjn~wJH)keJxj{?U_{8} zyoI31IeX#D+V^VZhPB@%QSd3gTGNJx2s3EpJ2#|ymMTGgaHI6jw>3$>7o{((c8$(i z9?u2bGf&=S*G{8Gw>US55*8=xw%i`_mr2%Cn8fV%L4<)Ft5qA z0?(Yi{vE$MvD4TSzu&r*5xOaao*QUQnv=}4<NY;%Z@Gq!~J)8Y;S?X-R4ucvwSW z8_!>V0}mkkPtGH&kD-6FeO=GVzd*LNYoC_U-1Sup+V8ZZQ?njqH`Y6HodhP1va$;Xo^m!#+K;`_66!)3XU) z&^}03bVbCnKwj2n-c`ygt!#O^LmFY>;zk9o<$R>kG;M+`hI^U>8dJC7SK;7*kb7>L zIM@R-p8j6`N$b!q-alIDm&cS;jyn0{Dz?0fF&XE^815L&v%MR-c1HN2J->x9HF+Z; zm|=3ZyDhpH6>Y^NT`c2Pj+3lXelVPlWS1b+2tZyw{q_)fi)>kJG$XMHbig zhSeZ|R&>?WJ#E91MD_j?`D6x!-D;ln$!#u7Ga1;0@l`Ol`{38Ccl!ldMoh-1>R*NJ zF%eN@3dgcK`)5f6#xEpEdt>vf*GHZg!l(GXdmT^O?vD!(q-unf2vv72tL-9f>p$d2 zd0*I+S1l+FRPub$i1S40rgBC$Om{rDI(%aDBKoW?wV=+oI0D`?yX12;ypao&b4B&j zmBx{XqhyB&xH9skOBO28x%iZ{Py2}ztS6y&bS*M(yA3Eabjd1+ek3;7V3`Yjxa!^h zBoiFKtr;KAS#K{od=F62WCm)weD@c)?pJdbb-NF9cy(c14UObU^Su!872tCb-YiG} zcYJr%y2Wl8IWGzf zbTY|G*s^>+F!GMM-}!~QB`s$rp3jpVp*?^->aMCu*IrC{ecqJ5UIRVgvQ49n-*~F8 zVcFJuEaJJRu;4BJ#~txk9S97n{@TY)wWn=E#QzQ)e%T7+7rza2re71WonWzA4u#U& z=@cXY?da0=*5Ew_i!rsWiu@=A=q)WtjJsRjerMI5trFW4a+(#AAGN5HyabJ0vfh~qh5Y!WA?XEd{Q%Tl8NC2T8DmLdFk>fS`eQl8uI z6(vb0YTF!IQ-TCaHO@PwQr;*rTA*o__aPpxlCzR;(i-hfg?2256Fx4!4L+cH<++L((V~{;Eg%WOwlO2&LITqrj-`anqM2j;QfHU#_Msnz}3< z-=^6(>uf3H!#?Pa`3n_n)I3773U1W#*XfmBc6^2bR#owx+I)2J0R_?BUJxkI~AJO);cB6xUz8`T zERN6;ecP|MfQb(sM=%0sVDN$Dy!S2L1y*2H4)B&=s)`@X{!623WAk$9$znTwqVS{lSDsz%xaL#gRfQJ?36eJPH7Xd7z`gQ!>#j` z_tK2kUP=iP0UrJ>Zp$-(#xMbZWq*T!UXiCyacIazUaZ$pm77?2{HLgX4yVW1(8cta z_QX?cvoji`>r?!X3CAYO)*s2;$yNsR!nj3aZehcSy2I5^8z}{7+9S&^`%|a`Me1C9 z=#wmtSJ9bUb=BQfPeV$2LYLy(q6K(_|F%Ad*Ij-X!W90G6_-2#%)$D+VQ%nQ0>kSb zfldG)s5zLST@OAP3KQ9d=^KS>3j`)<+n$K(3@QcdFJl{5OXc{2&TI$N#C#g#yw?GN z)ONfs8{ZX!VW#7<`!~LoY1L@yx#pR)#d4rJI6WA#;h#WI*LX^m7u;4L{Je`xsj=C& zB^3xSN~X=rSEwDqqiwH2r?MU_Zq%XnCDwL>f6Zw5eKDK@{%%`JXf3A*DD2rv4P~;- zKqVl(t^A5TGh22>N$mB9ap9|rk5^UvES>#k3EVmVJq=|KnZYx>N2TDsGUQzB+;KD% z1!*PE@kdjxM&K*@u|U{}Vnj3*xs0ut+6!FvLyg9I@BNDZAX-V|$N3MtoxLO>fBL>+ zA+UVosz}Mer=qb;Q}}SfQl{e)x|vh=e6tbX=9X~6hL1` zW1gO*Jluh)(KF7dbq6X)Z6sYAr%8#wIe%Hv_ey!zM*O^WS0%g~+E!ccQbPBOa*L&u~W;$a`pootNMtPi9`RI%AzdC zt1`#>sWteCb|p5r8v9PH3+wD=+HsR-w1IL>#mpVbU zctQq`AB{)6qZW=)5OjPB9;hc>n(fjhlOepUy1^U!AC^$;+cseY`lV`T^cB)$$x^3@ zfVjjR60b;9Q0$+=bwWfY#aNq&>zc1)N4baPQqJB==X@_fvilI>R5{+zc+eK_#GvRX zEUsLE5S*gvSlD9o`#19({$p niI#QLMsHq^k~W!6nfb#SXDr7J_c5qC0eql$jqa4*c6jxF|9x+* literal 0 HcmV?d00001 From 906bf08290212ce06edc54e6fdb65f30665c1311 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 24 Apr 2020 16:09:10 +0200 Subject: [PATCH 186/316] Add allocate, dim0, dim1, dim2 to Representation --- .../Array/Accelerate/Array/Representation.hs | 26 ++++++++++++++++--- src/Data/Array/Accelerate/Array/Sugar.hs | 6 ++--- 2 files changed, 25 insertions(+), 7 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index 191c275c2..5bf39d8b2 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -27,11 +27,11 @@ module Data.Array.Accelerate.Array.Representation ( -- * Array data type in terms of representation types Array(..), ArrayR(..), arraysRarray, arraysRtuple2, arrayRshape, arrayRtype, rnfArray, rnfShape, ArraysR, TupleType, Scalar, Vector, Matrix, fromList, toList, Segments, shape, reshape, concatVectors, - showArrayR, showArraysR, fromFunction, fromFunctionM, + showArrayR, showArraysR, fromFunction, fromFunctionM, reduceRank, allocateArray, -- * Array shapes, indices, and slices ShapeR(..), Slice(..), SliceIndex(..), - DIM0, DIM1, DIM2, (!), (!!), + DIM0, DIM1, DIM2, dim0, dim1, dim2, (!), (!!), -- * Shape functions rank, size, empty, ignore, intersect, union, toIndex, fromIndex, iter, iter1, @@ -123,7 +123,6 @@ fromFunctionM (ArrayR shr tp) sh f = do concatVectors :: forall e. TupleType e -> [Vector e] -> Vector e concatVectors tp vs = adata `seq` Array ((), len) adata where - dim1 = ShapeRsnoc ShapeRz offsets = scanl (+) 0 (map (size dim1 . shape) vs) len = last offsets (adata, _) = runArrayData @e $ do @@ -133,6 +132,14 @@ concatVectors tp vs = adata `seq` Array ((), len) adata , i <- [0 .. n - 1] ] return (arr, undefined) +-- | Creates a new, uninitialized Accelerate array. +-- +{-# INLINEABLE allocateArray #-} +allocateArray :: ArrayR (Array sh e) -> sh -> IO (Array sh e) +allocateArray (ArrayR shr tp) sh = do + adata <- newArrayData tp (size shr sh) + return $! Array sh adata + {-# INLINEABLE fromList #-} fromList :: forall sh e. ArrayR (Array sh e) -> sh -> [e] -> Array sh e fromList (ArrayR shr tp) sh xs = adata `seq` Array sh adata @@ -206,6 +213,15 @@ type DIM0 = () type DIM1 = ((), Int) type DIM2 = (((), Int), Int) +dim0 :: ShapeR DIM0 +dim0 = ShapeRz + +dim1 :: ShapeR DIM1 +dim1 = ShapeRsnoc dim0 + +dim2 :: ShapeR DIM2 +dim2 = ShapeRsnoc dim1 + -- |Index representations (which are nested pairs) -- @@ -635,3 +651,7 @@ showMatrix f tp arr@(Array sh _) | otherwise = ',' : ppMat r (c+1) in before ++ cell ++ after + + +reduceRank :: ArrayR (Array (sh, Int) e) -> ArrayR (Array sh e) +reduceRank (ArrayR (ShapeRsnoc shr) tp) = ArrayR shr tp diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/src/Data/Array/Accelerate/Array/Sugar.hs index 754e619e3..94c4c6397 100644 --- a/src/Data/Array/Accelerate/Array/Sugar.hs +++ b/src/Data/Array/Accelerate/Array/Sugar.hs @@ -74,7 +74,6 @@ import GHC.TypeLits import qualified GHC.Exts as GHC -- friends -import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Error import Data.Array.Accelerate.Orphans () import Data.Array.Accelerate.Type @@ -887,13 +886,12 @@ fromFunctionM sh f = Array <$> Repr.fromFunctionM (arrayR @sh @e) (fromElt sh) f concatVectors :: forall e. Elt e => [Vector e] -> Vector e concatVectors = toArr . Repr.concatVectors (eltType @e) . map fromArr + -- | Creates a new, uninitialized Accelerate array. -- {-# INLINEABLE allocateArray #-} allocateArray :: forall sh e. (Shape sh, Elt e) => sh -> IO (Array sh e) -allocateArray sh = do - adata <- newArrayData (eltType @e) (size sh) - return $! Array $ Repr.Array (fromElt sh) adata +allocateArray sh = Array <$> Repr.allocateArray (arrayR @sh @e) (fromElt sh) -- | Convert elements of a list into an Accelerate 'Array'. From bff50f34688c6a0ef0bf63b01a9a4fe0890bbd9a Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 25 Apr 2020 18:26:05 +0200 Subject: [PATCH 187/316] fix pattern synonyms for arrays --- src/Data/Array/Accelerate/Pattern.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 382999ae1..17ccc6621 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -111,21 +111,23 @@ $(runQ $ do destruct _x = $(tupE (map (get [|_x|]) [(n-1), (n-2) .. 0])) |] - mkIsPattern :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] - mkIsPattern _ _ _ _ _ _ 1 = return [] - mkIsPattern con cst smart prj nil pair n = do + mkIsPattern :: Name -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] + mkIsPattern con cst repr smart prj nil pair n = do let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] ts = map varT xs a = tupT ts b = tupT (map (conT con `appT`) ts) context = tupT (map (cst `appT`) ts) + equiv = case n of + 1 -> [t| ((), $repr $a) |] + _ -> [t| $repr $a |] -- get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) -- _x <- newName "_x" - [d| instance $context => IsPattern $(conT con) $a $b where + [d| instance ($repr a ~ $equiv, $context) => IsPattern $(conT con) a $b where construct $(tupP (map (conP con . return . varP) xs)) = $(conE con) $(foldl (\vs v -> appE smart (appE (appE pair vs) (varE v))) (appE smart nil) xs) destruct $(conP con [varP _x]) = @@ -133,7 +135,7 @@ $(runQ $ do |] mkExpPattern = mkIsPattern' (mkName "Exp") [t| Elt |] [| Tuple |] [| Prj |] [| NilTup |] [| SnocTup |] - mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] + mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [t| ArrRepr |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] -- es <- mapM mkExpPattern [0..16] as <- mapM mkAccPattern [0..16] From ce8481755d8cd3922bd799504a502e7c901de759 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 29 Apr 2020 13:08:36 +0200 Subject: [PATCH 188/316] Also use representation types for (A)foreign --- src/Data/Array/Accelerate/AST.hs | 37 +++++++++---------- src/Data/Array/Accelerate/Analysis/Hash.hs | 4 +- src/Data/Array/Accelerate/Analysis/Match.hs | 4 +- src/Data/Array/Accelerate/Interpreter.hs | 5 +-- src/Data/Array/Accelerate/Language.hs | 10 ++--- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 4 +- src/Data/Array/Accelerate/Pretty/Print.hs | 4 +- src/Data/Array/Accelerate/Smart.hs | 29 ++++++++------- src/Data/Array/Accelerate/Trafo/Fusion.hs | 10 ++--- src/Data/Array/Accelerate/Trafo/Sharing.hs | 35 +++++++++++++----- src/Data/Array/Accelerate/Trafo/Shrink.hs | 8 ++-- src/Data/Array/Accelerate/Trafo/Simplify.hs | 4 +- .../Array/Accelerate/Trafo/Substitution.hs | 6 +-- 13 files changed, 88 insertions(+), 72 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 8c0c50a97..6e63336dd 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -383,11 +383,12 @@ data PreOpenAcc acc aenv a where -- Accelerate version for use with other backends. The functions must be -- closed. -- - Aforeign :: (Sugar.Arrays as, Sugar.Arrays bs, Sugar.Foreign asm) - => asm (as -> bs) -- The foreign function for a given backend - -> PreAfun acc (Sugar.ArrRepr as -> Sugar.ArrRepr bs) -- Fallback implementation(s) - -> acc aenv (Sugar.ArrRepr as) -- Arguments to the function - -> PreOpenAcc acc aenv (Sugar.ArrRepr bs) + Aforeign :: Sugar.Foreign asm + => ArraysR bs + -> 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 -- @@ -780,9 +781,7 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where arraysRepr (Apair as bs) = TupRpair (arraysRepr as) (arraysRepr bs) arraysRepr Anil = TupRunit arraysRepr (Apply repr _ _) = repr - arraysRepr (Aforeign _ (Alam _ (Abody a)) _) = arraysRepr a - arraysRepr (Aforeign _ (Abody _) _) = error "And what have you got, at the end of the day?" - arraysRepr (Aforeign _ (Alam _ (Alam _ _)) _) = error "A bottle of whisky. And a new set of lies." + arraysRepr (Aforeign r _ _ _) = r arraysRepr (Acond _ whenTrue _) = arraysRepr whenTrue arraysRepr (Awhile _ (Alam lhs _) _) = lhsToTupR lhs arraysRepr (Awhile _ _ _) = error "I want my, I want my MTV!" @@ -876,11 +875,12 @@ data PreOpenExp acc env aenv t where -> PreOpenExp acc env aenv t -- Apply a backend-specific foreign function - Foreign :: (Sugar.Foreign asm, Sugar.Elt x, Sugar.Elt y) - => asm (x -> y) -- foreign function - -> PreFun acc () (Sugar.EltRepr x -> Sugar.EltRepr y) -- alternate implementation (for other backends) - -> PreOpenExp acc env aenv (Sugar.EltRepr x) - -> PreOpenExp acc env aenv (Sugar.EltRepr y) + Foreign :: Sugar.Foreign asm + => TupleType 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 Pair :: PreOpenExp acc env aenv t1 @@ -984,8 +984,7 @@ expType :: HasArraysRepr acc => PreOpenExp acc aenv env t -> TupleType t expType expr = case expr of Let _ _ body -> expType body Evar (Var tp _) -> TupRsingle tp - Foreign _ (Lam _ (Body e)) _ -> expType e - Foreign _ _ _ -> error "Though you ride on the wheels of tomorrow, you still wander the fields of your sorrow." + Foreign tp _ _ _ -> tp Pair e1 e2 -> TupRpair (expType e1) (expType e2) Nil -> TupRunit VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR @@ -1322,7 +1321,7 @@ rnfPreOpenAcc rnfA pacc = Apair as bs -> rnfA as `seq` rnfA bs Anil -> () Apply repr afun acc -> rnfTupR rnfArrayR repr `seq` rnfAF afun `seq` rnfA acc - Aforeign asm afun a -> rnf (Sugar.strForeign asm) `seq` rnfAF afun `seq` rnfA a + Aforeign repr asm afun a -> rnfTupR rnfArrayR repr `seq` rnf (Sugar.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 repr arr -> rnfArray repr arr @@ -1498,7 +1497,7 @@ rnfPreOpenExp rnfA topExp = case topExp of Let lhs bnd body -> rnfELhs lhs `seq` rnfE bnd `seq` rnfE body Evar (Var tp ix) -> rnfScalarType tp `seq` rnfIdx ix - Foreign asm f x -> rnf (Sugar.strForeign asm) `seq` rnfF f `seq` rnfE x + Foreign tp asm f x -> rnfTupleType tp `seq` rnf (Sugar.strForeign asm) `seq` rnfF f `seq` rnfE x Const tp c -> c `seq` rnfScalarType tp -- scalars should have (nf == whnf) Undef tp -> rnfScalarType tp Pair a b -> rnfE a `seq` rnfE b @@ -1689,7 +1688,7 @@ liftPreOpenAcc liftA pacc = Apair as bs -> [|| Apair $$(liftA as) $$(liftA bs) ||] Anil -> [|| Anil ||] Apply repr f a -> [|| Apply $$(liftArraysR repr) $$(liftAF f) $$(liftA a) ||] - Aforeign asm f a -> [|| Aforeign $$(Sugar.liftForeign asm) $$(liftPreOpenAfun liftA f) $$(liftA a) ||] + Aforeign repr asm f a -> [|| Aforeign $$(liftArraysR repr) $$(Sugar.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 repr a -> [|| Use $$(liftArrayR repr) $$(liftArray repr a) ||] @@ -1786,7 +1785,7 @@ liftPreOpenExp liftA pexp = case pexp of Let lhs bnd body -> [|| Let $$(liftELhs lhs) $$(liftPreOpenExp liftA bnd) $$(liftPreOpenExp liftA body) ||] Evar var -> [|| Evar $$(liftExpVar var) ||] - Foreign asm f x -> [|| Foreign $$(Sugar.liftForeign asm) $$(liftPreOpenFun liftA f) $$(liftE x) ||] + Foreign repr asm f x -> [|| Foreign $$(liftTupleType repr) $$(Sugar.liftForeign asm) $$(liftPreOpenFun liftA f) $$(liftE x) ||] Const tp c -> [|| Const $$(liftScalarType tp) $$(liftConst (TupRsingle tp) c) ||] Undef tp -> [|| Undef $$(liftScalarType tp) ||] Pair a b -> [|| Pair $$(liftE a) $$(liftE b) ||] diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 3a69de716..862cbee09 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -169,7 +169,7 @@ encodePreOpenAcc options encodeAcc pacc = Apair a1 a2 -> intHost $(hashQ "Apair") <> travA a1 <> travA a2 Anil -> intHost $(hashQ "Anil") Apply _ f a -> intHost $(hashQ "Apply") <> travAF f <> travA a - Aforeign _ f a -> intHost $(hashQ "Aforeign") <> travAF f <> travA a + Aforeign _ _ f a -> intHost $(hashQ "Aforeign") <> travAF f <> travA a Use repr a -> intHost $(hashQ "Use") <> encodeArrayType repr <> deep (encodeArray a) Awhile p f a -> intHost $(hashQ "Awhile") <> travAF f <> travAF p <> travA a Unit _ e -> intHost $(hashQ "Unit") <> travE e @@ -354,7 +354,7 @@ encodePreOpenExp options encodeAcc exp = LinearIndex a ix -> intHost $(hashQ "LinearIndex") <> travA a <> travE ix Shape a -> intHost $(hashQ "Shape") <> travA a ShapeSize _ sh -> intHost $(hashQ "ShapeSize") <> travE sh - Foreign _ f e -> intHost $(hashQ "Foreign") <> travF f <> travE e + Foreign _ _ f e -> intHost $(hashQ "Foreign") <> travF f <> travE e Coerce _ tp e -> intHost $(hashQ "Coerce") <> encodeScalarType tp <> travE e diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index 1f4e525e0..4e280bc57 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -98,7 +98,7 @@ matchPreOpenAcc matchAcc encodeAcc = match , Just Refl <- matchAcc a1 a2 = Just Refl - match (Aforeign ff1 f1 a1) (Aforeign ff2 f2 a2) + match (Aforeign _ ff1 f1 a1) (Aforeign _ ff2 f2 a2) | Just Refl <- matchAcc a1 a2 , unsafePerformIO $ do sn1 <- makeStableName ff1 @@ -465,7 +465,7 @@ matchPreOpenExp matchAcc encodeAcc = match match (Evar v1) (Evar v2) = matchVar v1 v2 - match (Foreign ff1 f1 e1) (Foreign ff2 f2 e2) + match (Foreign _ ff1 f1 e1) (Foreign _ ff2 f2 e2) | Just Refl <- match e1 e2 , unsafePerformIO $ do sn1 <- makeStableName ff1 diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 30135452a..a5bb15e18 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -207,8 +207,7 @@ evalOpenAcc (AST.Manifest pacc) aenv = (TupRpair r1 r2, (a1, a2)) Anil -> (TupRunit, ()) Apply repr afun acc -> (repr, evalOpenAfun afun aenv $ snd $ manifest acc) - Aforeign (_ :: asm (a1 -> a2)) afun acc - -> (Sugar.arrays @a2, evalOpenAfun afun Empty $ snd $ manifest acc) + Aforeign repr _ afun acc -> (repr, evalOpenAfun afun Empty $ snd $ manifest acc) Acond p acc1 acc2 | evalE p -> manifest acc1 | otherwise -> manifest acc2 @@ -986,7 +985,7 @@ evalPreOpenExp evalAcc pexp env aenv = in (repr, a) ! ix Shape acc -> shape $ snd $ evalA acc ShapeSize shr sh -> size shr (evalE sh) - Foreign _ f e -> evalPreOpenFun evalAcc f Empty Empty $ evalE e + Foreign _ _ f e -> evalPreOpenFun evalAcc f Empty Empty $ evalE e Coerce t1 t2 e -> evalCoerceScalar t1 t2 (evalE e) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 0de3f6355..c6bef7c64 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1198,11 +1198,11 @@ collect = Acc . Collect -- foreignAcc :: forall as bs asm. (Arrays as, Arrays bs, Foreign asm) - => asm (as -> bs) + => asm (ArrRepr as -> ArrRepr bs) -> (Acc as -> Acc bs) -> Acc as -> Acc bs -foreignAcc asm f (Acc as) = Acc $ SmartAcc $ Aforeign asm f as +foreignAcc asm f (Acc as) = Acc $ SmartAcc $ Aforeign (arrays @bs) asm (unAccFunction f) as -- | Call a foreign scalar expression. -- @@ -1215,12 +1215,12 @@ foreignAcc asm f (Acc as) = Acc $ SmartAcc $ Aforeign asm f as -- purely in Accelerate. -- foreignExp - :: (Elt x, Elt y, Foreign asm) - => asm (x -> y) + :: forall x y asm. (Elt x, Elt y, Foreign asm) + => asm (EltRepr x -> EltRepr y) -> (Exp x -> Exp y) -> Exp x -> Exp y -foreignExp a f (Exp x) = exp $ Foreign a f x +foreignExp a f (Exp x) = exp $ Foreign (eltType @y) a (unExpFunction f) x -- Composition of array computations diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 3b78e8bfb..b99e8a369 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -46,7 +46,7 @@ import qualified Data.Sequence as Seq -- friends import Data.Array.Accelerate.AST hiding ( Val(..), prj ) import Data.Array.Accelerate.Array.Representation -import Data.Array.Accelerate.Array.Sugar ( strForeign, TupR(..) ) +import Data.Array.Accelerate.Array.Sugar ( strForeign ) import Data.Array.Accelerate.Error import Data.Array.Accelerate.Pretty.Graphviz.Monad import Data.Array.Accelerate.Pretty.Graphviz.Type @@ -253,7 +253,7 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = -> "stencil" .$ [ ppF sten, ppB (stencilElt s) bndy, ppA xs ] Stencil2 s1 s2 _ sten bndy1 acc1 bndy2 acc2 -> "stencil2" .$ [ ppF sten, ppB (stencilElt s1) bndy1, ppA acc1, ppB (stencilElt s2) bndy2, ppA acc2 ] - Aforeign ff _afun xs -> "aforeign" .$ [ return (PDoc (pretty (strForeign ff)) []), {- ppAf afun, -} ppA xs ] + Aforeign _ ff _afun xs -> "aforeign" .$ [ return (PDoc (pretty (strForeign ff)) []), {- ppAf afun, -} ppA xs ] -- Collect{} -> error "Collect" where diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 35634e67a..df51931e0 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -149,7 +149,7 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = , hang shiftwidth (sep [ then_, t' ]) , hang shiftwidth (sep [ else_, e' ]) ] - Aforeign ff _f a -> "aforeign" .$ [ pretty (strForeign ff), ppA a ] + Aforeign _ ff _ a -> "aforeign" .$ [ pretty (strForeign ff), ppA a ] Awhile p f a -> "awhile" .$ [ ppAF p, ppAF f, ppA a ] Use repr arr -> "use" .$ [ prettyArray repr arr ] Unit _ e -> "unit" .$ [ ppE e ] @@ -376,7 +376,7 @@ prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = ToIndex _ sh ix -> ppF2 "toIndex" (ppE sh) (ppE ix) FromIndex _ sh ix -> ppF2 "fromIndex" (ppE sh) (ppE ix) While p f x -> ppF3 "while" (ppF p) (ppF f) (ppE x) - Foreign ff _f e -> ppF2 "foreign" (\_ -> pretty (strForeign ff)) (ppE e) + Foreign _ ff _ e -> ppF2 "foreign" (\_ -> pretty (strForeign ff)) (ppE e) Shape arr -> ppF1 "shape" (ppA arr) ShapeSize _ sh -> ppF1 "shapeSize" (ppE sh) Index arr ix -> ppF2 (Operator (pretty '!') Infix L 9) (ppA arr) (ppE ix) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 8b3120e59..efbf704ee 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -63,7 +63,7 @@ module Data.Array.Accelerate.Smart ( -- * Auxiliary functions ($$), ($$$), ($$$$), ($$$$$), unAcc, unAccFunction, ApplyAcc(..), exp, unPair, mkPairToTuple, HasExpType(..), HasArraysRepr(..), - vecR2, vecR3, vecR4, vecR5, vecR6, vecR7, vecR8, vecR9, vecR16, + vecR2, vecR3, vecR4, vecR5, vecR6, vecR7, vecR8, vecR9, vecR16, unExpFunction, -- Debugging showPreAccOp, showPreExpOp, @@ -297,11 +297,12 @@ data PreSmartAcc acc exp as where -> acc as -> PreSmartAcc acc exp cs - Aforeign :: (Arrays as, Arrays bs, Foreign asm) - => asm (as -> bs) - -> (Acc as -> Acc bs) - -> acc (ArrRepr as) - -> PreSmartAcc acc exp (ArrRepr bs) + Aforeign :: Foreign asm + => ArraysR bs + -> asm (as -> bs) + -> (SmartAcc as -> SmartAcc bs) + -> acc as + -> PreSmartAcc acc exp bs Acond :: exp Bool -> acc as @@ -471,8 +472,7 @@ instance HasArraysRepr acc => HasArraysRepr (PreSmartAcc acc exp) where arraysRepr acc = case acc of Atag repr _ -> repr Pipe _ _ repr _ _ _ -> repr - Aforeign (_ :: asm (as -> bs)) _ _ - -> Sugar.arrays @bs + Aforeign repr _ _ _ -> repr Acond _ a _ -> arraysRepr a Awhile _ _ _ a -> arraysRepr a Anil -> TupRunit @@ -730,11 +730,12 @@ data PreSmartExp acc exp t where -> exp sh -> PreSmartExp acc exp Int - 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 (EltRepr x) - -> PreSmartExp acc exp (EltRepr y) + Foreign :: Foreign asm + => TupleType y + -> asm (x -> y) + -> (SmartExp x -> SmartExp y) -- RCE: Using SmartExp instead of exp to aid in sharing recovery. + -> exp x + -> PreSmartExp acc exp y Undef :: ScalarType t -> PreSmartExp acc exp t @@ -771,7 +772,7 @@ instance HasExpType exp => HasExpType (PreSmartExp acc exp) where LinearIndex tp _ _ -> tp Shape shr _ -> shapeType shr ShapeSize _ _ -> TupRsingle $ scalarTypeInt - Foreign (_ :: asm (x -> y)) _ _ -> eltType @y + Foreign tp _ _ _ -> tp Undef tp -> TupRsingle tp Coerce _ tp _ -> TupRsingle tp diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 4f3549147..9ab7b76a8 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -168,7 +168,7 @@ manifest config (OpenAcc pacc) = Apair a1 a2 -> Apair (manifest config a1) (manifest config a2) Anil -> Anil Apply repr f a -> apply repr (cvtAF f) (manifest config a) - Aforeign ff f a -> Aforeign ff (cvtAF f) (manifest config a) + Aforeign repr ff f a -> Aforeign repr ff (cvtAF f) (manifest config a) -- Producers -- --------- @@ -295,7 +295,7 @@ convertOpenExp config exp = LinearIndex a i -> LinearIndex (manifest config a) (cvtE i) Shape a -> Shape (manifest config a) ShapeSize shr sh -> ShapeSize shr (cvtE sh) - Foreign ff f e -> Foreign ff (cvtF f) (cvtE e) + Foreign tp ff f e -> Foreign tp ff (cvtF f) (cvtE e) Coerce t1 t2 e -> Coerce t1 t2 (cvtE e) where -- Conversions for closed scalar functions and expressions @@ -408,7 +408,7 @@ embedPreAcc config embedAcc elimAcc pacc Apply repr f a -> done $ Apply repr (cvtAF f) (cvtA a) Awhile p f a -> done $ Awhile (cvtAF p) (cvtAF f) (cvtA a) Apair a1 a2 -> done $ Apair (cvtA a1) (cvtA a2) - Aforeign ff f a -> done $ Aforeign ff (cvtAF f) (cvtA a) + Aforeign repr ff f a -> done $ Aforeign repr ff (cvtAF f) (cvtA a) -- Collect s -> collectD s -- Array injection @@ -1415,7 +1415,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en Let lhs x y -> let k = weakenWithLHS lhs in Let lhs (cvtE x) (replaceE (weakenE k sh') (weakenE k f') avar y) Evar var -> Evar var - Foreign ff f e -> Foreign ff f (cvtE e) + Foreign tp ff f e -> Foreign tp ff f (cvtE e) Const tp c -> Const tp c Undef tp -> Undef tp Nil -> Nil @@ -1491,7 +1491,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en Apair a1 a2 -> Apair (cvtA a1) (cvtA a2) Awhile p f a -> Awhile (cvtAF p) (cvtAF f) (cvtA a) Apply repr f a -> Apply repr (cvtAF f) (cvtA a) - Aforeign ff f a -> Aforeign ff f (cvtA a) -- no sharing between f and a + Aforeign repr ff f a -> Aforeign repr ff f (cvtA a) -- no sharing between f and a Generate repr sh f -> Generate repr (cvtE sh) (cvtF f) Map tp f a -> Map tp (cvtF f) (cvtA a) ZipWith tp f a b -> ZipWith tp (cvtF f) (cvtA a) (cvtA b) diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 6ffbccc24..c8fd98b68 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -201,6 +201,14 @@ instance Arrays b => Afunction (Acc b) where afunctionRepr = AfunctionReprBody convertOpenAfun config alyt (Acc body) = Abody $ convertOpenAcc config alyt body +convertSmartAfun1 :: Config -> ArraysR a -> (SmartAcc a -> SmartAcc b) -> AST.Afun (a -> b) +convertSmartAfun1 config repr f + | DeclareVars lhs _ value <- declareVars repr = + let + a = SmartAcc $ Atag repr 0 + alyt' = PushLayout EmptyLayout lhs (value weakenId) + in + Alam lhs $ Abody $ convertOpenAcc config alyt' $ f a -- | Convert an open array expression to de Bruijn form while also incorporating sharing -- information. @@ -305,8 +313,8 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) (avarsIn $ value weakenId) in AST.Alet lhs (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) - Aforeign ff afun acc - -> AST.Aforeign ff (convertAfunWith config afun) (cvtA acc) + Aforeign repr ff afun acc + -> AST.Aforeign repr ff (convertSmartAfun1 config (arraysRepr acc) afun) (cvtA acc) Acond b acc1 acc2 -> AST.Acond (cvtE b) (cvtA acc1) (cvtA acc2) Awhile reprA pred iter init -> AST.Awhile (cvtAfun1 reprA pred) (cvtAfun1 reprA iter) (cvtA init) @@ -607,6 +615,15 @@ instance Elt b => Function (Exp b) where functionRepr = FunctionReprBody convertOpenFun config lyt (Exp body) = Body $ convertOpenExp config lyt body +convertSmartFun :: Config -> TupleType a -> (SmartExp a -> SmartExp b) -> AST.Fun () (a -> b) +convertSmartFun config tp f + | DeclareVars lhs _ value <- declareVars tp = + let + e = SmartExp $ Tag tp 0 + lyt' = PushLayout EmptyLayout lhs (value weakenId) + in + Lam lhs $ Body $ convertOpenExp config lyt' $ f e + -- Scalar expressions -- ------------------ @@ -730,7 +747,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp LinearIndex _ a i -> AST.LinearIndex (cvtA a) (cvt i) Shape _ a -> AST.Shape (cvtA a) ShapeSize shr e -> AST.ShapeSize shr (cvt e) - Foreign ff f e -> AST.Foreign ff (convertFunWith config f) (cvt e) + Foreign repr ff f e -> AST.Foreign repr ff (convertSmartFun config (expType e) f) (cvt e) Coerce t1 t2 e -> AST.Coerce t1 t2 (cvt e) cvtPrj :: forall a b c env1 aenv1. PairIdx (a, b) c -> AST.OpenExp env1 aenv1 (a, b) -> AST.OpenExp env1 aenv1 c @@ -1324,7 +1341,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc (acc', h3) <- traverseAcc lvl acc return (Pipe repr1 repr2 repr3 afun1' afun2' acc' , h1 `max` h2 `max` h3 + 1) - Aforeign ff afun acc -> travA (Aforeign ff afun) acc + Aforeign repr ff afun acc -> travA (Aforeign repr ff afun) acc Acond e acc1 acc2 -> do (e' , h1) <- traverseExp lvl e (acc1', h2) <- traverseAcc lvl acc1 @@ -1657,9 +1674,9 @@ makeOccMapSharingExp config accOccMap expOccMap = travE LinearIndex tp a i -> travAE (LinearIndex tp) a i Shape shr a -> travA (Shape shr) a ShapeSize shr e -> travE1 (ShapeSize shr) e - Foreign ff f e -> do + Foreign tp ff f e -> do (e', h) <- travE lvl e - return (Foreign ff f e', h+1) + return (Foreign tp ff f e', h+1) Coerce t1 t2 e -> travE1 (Coerce t1 t2) e where @@ -2124,10 +2141,10 @@ determineScopesSharingAcc config accOccMap = scopesAcc reconstruct (Pipe repr1 repr2 repr3 afun1' afun2' acc') (accCount1 +++ accCount2 +++ accCount3) - Aforeign ff afun acc -> let + Aforeign r ff afun acc -> let (acc', accCount) = scopesAcc acc in - reconstruct (Aforeign ff afun acc') accCount + reconstruct (Aforeign r ff afun acc') accCount Acond e acc1 acc2 -> let (e' , accCount1) = scopesExp e (acc1', accCount2) = scopesAcc acc1 @@ -2502,7 +2519,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp LinearIndex tp a e -> travAE (LinearIndex tp) a e Shape shr a -> travA (Shape shr) a ShapeSize shr e -> travE1 (ShapeSize shr) e - Foreign ff f e -> travE1 (Foreign ff f) e + Foreign tp ff f e -> travE1 (Foreign tp ff f) e Coerce t1 t2 e -> travE1 (Coerce t1 t2) e where travE1 :: (ScopedExp a -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedExp a diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index a7dabed83..755f3c66b 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -265,7 +265,7 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE LinearIndex a i -> LinearIndex a <$> shrinkE i Shape a -> pure (Shape a) ShapeSize shr sh -> ShapeSize shr <$> shrinkE sh - Foreign ff f e -> Foreign ff <$> shrinkF f <*> shrinkE e + Foreign repr ff f e -> Foreign repr ff <$> shrinkF f <*> shrinkE e Coerce t1 t2 e -> Coerce t1 t2 <$> shrinkE e shrinkF :: Kit acc => PreOpenFun acc env aenv t -> (Any, PreOpenFun acc env aenv t) @@ -453,7 +453,7 @@ usesOfExp range = countE LinearIndex _ i -> countE i Shape _ -> Finite 0 ShapeSize _ sh -> countE sh - Foreign _ _ e -> countE e + Foreign _ _ _ e -> countE e Coerce _ _ e -> countE e usesOfFun :: VarsRange -> PreOpenFun acc env aenv f -> Count @@ -488,7 +488,7 @@ usesOfPreAcc withShape countAcc idx = count Apair a1 a2 -> countA a1 + countA a2 Anil -> 0 Apply _ _ a -> countA a --- XXX: It is suspicious that we don't descend into the function here. Same for awhile. - Aforeign _ _ a -> countA a + Aforeign _ _ _ a -> countA a Acond p t e -> countE p + countA t + countA e Awhile _ _ a -> countA a Use _ _ -> 0 @@ -540,7 +540,7 @@ usesOfPreAcc withShape countAcc idx = count Shape a | withShape -> countA a | otherwise -> 0 - Foreign _ _ e -> countE e + Foreign _ _ _ e -> countE e Coerce _ _ e -> countE e countA :: acc aenv a -> Int diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index f43aeb437..e255a819a 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -246,7 +246,7 @@ simplifyOpenExp env = first getAny . cvtE LinearIndex a i -> LinearIndex a <$> cvtE i Shape a -> shape a ShapeSize shr sh -> shapeSize shr (cvtE sh) - Foreign ff f e -> Foreign ff <$> first Any (simplifyOpenFun EmptyExp f) <*> cvtE e + Foreign tp ff f e -> Foreign tp ff <$> first Any (simplifyOpenFun EmptyExp f) <*> cvtE e While p f x -> While <$> cvtF env p <*> cvtF env f <*> cvtE x Coerce t1 t2 e -> Coerce t1 t2 <$> cvtE e @@ -490,7 +490,7 @@ summariseOpenExp = (terms +~ 1) . goE case exp of Let _ bnd body -> travE bnd +++ travE body & binders +~ 1 Evar{} -> zero & vars +~ 1 - Foreign _ _ x -> travE x & terms +~ 1 -- +1 for asm, ignore fallback impls. + Foreign _ _ _ x -> travE x & terms +~ 1 -- +1 for asm, ignore fallback impls. Const{} -> zero Undef _ -> zero Nil -> zero & terms +~ 1 diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index bb68bf949..747919789 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -141,7 +141,7 @@ inlineVars lhsBound expr bound | Exists lhs' <- rebuildLHS lhs -> Let lhs' <$> travE e1 <*> substitute (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weaken` vars) e2 Evar (Var t ix) -> Evar . Var t <$> k1 ix - Foreign asm f e1 -> Foreign asm f <$> travE e1 + Foreign tp asm f e1 -> Foreign tp asm f <$> travE e1 Pair e1 e2 -> Pair <$> travE e1 <*> travE e2 Nil -> Just Nil VecPack vec e1 -> VecPack vec <$> travE e1 @@ -541,7 +541,7 @@ rebuildPreOpenExp k v av exp = LinearIndex a i -> LinearIndex <$> k av a <*> rebuildPreOpenExp k v av i Shape a -> Shape <$> k av a ShapeSize shr sh -> ShapeSize shr <$> rebuildPreOpenExp k v av sh - Foreign ff f e -> Foreign ff f <$> rebuildPreOpenExp k v av e + Foreign tp ff f e -> Foreign tp ff f <$> rebuildPreOpenExp k v av e Coerce t1 t2 e -> Coerce t1 t2 <$> rebuildPreOpenExp k v av e {-# INLINEABLE rebuildFun #-} @@ -661,7 +661,7 @@ rebuildPreOpenAcc k av acc = Stencil sr tp f b a -> Stencil sr tp <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b <*> k av a Stencil2 s1 s2 tp f b1 a1 b2 a2 -> Stencil2 s1 s2 tp <$> 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 + Aforeign repr ff afun as -> Aforeign repr ff afun <$> k av as {-# INLINEABLE rebuildAfun #-} rebuildAfun From 7e5ca843575ec15e1e2f00683d3d29cd7907b9f9 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 4 May 2020 13:53:31 +0200 Subject: [PATCH 189/316] add pattern synonyms for Ordering --- src/Data/Array/Accelerate.hs | 2 +- src/Data/Array/Accelerate/Classes/Eq.hs | 1 + src/Data/Array/Accelerate/Classes/Ord.hs | 13 ++++++++++++- 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 39da125b3..461e52546 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -306,7 +306,7 @@ module Data.Array.Accelerate ( -- ** Type classes -- *** Basic type classes Eq(..), - Ord(..), Ordering(..), + Ord(..), Ordering(..), pattern LT_, pattern EQ_, pattern GT_, Enum, succ, pred, Bounded, minBound, maxBound, diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index c99983182..28fd413e3 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -43,6 +43,7 @@ pattern True_ = Exp (Const True) pattern False_ :: Exp Bool pattern False_ = Exp (Const False) +{-# COMPLETE True_, False_ #-} infix 4 == diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 95c8e4ac1..d3d908b63 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -21,7 +22,7 @@ module Data.Array.Accelerate.Classes.Ord ( Ord(..), - Ordering(..), + Ordering(..), pattern LT_, pattern EQ_, pattern GT_, ) where @@ -45,6 +46,16 @@ infix 4 > infix 4 <= infix 4 >= +pattern LT_ :: Exp Ordering +pattern LT_ = Exp (Const LT) + +pattern EQ_ :: Exp Ordering +pattern EQ_ = Exp (Const EQ) + +pattern GT_ :: Exp Ordering +pattern GT_ = Exp (Const GT) +{-# COMPLETE LT_, EQ_, GT_ #-} + -- | The 'Ord' class for totally ordered datatypes -- class Eq a => Ord a where From 6723bf67e1d2940277562eb8bdfbc9e156e3101c Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Thu, 7 May 2020 15:38:13 +0200 Subject: [PATCH 190/316] Use SingleType instead of Scalar for remove memory --- .../Array/Accelerate/Array/Remote/Class.hs | 6 ++-- src/Data/Array/Accelerate/Array/Remote/LRU.hs | 32 +++++++++---------- .../Array/Accelerate/Array/Remote/Table.hs | 26 +++++++-------- src/Data/Array/Accelerate/Type.hs | 6 ++++ 4 files changed, 38 insertions(+), 32 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Remote/Class.hs b/src/Data/Array/Accelerate/Array/Remote/Class.hs index c8af43cef..a09236399 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Class.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Class.hs @@ -32,7 +32,7 @@ module Data.Array.Accelerate.Array.Remote.Class ( ) where import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Type (ScalarType) +import Data.Array.Accelerate.Type (SingleType) import Control.Applicative import Control.Monad.Catch @@ -56,10 +56,10 @@ class (Applicative m, Monad m, MonadCatch m, MonadMask m) => RemoteMemory m wher mallocRemote :: Int -> m (Maybe (RemotePtr m Word8)) -- | Copy the given number of elements from the host array into remote memory. - pokeRemote :: ScalarType e -> Int -> RemotePtr m (ScalarDataRepr e) -> ArrayData e -> m () + pokeRemote :: SingleType e -> Int -> RemotePtr m (ScalarDataRepr e) -> ArrayData e -> m () -- | Copy the given number of elements from remote memory to the host array. - peekRemote :: ScalarType e -> Int -> RemotePtr m (ScalarDataRepr e) -> MutableArrayData e -> m () + peekRemote :: SingleType e -> Int -> RemotePtr m (ScalarDataRepr e) -> MutableArrayData e -> m () -- | Cast a remote pointer. castRemotePtr :: RemotePtr m a -> RemotePtr m b diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs index 01f67025a..67783ff55 100644 --- a/src/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/src/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -52,9 +52,9 @@ import Prelude hiding ( lookup import qualified Data.HashTable.IO as HT import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Analysis.Type ( sizeOfScalarType ) -import Data.Array.Accelerate.Analysis.Match ( matchScalarType, (:~:)(..) ) -import Data.Array.Accelerate.Array.Data ( ArrayData, ScalarData, ScalarDataRepr, ScalarDict(..), scalarDict ) +import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) +import Data.Array.Accelerate.Analysis.Match ( matchSingleType, (:~:)(..) ) +import Data.Array.Accelerate.Array.Data ( ArrayData, ScalarData, ScalarDataRepr, ScalarDict(..), singleDict ) import Data.Array.Accelerate.Array.Remote.Class import Data.Array.Accelerate.Array.Remote.Table ( StableArray, makeWeakArrayData ) import Data.Array.Accelerate.Error ( internalError ) @@ -92,7 +92,7 @@ data Used task where -> {-# UNPACK #-} !Int -- Use count -> ![task] -- Asynchronous tasks using the array -> {-# UNPACK #-} !Int -- Number of elements - -> !(ScalarType e) + -> !(SingleType e) -> {-# UNPACK #-} !(Weak (ScalarData e)) -> Used task @@ -138,12 +138,12 @@ new release = do withRemote :: forall task m a c. (Task task, RemoteMemory m, MonadIO m, Functor m) => MemoryTable (RemotePtr m) task - -> ScalarType a + -> SingleType a -> ArrayData a -> (RemotePtr m (ScalarDataRepr a) -> m (task, c)) -> m (Maybe c) withRemote (MemoryTable !mt !ref _) !tp !arr run - | (_, ScalarDict) <- scalarDict tp = do + | (ScalarDict, _, _) <- singleDict tp = do key <- Basic.makeStableArray tp arr mp <- withMVar' ref $ \utbl -> do mu <- liftIO . HT.mutate utbl key $ \case @@ -177,7 +177,7 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run copyBack :: UT task -> Used task -> m (RemotePtr m (ScalarDataRepr a)) copyBack utbl (Used ts _ count tasks n tp' weak_arr) - | Just Refl <- matchScalarType tp tp' = do + | Just Refl <- matchSingleType tp tp' = do message "withRemote/reuploading-evicted-array" p <- mallocWithUsage mt utbl tp arr (Used ts Clean count tasks n tp weak_arr) pokeRemote tp n p arr @@ -220,13 +220,13 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run -- malloc :: forall e m task. (RemoteMemory m, MonadIO m, Task task) => MemoryTable (RemotePtr m) task - -> ScalarType e + -> SingleType e -> ArrayData e -> Bool -- ^ True if host array is frozen. -> Int -- ^ Number of elements -> m Bool -- ^ Was the array allocated successfully? malloc (MemoryTable mt ref weak_utbl) !tp !ad !frozen !n - | (_, ScalarDict) <- scalarDict tp -- Required for ArrayData e ~ ScalarData e + | (ScalarDict, _, _) <- singleDict tp -- Required for ArrayData e ~ ScalarData e = do ts <- liftIO $ getCPUTime key <- Basic.makeStableArray tp ad @@ -249,7 +249,7 @@ mallocWithUsage :: forall e m task. (RemoteMemory m, MonadIO m, Task task, ArrayData e ~ ScalarData e) => Basic.MemoryTable (RemotePtr m) -> UT task - -> ScalarType e + -> SingleType e -> ArrayData e -> Used task -> m (RemotePtr m (ScalarDataRepr e)) @@ -313,8 +313,8 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do _ -> return prev eldest prev _ = return prev - remoteBytes :: ScalarType e -> Int -> Int64 - remoteBytes tp n = fromIntegral (sizeOfScalarType tp) * fromIntegral n + remoteBytes :: SingleType e -> Int -> Int64 + remoteBytes tp n = fromIntegral (sizeOfSingleType tp) * fromIntegral n evictable :: Status -> Bool evictable Clean = True @@ -322,7 +322,7 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do evictable Unmanaged = False evictable Evicted = False - copyIfNecessary :: Status -> Int -> ScalarType e -> ArrayData e -> m () + copyIfNecessary :: Status -> Int -> SingleType e -> ArrayData e -> m () copyIfNecessary Clean _ _ _ = return () copyIfNecessary Unmanaged _ _ _ = return () copyIfNecessary Evicted _ _ _ = $internalError "evictLRU" "Attempting to evict already evicted array" @@ -338,7 +338,7 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do -- free :: forall m a task. (RemoteMemory m) => MemoryTable (RemotePtr m) task - -> ScalarType a + -> SingleType a -> ArrayData a -> IO () free (MemoryTable !mt !ref _) !tp !arr @@ -357,12 +357,12 @@ free (MemoryTable !mt !ref _) !tp !arr insertUnmanaged :: (MonadIO m, RemoteMemory m) => MemoryTable (RemotePtr m) task - -> ScalarType e + -> SingleType e -> ArrayData e -> RemotePtr m (ScalarDataRepr e) -> m () insertUnmanaged (MemoryTable mt ref weak_utbl) !tp !arr !ptr - | (_, ScalarDict) <- scalarDict tp = do -- Gives evidence that ArrayData e ~ ScalarData e + | (ScalarDict, _, _) <- singleDict tp = do -- Gives evidence that ArrayData e ~ ScalarData e key <- Basic.makeStableArray tp arr () <- Basic.insertUnmanaged mt tp arr ptr liftIO diff --git a/src/Data/Array/Accelerate/Array/Remote/Table.hs b/src/Data/Array/Accelerate/Array/Remote/Table.hs index d3f91493d..1b4116820 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Table.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Table.hs @@ -122,11 +122,11 @@ new release = do lookup :: forall m a. RemoteMemory m => MemoryTable (RemotePtr m) - -> ScalarType a + -> SingleType a -> ArrayData a -> IO (Maybe (RemotePtr m (ScalarDataRepr a))) lookup (MemoryTable !ref _ _ _) !tp !arr - | (_, ScalarDict) <- scalarDict tp = do + | (ScalarDict, _, _) <- singleDict tp = do sa <- makeStableArray tp arr mw <- withMVar ref (`HT.lookup` sa) case mw of @@ -159,12 +159,12 @@ lookup (MemoryTable !ref _ _ _) !tp !arr -- malloc :: forall a m. (RemoteMemory m, MonadIO m) => MemoryTable (RemotePtr m) - -> ScalarType a + -> SingleType a -> ArrayData a -> Int -> m (Maybe (RemotePtr m (ScalarDataRepr a))) malloc mt@(MemoryTable _ _ !nursery _) !tp !ad !n - | (_, ScalarDict) <- scalarDict tp = do + | (ScalarDict, _, _) <- singleDict tp = do -- Note: [Allocation sizes] -- -- Instead of allocating the exact number of elements requested, we round up to @@ -221,7 +221,7 @@ malloc mt@(MemoryTable _ _ !nursery _) !tp !ad !n -- free :: forall m a. (RemoteMemory m) => MemoryTable (RemotePtr m) - -> ScalarType a + -> SingleType a -> ArrayData a -> IO () free mt tp !arr = do @@ -259,13 +259,13 @@ freeStable (MemoryTable !ref _ !nrs _) !sa = insert :: forall m a. (RemoteMemory m, MonadIO m) => MemoryTable (RemotePtr m) - -> ScalarType a + -> SingleType a -> ArrayData a -> RemotePtr m (ScalarDataRepr a) -> Int -> m () insert mt@(MemoryTable !ref _ _ _) !tp !arr !ptr !bytes - | (_, ScalarDict) <- scalarDict tp = do + | (ScalarDict, _, _) <- singleDict tp = do key <- makeStableArray tp arr weak <- liftIO $ makeWeakArrayData tp arr () (Just $ freeStable @m mt key) message $ "insert: " ++ show key @@ -282,12 +282,12 @@ insert mt@(MemoryTable !ref _ _ _) !tp !arr !ptr !bytes insertUnmanaged :: forall m a. (MonadIO m, RemoteMemory m) => MemoryTable (RemotePtr m) - -> ScalarType a + -> SingleType a -> ArrayData a -> RemotePtr m (ScalarDataRepr a) -> m () insertUnmanaged (MemoryTable !ref !weak_ref _ _) tp !arr !ptr - | (_, ScalarDict) <- scalarDict tp = do + | (ScalarDict, _, _) <- singleDict tp = do key <- makeStableArray tp arr weak <- liftIO $ makeWeakArrayData tp arr () (Just $ remoteFinalizer weak_ref key) message $ "insertUnmanaged: " ++ show key @@ -356,11 +356,11 @@ remoteFinalizer !weak_ref !key = do {-# INLINE makeStableArray #-} makeStableArray :: MonadIO m - => ScalarType a + => SingleType a -> ArrayData a -> m StableArray makeStableArray !tp !ad - | (_, ScalarDict) <- scalarDict tp = return $! StableArray (uniqueArrayId ad) + | (ScalarDict, _, _) <- singleDict tp = return $! StableArray (uniqueArrayId ad) -- Weak arrays @@ -371,13 +371,13 @@ makeStableArray !tp !ad -- makeWeakArrayData :: forall e c. - ScalarType e + SingleType e -> ArrayData e -> c -> Maybe (IO ()) -> IO (Weak c) makeWeakArrayData !tp !ad !c !mf - | (_, ScalarDict) <- scalarDict tp = do + | (ScalarDict, _, _) <- singleDict tp = do let !uad = uniqueArrayData ad case mf of Nothing -> return () diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index 51427337d..817f1eabc 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -313,9 +313,15 @@ scalarTypeBool = SingleScalarType $ NonNumSingleType TypeBool scalarTypeInt :: ScalarType Int scalarTypeInt = SingleScalarType $ NumSingleType $ IntegralNumType TypeInt +scalarTypeInt32 :: ScalarType Int32 +scalarTypeInt32 = SingleScalarType $ NumSingleType $ IntegralNumType TypeInt32 + scalarTypeWord8 :: ScalarType Word8 scalarTypeWord8 = SingleScalarType $ NumSingleType $ IntegralNumType TypeWord8 +scalarTypeWord32 :: ScalarType Word32 +scalarTypeWord32 = SingleScalarType $ NumSingleType $ IntegralNumType TypeWord32 + -- Tuple representation -- ------------------- -- From e6f52e4e11c0e29142d4979be497f17c12c73cb3 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 8 May 2020 16:57:24 +0200 Subject: [PATCH 191/316] Fix shrinking bug --- src/Data/Array/Accelerate/Trafo/Fusion.hs | 4 +- src/Data/Array/Accelerate/Trafo/Shrink.hs | 115 ++++++++++++++-------- 2 files changed, 77 insertions(+), 42 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 9ab7b76a8..fb195c40d 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -1204,10 +1204,10 @@ zipWithD tp f cc1 cc0 | Lam lhsA (Lam lhsB (Body c')) <- weakenE (weakenWithLHS lhs1) c -> Lam lhs1 $ Body $ Let lhsA ixa' $ Let lhsB (weakenE (weakenWithLHS lhsA) ixb') c' Nothing - | CombinedLHS lhs k1 _ <- combineLhs lhs1 lhs2 + | CombinedLHS lhs k1 k2 <- combineLhs lhs1 lhs2 , Lam lhsA (Lam lhsB (Body c')) <- weakenE (weakenWithLHS lhs) c , ixa'' <- weakenE k1 ixa' - -> Lam lhs $ Body $ Let lhsA ixa'' $ Let lhsB {-(weakenE (weakenWithLHS lhsA .> k2) ixb')-} undefined c' + -> Lam lhs $ Body $ Let lhsA ixa'' $ Let lhsB (weakenE (weakenWithLHS lhsA .> k2) ixb') c' combineLhs :: LeftHandSide s t env env1' -> LeftHandSide s t env env2' -> CombinedLHS s t env1' env2' env combineLhs = go weakenId weakenId diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 755f3c66b..e4a35a334 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -52,6 +52,8 @@ import Data.Semigroup import Data.Monoid #endif +import Data.Either (fromRight) + -- friends import Data.Array.Accelerate.AST import Data.Array.Accelerate.Trafo.Base @@ -73,39 +75,52 @@ instance Kit acc => Shrink (PreOpenExp acc env aenv e) where instance Kit acc => Shrink (PreOpenFun acc env aenv f) where shrink' = shrinkFun -data VarsRange = VarsRange !Int !Int !(Maybe RangeTuple) -- first, count, tuple +data VarsRange env = VarsRange !(Exists (Idx env)) !Int !(Maybe RangeTuple) -- rightmost variable, count, tuple data RangeTuple = RTNil | RTSingle | RTPair !RangeTuple !RangeTuple -lhsVarsRange :: LeftHandSide s v env env' -> VarsRange -lhsVarsRange (LeftHandSideWildcard TupRunit) = VarsRange 0 0 $ Just RTNil -lhsVarsRange (LeftHandSideWildcard _) = VarsRange 0 0 Nothing -lhsVarsRange (LeftHandSideSingle _) = VarsRange 0 1 $ Just RTSingle -lhsVarsRange (LeftHandSidePair l1 l2) = VarsRange 0 (n1 + n2) $ RTPair <$> t1 <*> t2 +lhsVarsRange :: LeftHandSide s v env env' -> Either (env :~: env') (VarsRange env') +lhsVarsRange lhs = case rightIx lhs of + Left eq -> Left eq + Right ix -> let (n, rt) = go lhs + in Right $ VarsRange ix n rt where - VarsRange _ n1 t1 = lhsVarsRange l1 - VarsRange _ n2 t2 = lhsVarsRange l2 - -lhsSize :: LeftHandSide s v env env' -> Int -lhsSize (LeftHandSideWildcard _) = 0 -lhsSize (LeftHandSideSingle _) = 1 -lhsSize (LeftHandSidePair l1 l2) = lhsSize l1 + lhsSize l2 - -weakenVarsRange :: LeftHandSide s v env env' -> VarsRange -> VarsRange -weakenVarsRange lhs (VarsRange i n t) = VarsRange (i + lhsSize lhs) n t + rightIx :: LeftHandSide s v env env' -> Either (env :~: env') (Exists (Idx env')) + rightIx (LeftHandSideWildcard _) = Left Refl + rightIx (LeftHandSideSingle _) = Right $ Exists ZeroIdx + rightIx (LeftHandSidePair l1 l2) = case rightIx l2 of + Right ix -> Right ix + Left Refl -> rightIx l1 + + go :: LeftHandSide s v env env' -> (Int, Maybe (RangeTuple)) + go (LeftHandSideWildcard TupRunit) = (0, Just RTNil) + go (LeftHandSideWildcard _) = (0, Nothing) + go (LeftHandSideSingle _) = (1, Just RTSingle) + go (LeftHandSidePair l1 l2) = (n1 + n2, RTPair <$> t1 <*> t2) + where + (n1, t1) = go l1 + (n2, t2) = go l2 + +weakenVarsRange :: LeftHandSide s v env env' -> VarsRange env -> VarsRange env' +weakenVarsRange lhs (VarsRange ix n t) = VarsRange (go lhs ix) n t + where + go :: LeftHandSide s v env env' -> Exists (Idx env) -> Exists (Idx env') + go (LeftHandSideWildcard _) ix' = ix' + go (LeftHandSideSingle _) (Exists ix') = Exists (SuccIdx ix') + go (LeftHandSidePair l1 l2) ix' = go l2 $ go l1 ix' -matchEVarsRange :: VarsRange -> PreOpenExp acc env aenv t -> Bool -matchEVarsRange (VarsRange first _ (Just rt)) expr = isJust $ go first rt expr +matchEVarsRange :: VarsRange env -> PreOpenExp acc env aenv t -> Bool +matchEVarsRange (VarsRange (Exists first) _ (Just rt)) expr = isJust $ go (idxToInt first) rt expr where go :: Int -> RangeTuple -> PreOpenExp acc env aenv t -> Maybe Int go i RTNil Nil = Just i go i RTSingle (Evar (Var _ ix)) | checkIdx i ix = Just (i + 1) go i (RTPair t1 t2) (Pair e1 e2) - | Just i' <- go i t1 e1 = go i' t2 e2 + | Just i' <- go i t2 e2 = go i' t1 e1 go _ _ _ = Nothing checkIdx :: Int -> Idx env t -> Bool @@ -114,12 +129,23 @@ matchEVarsRange (VarsRange first _ (Just rt)) expr = isJust $ go first rt expr checkIdx _ _ = False matchEVarsRange _ _ = False -varInRange :: VarsRange -> Var s env t -> Maybe Usages -varInRange (VarsRange i n _) (Var _ ix) - | 0 <= j && j < n = Just $ replicate j False ++ [True] ++ replicate (n - j - 1) False - | otherwise = Nothing +varInRange :: VarsRange env -> Var s env t -> Maybe Usages +varInRange (VarsRange (Exists rangeIx) n _) (Var _ varIx) = case go rangeIx varIx of + Nothing -> Nothing + Just j -> Just $ replicate j False ++ [True] ++ replicate (n - j - 1) False where - j = n - 1 - (idxToInt ix - i) + -- `go ix ix'` checks whether ix <= ix' with recursion, and then checks + -- whether ix' < ix + n in go'. Returns a Just if both checks + -- are successful, containing an integer j such that ix + j = ix'. + go :: Idx env u -> Idx env t -> Maybe Int + go (SuccIdx ix) (SuccIdx ix') = go ix ix' + go ZeroIdx ix' = go' ix' 0 + go _ ZeroIdx = Nothing + + go' :: Idx env t -> Int -> Maybe Int + go' _ j | j >= n = Nothing + go' ZeroIdx j = Just j + go' (SuccIdx ix') j = go' ix' (j + 1) -- Describes how often the variables defined in a LHS are used together. data Count @@ -156,8 +182,8 @@ shrinkLhs (Impossible usages) lhs = case go usages lhs of go (True : us) (LeftHandSideSingle tp) = (False, us, Exists $ LeftHandSideSingle tp) go (False : us) (LeftHandSideSingle tp) = (True , us, Exists $ LeftHandSideWildcard $ TupRsingle tp) go us (LeftHandSidePair l1 l2) - | (c1, us' , Exists l1') <- go us l1 - , (c2, us'', Exists l2') <- go us' l2 + | (c2, us' , Exists l2') <- go us l2 + , (c1, us'', Exists l1') <- go us' l1 , Exists l2'' <- rebuildLHS l2' = let lhs' @@ -226,21 +252,23 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE | otherwise -> Let lhs <$> bnd' <*> body' where shouldInline = case count of + Finite 0 -> False -- Handled by shrinkLhs Finite n -> n <= lIMIT || cheap (snd bnd') Infinity -> cheap (snd bnd') Impossible _ -> False bnd' = shrinkE bnd body' = shrinkE body - range = lhsVarsRange lhs + -- If the lhs includes non-trivial wildcards (the last field of range is Nothing), -- then we cannot inline the binding. We can only check which variables are not used, -- to detect unused variables. -- If the lhs does not include non-trivial wildcards (the last field of range is a Just), -- we can both analyse whether we can inline the binding, and check which variables are -- not used, to detect unused variables. - - count = usesOfExp range (snd body') + count = case lhsVarsRange lhs of + Left _ -> Finite 0 + Right range -> usesOfExp range (snd body') msg = case count of Finite 0 -> "dead exp" @@ -278,15 +306,22 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE yes (_, x) = (Any True, x) shrinkFun :: Kit acc => PreOpenFun acc env aenv f -> (Bool, PreOpenFun acc env aenv f) -shrinkFun (Lam lhs f) - | Just (Exists lhs') <- shrinkLhs count lhs = case strengthenE (strengthenShrunkLHS lhs lhs' Just) f' of - Just f'' -> (True, Lam lhs' f'') - Nothing -> error "shrinkFun: Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." - | otherwise = (b, Lam lhs f') +shrinkFun (Lam lhs f) = case lhsVarsRange lhs of + Left Refl -> + let b' = case lhs of + LeftHandSideWildcard TupRunit -> b + _ -> True + in (b', Lam (LeftHandSideWildcard $ lhsToTupR lhs) f') + Right range -> + let + count = usesOfFun range f + in case shrinkLhs count lhs of + Just (Exists lhs') -> case strengthenE (strengthenShrunkLHS lhs lhs' Just) f' of + Just f'' -> (True, Lam lhs' f'') + Nothing -> error "shrinkFun: Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." + Nothing -> (b, Lam lhs f') where (b, f') = shrinkFun f - range = lhsVarsRange lhs - count = usesOfFun range f shrinkFun (Body b) = Body <$> shrinkExp b @@ -424,7 +459,7 @@ shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrinkA" shrinkA -- 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 t. VarsRange -> PreOpenExp acc env aenv t -> Count +usesOfExp :: forall acc env aenv t. VarsRange env -> PreOpenExp acc env aenv t -> Count usesOfExp range = countE where countE :: PreOpenExp acc env aenv e -> Count @@ -456,9 +491,9 @@ usesOfExp range = countE Foreign _ _ _ e -> countE e Coerce _ _ e -> countE e -usesOfFun :: VarsRange -> PreOpenFun acc env aenv f -> Count -usesOfFun range' (Lam lhs f) = usesOfFun (weakenVarsRange lhs range') f -usesOfFun range' (Body b) = usesOfExp range' b +usesOfFun :: VarsRange env -> PreOpenFun acc env aenv f -> Count +usesOfFun range (Lam lhs f) = usesOfFun (weakenVarsRange lhs range) f +usesOfFun range (Body b) = usesOfExp range b -- 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 From 6244ee6a14b03783f5626db422d633dcd1d2415b Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Mon, 11 May 2020 09:54:38 +0200 Subject: [PATCH 192/316] Fix pattern synonyms for Ordering after merge --- src/Data/Array/Accelerate/Classes/Ord.hs | 40 +++++++++++++----------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 72624cae0..a2b52b1c0 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -32,28 +32,30 @@ import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Classes.Eq +-- We must hide (==), as that operator is used for the literals 0, 1 and 2 in the pattern synonyms for Ordering. +-- As RebindableSyntax is enabled, a literal pattern is compiled to a call to (==), meaning that the Prelude.(==) should be in scope as (==). +import Data.Array.Accelerate.Classes.Eq hiding ( (==) ) +import qualified Data.Array.Accelerate.Classes.Eq as A import Text.Printf -import Prelude ( ($), (.), (>>=), Ordering(..), Num(..), Maybe(..), String, show, error, unlines, return, concat, map, mapM ) +import Prelude ( ($), (.), (>>=), Ordering(..), Num(..), Maybe(..), String, show, error, unlines, return, concat, map, mapM, (==) ) import Language.Haskell.TH hiding ( Exp ) import Language.Haskell.TH.Extra import qualified Prelude as P - infix 4 < infix 4 > infix 4 <= infix 4 >= pattern LT_ :: Exp Ordering -pattern LT_ = Exp (Const LT) +pattern LT_ = Exp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeInt8))) 0)) pattern EQ_ :: Exp Ordering -pattern EQ_ = Exp (Const EQ) +pattern EQ_ = Exp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeInt8))) 1)) pattern GT_ :: Exp Ordering -pattern GT_ = Exp (Const GT) +pattern GT_ = Exp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeInt8))) 2)) {-# COMPLETE LT_, EQ_, GT_ #-} -- | The 'Ord' class for totally ordered datatypes @@ -68,18 +70,18 @@ class Eq a => Ord a where 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 + x < y = if compare x y A.== constant LT then constant True else constant False + x <= y = if compare x y A.== constant GT then constant False else constant True + x > y = if compare x y A.== constant GT then constant True else constant False + x >= y = if compare x y A.== 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 + if x A.== 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) -- @@ -122,8 +124,8 @@ instance Elt Ordering where 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) + x == y = mkBitcast x A.== (mkBitcast y :: Exp Int8) + x /= y = mkBitcast x /= (mkBitcast y :: Exp Int8) instance Ord Ordering where x < y = mkBitcast x < (mkBitcast y :: Exp Int8) @@ -225,22 +227,22 @@ $(runQ $ do mkLt' :: [ExpQ] -> [ExpQ] -> ExpQ mkLt' [x] [y] = [| $x < $y |] - mkLt' (x:xs) (y:ys) = [| $x < $y || ( $x == $y && $(mkLt' xs ys) ) |] + mkLt' (x:xs) (y:ys) = [| $x < $y || ( $x A.== $y && $(mkLt' xs ys) ) |] mkLt' _ _ = error "mkLt'" mkGt' :: [ExpQ] -> [ExpQ] -> ExpQ mkGt' [x] [y] = [| $x > $y |] - mkGt' (x:xs) (y:ys) = [| $x > $y || ( $x == $y && $(mkGt' xs ys) ) |] + mkGt' (x:xs) (y:ys) = [| $x > $y || ( $x A.== $y && $(mkGt' xs ys) ) |] mkGt' _ _ = error "mkGt'" mkLtEq' :: [ExpQ] -> [ExpQ] -> ExpQ mkLtEq' [x] [y] = [| $x < $y |] - mkLtEq' (x:xs) (y:ys) = [| $x < $y || ( $x == $y && $(mkLtEq' xs ys) ) |] + mkLtEq' (x:xs) (y:ys) = [| $x < $y || ( $x A.== $y && $(mkLtEq' xs ys) ) |] mkLtEq' _ _ = error "mkLtEq'" mkGtEq' :: [ExpQ] -> [ExpQ] -> ExpQ mkGtEq' [x] [y] = [| $x > $y |] - mkGtEq' (x:xs) (y:ys) = [| $x > $y || ( $x == $y && $(mkGtEq' xs ys) ) |] + mkGtEq' (x:xs) (y:ys) = [| $x > $y || ( $x A.== $y && $(mkGtEq' xs ys) ) |] mkGtEq' _ _ = error "mkGtEq'" mkTup :: Int -> Q [Dec] From 3879e2be3dab37f903ba623771b6f670932d5506 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Mon, 11 May 2020 09:54:48 +0200 Subject: [PATCH 193/316] Remove unused import --- src/Data/Array/Accelerate/Trafo/Shrink.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index e4a35a334..f9e25c9a0 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -52,8 +52,6 @@ import Data.Semigroup import Data.Monoid #endif -import Data.Either (fromRight) - -- friends import Data.Array.Accelerate.AST import Data.Array.Accelerate.Trafo.Base From 8143b46ad2161bbeb77c99a2c0404e6152a6d230 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Thu, 14 May 2020 09:54:52 +0200 Subject: [PATCH 194/316] Remove redundant parentheses --- src/Data/Array/Accelerate/Type.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index 817f1eabc..e10c26ecb 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -359,7 +359,7 @@ type Tup7 a b c d e f g = ((((((((), a), b), c), d), e), f), g) type Tup8 a b c d e f g h = (((((((((), a), b), c), d), e), f), g), h) type Tup9 a b c d e f g h i = ((((((((((), a), b), c), d), e), f), g), h), i) type Tup16 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)) + i j k l m n o p = (((((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n), o), p) tupR2 :: TupR s t1 -> TupR s t2 -> TupR s (Tup2 t1 t2) tupR2 t1 t2 = TupRunit `TupRpair` t1 `TupRpair` t2 From 90e332d02d819b7534785783d31f59347f2215d3 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Thu, 14 May 2020 09:55:10 +0200 Subject: [PATCH 195/316] Fix alignment --- src/Data/Array/Accelerate/Type.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index e10c26ecb..f7a1c0c49 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -359,7 +359,7 @@ type Tup7 a b c d e f g = ((((((((), a), b), c), d), e), f), g) type Tup8 a b c d e f g h = (((((((((), a), b), c), d), e), f), g), h) type Tup9 a b c d e f g h i = ((((((((((), a), b), c), d), e), f), g), h), i) type Tup16 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) + i j k l m n o p = (((((((((((((((((), a), b), c), d), e), f), g), h), i), j), k), l), m), n), o), p) tupR2 :: TupR s t1 -> TupR s t2 -> TupR s (Tup2 t1 t2) tupR2 t1 t2 = TupRunit `TupRpair` t1 `TupRpair` t2 From 9d9ca3819bd33c269f0329d6b183c69030cc8b9b Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Fri, 15 May 2020 16:19:45 +0200 Subject: [PATCH 196/316] Split let bindings when RHS is a pair --- src/Data/Array/Accelerate/Trafo/Base.hs | 2 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 25 ++++++++++----------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index a0b7d66c0..a21e7e433 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -45,7 +45,7 @@ module Data.Array.Accelerate.Trafo.Base ( -- Environments Gamma(..), incExp, prjExp, pushExp, Extend(..), pushArrayEnv, append, bind, - Sink(..), sinkA, sink1, + Sink(..), SinkExp(..), sinkA, sink1, PreOpenExp', bindExps, -- Adding new variables to the environment diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index e255a819a..df797bebd 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -211,20 +211,10 @@ simplifyOpenExp env = first getAny . cvtE where cvtE :: PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t) cvtE exp = case exp of - Let lhs@(LeftHandSideSingle _) 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 lhs <$> bnd' <*> body' + Let lhs bnd body -> (u <> v, exp') where - bnd' = cvtE bnd - env' = env `pushExp` snd bnd' - body' = cvtE' (incExp env') body - Let lhs bnd body -> Let lhs <$> bnd' <*> body' - where - bnd' = cvtE bnd - env' = lhsExpr lhs env - body' = cvtE' env' body - + (u, bnd') = cvtE bnd + (v, exp') = cvtLet env lhs bnd' (\env' -> cvtE' env' body) Evar var -> pure $ Evar var Const tp c -> pure $ Const tp c Undef tp -> pure $ Undef tp @@ -256,6 +246,15 @@ simplifyOpenExp env = first getAny . cvtE cvtF :: Gamma acc env' env' aenv -> PreOpenFun acc env' aenv f -> (Any, PreOpenFun acc env' aenv f) cvtF env' = first Any . simplifyOpenFun env' + cvtLet :: Gamma acc env' env' aenv -> ELeftHandSide bnd env' env'' -> PreOpenExp acc env' aenv bnd -> (Gamma acc env'' env'' aenv -> (Any, PreOpenExp acc env'' aenv t)) -> (Any, PreOpenExp acc env' aenv t) + cvtLet env' lhs@(LeftHandSideSingle _) bnd body = Let lhs bnd <$> body (incExp $ env' `pushExp` bnd) -- Single variable on the LHS, add binding to the environment + cvtLet env' (LeftHandSideWildcard _) _ body = body env' -- Binding not used, remove let binding + cvtLet env' (LeftHandSidePair l1 l2) (Pair e1 e2) body = -- Split binding to multiple bindings + first (const $ Any True) $ + cvtLet env' l1 e1 $ + \env'' -> cvtLet env'' l2 (weakenE (weakenWithLHS l1) e2) body + cvtLet env' lhs bnd body = Let lhs bnd <$> body (lhsExpr lhs env') -- Cannot split this binding. + -- Simplify conditional expressions, in particular by eliminating branches -- when the predicate is a known constant. -- From efb4aa85b18be70cb65270d6711211a2db32604d Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Sat, 16 May 2020 00:02:28 +0200 Subject: [PATCH 197/316] Split Alet bindings if RHS is an Apair --- accelerate.cabal | 1 + src/Data/Array/Accelerate/Trafo.hs | 3 + src/Data/Array/Accelerate/Trafo/LetSplit.hs | 82 +++++++++++++++++++++ 3 files changed, 86 insertions(+) create mode 100644 src/Data/Array/Accelerate/Trafo/LetSplit.hs diff --git a/accelerate.cabal b/accelerate.cabal index d86e63cda..29957e9d5 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -380,6 +380,7 @@ Library Data.Array.Accelerate.Trafo.Base Data.Array.Accelerate.Trafo.Config Data.Array.Accelerate.Trafo.Fusion + Data.Array.Accelerate.Trafo.LetSplit Data.Array.Accelerate.Trafo.Sharing Data.Array.Accelerate.Trafo.Shrink Data.Array.Accelerate.Trafo.Simplify diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 5e38edf22..7266a3a1b 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -65,6 +65,7 @@ import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, A 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.LetSplit as LetSplit 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 @@ -89,6 +90,7 @@ convertAcc = convertAccWith defaultOptions convertAccWith :: Config -> Acc arrs -> DelayedAcc (ArrRepr arrs) convertAccWith config = phase "array-fusion" (Fusion.convertAccWith config) + . phase "array-split-lets" LetSplit.convertAcc -- phase "vectorise-sequences" Vectorise.vectoriseSeqAcc `when` vectoriseSequences . phase "sharing-recovery" (Sharing.convertAccWith config) @@ -102,6 +104,7 @@ convertAfun = convertAfunWith defaultOptions convertAfunWith :: Afunction f => Config -> f -> DelayedAfun (AreprFunctionR f) convertAfunWith config = phase "array-fusion" (Fusion.convertAfunWith config) + . phase "array-split-lets" LetSplit.convertAfun -- phase "vectorise-sequences" Vectorise.vectoriseSeqAfun `when` vectoriseSequences . phase "sharing-recovery" (Sharing.convertAfunWith config) diff --git a/src/Data/Array/Accelerate/Trafo/LetSplit.hs b/src/Data/Array/Accelerate/Trafo/LetSplit.hs new file mode 100644 index 000000000..3376090fc --- /dev/null +++ b/src/Data/Array/Accelerate/Trafo/LetSplit.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE GADTs #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.LetSplit +-- Copyright : [2012..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Trafo.LetSplit ( + + convertAcc, convertAfun + +) where + +import Prelude hiding ( exp ) +import Data.Array.Accelerate.Array.Representation +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Trafo.Base + +convertAcc :: Kit acc => acc aenv a -> acc aenv a +convertAcc acc = case extract acc of + Just a -> travA a + Nothing -> acc + +travA :: Kit acc => PreOpenAcc acc aenv a -> acc aenv a +travA (Alet lhs bnd body) = travBinding lhs (convertAcc bnd) (convertAcc body) +travA (Avar var) = inject $ Avar var +travA (Apair a1 a2) = inject $ Apair (convertAcc a1) (convertAcc a2) +travA Anil = inject $ Anil +travA (Apply repr f a) = inject $ Apply repr (convertAfun f) (convertAcc a) +travA (Aforeign repr asm f a) = inject $ Aforeign repr asm (convertAfun f) (convertAcc a) +travA (Acond e a1 a2) = inject $ Acond (travE e) (convertAcc a1) (convertAcc a2) +travA (Awhile c f a) = inject $ Awhile (convertAfun c) (convertAfun f) (convertAcc a) +travA (Use repr arr) = inject $ Use repr arr +travA (Unit tp e) = inject $ Unit tp (travE e) +travA (Reshape shr e a) = inject $ Reshape shr (travE e) a +travA (Generate repr e f) = inject $ Generate repr (travE e) (travF f) +travA (Transform repr sh f g a) = inject $ Transform repr (travE sh) (travF f) (travF g) (convertAcc a) +travA (Replicate slix sl a) = inject $ Replicate slix (travE sl) (convertAcc a) +travA (Slice slix a sl) = inject $ Slice slix (convertAcc a) (travE sl) +travA (Map tp f a) = inject $ Map tp (travF f) (convertAcc a) +travA (ZipWith tp f a1 a2) = inject $ ZipWith tp (travF f) (convertAcc a1) (convertAcc a2) +travA (Fold f e a) = inject $ Fold (travF f) (travE e) (convertAcc a) +travA (Fold1 f a) = inject $ Fold1 (travF f) (convertAcc a) +travA (FoldSeg i f e a s) = inject $ FoldSeg i (travF f) (travE e) (convertAcc a) (convertAcc s) +travA (Fold1Seg i f a s) = inject $ Fold1Seg i (travF f) (convertAcc a) (convertAcc s) +travA (Scanl f e a) = inject $ Scanl (travF f) (travE e) (convertAcc a) +travA (Scanl' f e a) = inject $ Scanl' (travF f) (travE e) (convertAcc a) +travA (Scanl1 f a) = inject $ Scanl1 (travF f) (convertAcc a) +travA (Scanr f e a) = inject $ Scanr (travF f) (travE e) (convertAcc a) +travA (Scanr' f e a) = inject $ Scanr' (travF f) (travE e) (convertAcc a) +travA (Scanr1 f a) = inject $ Scanr1 (travF f) (convertAcc a) +travA (Permute f a1 g a2) = inject $ Permute (travF f) (convertAcc a1) (travF g) (convertAcc a2) +travA (Backpermute shr sh f a) = inject $ Backpermute shr (travE sh) (travF f) (convertAcc a) +travA (Stencil s tp f b a) = inject $ Stencil s tp (travF f) (travB b) (convertAcc a) +travA (Stencil2 s1 s2 tp f b1 a1 b2 a2) = inject $ Stencil2 s1 s2 tp (travF f) (travB b1) (convertAcc a1) (travB b2) (convertAcc a2) + +travBinding :: Kit acc => ALeftHandSide bnd aenv aenv' -> acc aenv bnd -> acc aenv' a -> acc aenv a +travBinding (LeftHandSideWildcard _) _ a = a +travBinding lhs@(LeftHandSideSingle _) bnd a = inject $ Alet lhs bnd a +travBinding lhs@(LeftHandSidePair l1 l2) bnd a = case extract bnd of + Just (Apair b1 b2) -> travBinding l1 b1 $ travBinding l2 (weaken (weakenWithLHS l1) b2) a + _ -> inject $ Alet lhs bnd a + +-- XXX: We assume that any Acc contained in an expression is Avar. +-- We thus do not have to descend into expressions. +-- This isn't yet enforced using the types however. +travE :: PreExp acc aenv t -> PreExp acc aenv t +travE = id + +travF :: PreFun acc aenv t -> PreFun acc aenv t +travF = id + +travB :: PreBoundary acc aenv (Array sh e) -> PreBoundary acc aenv (Array sh e) +travB = id + +convertAfun :: Kit acc => PreOpenAfun acc aenv f -> PreOpenAfun acc aenv f +convertAfun (Alam lhs f) = Alam lhs $ convertAfun f +convertAfun (Abody a) = Abody $ convertAcc a From 897064b542483124321e47338d92dc6e84031498 Mon Sep 17 00:00:00 2001 From: David Date: Mon, 18 May 2020 18:04:46 +0200 Subject: [PATCH 198/316] change O(n^3) to O(n+m^2) (where m< NodeCounts -> NodeCounts -(ns1,g1) +++ (ns2,g2) = (foldr insert ns1 ns2, Map.unionWith Set.union g1 g2) +(ns1, g1) +++ (ns2, g2) = (cleanup $ merge 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' + merge [] x = x + merge x [] = x + merge (x@(AccNodeCount sa1 count1):xs) (y@(AccNodeCount sa2 count2):ys) + | sa1 == sa2 = AccNodeCount (sa1 `pickNoneAvar` sa2) (count1 + count2) : merge xs ys + | sa1 `higherSSA` sa2 = x : merge xs (y:ys) + | otherwise = y : merge (x:xs) ys + merge (x@(ExpNodeCount se1 count1):xs) (y@(ExpNodeCount se2 count2):ys) + | se1 == se2 = ExpNodeCount (se1 `pickNoneVar` se2) (count1 + count2) : merge xs ys + | se1 `higherSSE` se2 = x : merge xs (y:ys) + | otherwise = y : merge (x:xs) ys + merge (x@(AccNodeCount _ _):xs) (y@(ExpNodeCount _ _):ys) = y : merge (x:xs) ys + merge (x@(ExpNodeCount _ _):xs) (y@(AccNodeCount _ _):ys) = x : merge xs (y:ys) (StableSharingAcc _ (AvarSharing _)) `pickNoneAvar` sa2 = sa2 sa1 `pickNoneAvar` _sa2 = sa1 @@ -2088,9 +2076,15 @@ nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeNam (StableSharingExp _ (VarSharing _)) `pickNoneVar` sa2 = sa2 sa1 `pickNoneVar` _sa2 = sa1 - -- pickNoneSvar :: StableSharingSeq -> StableSharingSeq -> StableSharingSeq - -- (StableSharingSeq _ (SvarSharing _)) `pickNoneSvar` sa2 = sa2 - -- sa1 `pickNoneSvar` _sa2 = sa1 + -- As the StableSharingAccs do not pose a strict ordering, this cleanup step is needed. + -- In this step, all pairs of AccNodes and ExpNodes that are of the same height are compared against eachother. + -- Without this step, duplicates may arise. + -- Note that while (+++) is morally symmetric, replacing `merge [x] y' with `merge y [x]' inside of `cleanup' won't check all required possibilities. + cleanup = concatMap (foldr (\x y -> merge [x] y) []) . groupBy sameHeight + sameHeight (AccNodeCount sa1 _) (AccNodeCount sa2 _) = not (sa1 `higherSSA` sa2) && not (sa2 `higherSSA` sa1) + sameHeight (ExpNodeCount se1 _) (ExpNodeCount se2 _) = not (se1 `higherSSE` se2) && not (se2 `higherSSE` se1) + sameHeight _ _ = False + -- 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 From f59a08b252fe3c518e31dc3aff4b8ef8cef0b5a3 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 19 May 2020 12:31:07 +0200 Subject: [PATCH 199/316] simplify semigroup instance --- src/Data/Array/Accelerate/Data/Monoid.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Monoid.hs b/src/Data/Array/Accelerate/Data/Monoid.hs index 7c217a161..517307586 100644 --- a/src/Data/Array/Accelerate/Data/Monoid.hs +++ b/src/Data/Array/Accelerate/Data/Monoid.hs @@ -114,8 +114,8 @@ instance Num a => Monoid (Exp (Sum a)) where #if __GLASGOW_HASKELL__ >= 800 -- | @since 1.2.0.0 instance Num a => Semigroup (Exp (Sum a)) where - (<>) = (+) - stimes n x = Sum_ $ P.fromIntegral n * getSum (unlift x :: Sum (Exp a)) + (<>) = (+) + stimes n (Sum_ x) = Sum_ $ P.fromIntegral n * x #endif @@ -174,8 +174,8 @@ instance Num a => Monoid (Exp (Product a)) where #if __GLASGOW_HASKELL__ >= 800 -- | @since 1.2.0.0 instance Num a => Semigroup (Exp (Product a)) where - (<>) = (*) - stimes n x = Product_ $ getProduct (unlift x :: Product (Exp a)) ^ (P.fromIntegral n :: Exp Int) + (<>) = (*) + stimes n (Product_ x) = Product_ $ x ^ (P.fromIntegral n :: Exp Int) #endif From 12ee3e6a57620be238393e49251f497b45ee9068 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 19 May 2020 12:31:15 +0200 Subject: [PATCH 200/316] update README.md --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index bf9d66629..c748eb722 100644 --- a/README.md +++ b/README.md @@ -256,7 +256,8 @@ Here is a list of features that are currently missing: [Wiki]: https://github.com/AccelerateHS/accelerate/wiki [Issues]: https://github.com/AccelerateHS/accelerate/issues [Google-Group]: http://groups.google.com/group/accelerate-haskell - [HOAS-conv]: https://web.archive.org/web/20180805092417/http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ + [HOAS-conv]: https://github.com/mchakravarty/hoas-conv + [repa]: http://hackage.haskell.org/package/repa [wiki-cc]: https://en.wikipedia.org/wiki/CUDA#Supported_GPUs [YLJ13-video]: http://youtu.be/ARqE4yT2Z0o From 04f4cd65e8e67c8e5c8ec822749dfddcf96aa8ae Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 19 May 2020 13:32:35 +0200 Subject: [PATCH 201/316] add github actions CI --- .github/workflows/ci.yml | 62 ++++++++++++++++++++++++++++++++++++++++ README.md | 1 + 2 files changed, 63 insertions(+) create mode 100644 .github/workflows/ci.yml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 000000000..fdd2c011b --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,62 @@ +name: CI + +# Trigger the workflow on push or pull request, but only for the master branch +on: + pull_request: + push: + branches: [master] + +jobs: + stack: + name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ubuntu-latest, macOS-latest, windows-latest] + stack: ["latest"] + ghc: + - "8.8" + - "8.6" + - "8.4" + - "8.2" + exclude: + - os: macOS-latest + ghc: 8.6 + - os: macOS-latest + ghc: 8.4 + - os: macOS-latest + ghc: 8.2 + - os: windows-latest + ghc: 8.6 + - os: windows-latest + ghc: 8.4 + - os: windows-latest + ghc: 8.2 + + steps: + - uses: actions/checkout@v2 + if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' + + - uses: actions/setup-haskell@v1.1 + name: Setup Haskell Stack + with: + enable-stack: true + ghc-version: ${{ matrix.ghc }} + stack-version: ${{ matrix.stack }} + + - uses: actions/cache@v1 + name: Cache ~/.stack + with: + path: ~/.stack + key: ${{ runner.os }}-${{ matrix.ghc }}-stack + + - name: Build + run: | + ln -s stack-${{ matrix.ghc }}.yaml stack.yaml + stack build --test --no-run-tests --system-ghc --flag accelerate:nofib + + - name: Test + run: | + stack test accelerate:doctest --system-ghc --flag accelerate:nofib + stack test accelerate:nofib-interpreter --system-ghc --flag accelerate:nofib --test-arguments='--hedgehog-tests 25' + diff --git a/README.md b/README.md index c748eb722..0de984d7d 100644 --- a/README.md +++ b/README.md @@ -5,6 +5,7 @@ [![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) +[![GitHub CI](https://github.com/tmcdonell/accelerate/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate/actions) [![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby)
[![Stackage LTS](https://stackage.org/package/accelerate/badge/lts)](https://stackage.org/lts/package/accelerate) From 2899072a4c0f74a642172970cd2d1380597f118b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 19 May 2020 13:41:15 +0200 Subject: [PATCH 202/316] run workflows on push to branches --- .github/workflows/ci.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index fdd2c011b..6376c5bb1 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -1,10 +1,10 @@ name: CI # Trigger the workflow on push or pull request, but only for the master branch -on: - pull_request: - push: - branches: [master] +# on: +# pull_request: +# push: +# branches: [master] jobs: stack: From 676e1dd517f32fdb0926c6d4a08e14bc28b2131c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 19 May 2020 13:43:26 +0200 Subject: [PATCH 203/316] =?UTF-8?q?okay=20but=20we=20still=20need=20an=20e?= =?UTF-8?q?vent=20trigger=20for=20=E2=80=98on=E2=80=99?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/ci.yml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6376c5bb1..669a46c36 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -1,10 +1,11 @@ name: CI -# Trigger the workflow on push or pull request, but only for the master branch -# on: -# pull_request: -# push: -# branches: [master] +# Trigger the workflow on push or pull request +on: + pull_request: + push: + # but only for the master branch + # branches: [master] jobs: stack: From 2d3f4f397dff0f86df1ab24069340b46975e1000 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 19 May 2020 14:47:16 +0200 Subject: [PATCH 204/316] script kiddie n00b --- .github/workflows/ci.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 669a46c36..2df126d7d 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -36,7 +36,6 @@ jobs: steps: - uses: actions/checkout@v2 - if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - uses: actions/setup-haskell@v1.1 name: Setup Haskell Stack From de2149abb20e377a508540796acd085a35d6b808 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 20 May 2020 11:22:54 +0200 Subject: [PATCH 205/316] Add stencilHalo Previously defined in accelerate-llvm --- .../Array/Accelerate/Array/Representation.hs | 27 ++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index 5bf39d8b2..7c8fdbed4 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -44,7 +44,7 @@ module Data.Array.Accelerate.Array.Representation ( VecR(..), vecRvector, vecRtuple, vecPack, vecUnpack, -- * Stencils - StencilR(..), stencilElt, stencilShape, stencilType, stencilArrayR, + StencilR(..), stencilElt, stencilShape, stencilType, stencilArrayR, stencilHalo, -- * Show showShape, showElement, showArray, showArray', @@ -489,6 +489,31 @@ stencilType (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) = tupR9 (stencilType s1) ( stencilArrayR :: StencilR sh e pat -> ArrayR (Array sh e) stencilArrayR stencil = ArrayR (stencilShape stencil) (stencilElt stencil) +stencilHalo :: StencilR sh e stencil -> (ShapeR sh, sh) +stencilHalo = go' + where + go' :: StencilR sh e stencil -> (ShapeR sh, sh) + go' StencilRunit3{} = (dim1, ((), 1)) + go' StencilRunit5{} = (dim1, ((), 2)) + go' StencilRunit7{} = (dim1, ((), 3)) + go' StencilRunit9{} = (dim1, ((), 4)) + -- + go' (StencilRtup3 a b c ) = (ShapeRsnoc shr, cons shr 1 $ foldl1 (union shr) [a', go b, go c]) + where (shr, a') = go' a + go' (StencilRtup5 a b c d e ) = (ShapeRsnoc shr, cons shr 2 $ foldl1 (union shr) [a', go b, go c, go d, go e]) + where (shr, a') = go' a + go' (StencilRtup7 a b c d e f g ) = (ShapeRsnoc shr, cons shr 3 $ foldl1 (union shr) [a', go b, go c, go d, go e, go f, go g]) + where (shr, a') = go' a + go' (StencilRtup9 a b c d e f g h i) = (ShapeRsnoc shr, cons shr 4 $ foldl1 (union shr) [a', go b, go c, go d, go e, go f, go g, go h, go i]) + where (shr, a') = go' a + + go :: StencilR sh e stencil -> sh + go = snd . go' + + cons :: ShapeR sh -> Int -> sh -> (sh, Int) + cons ShapeRz ix () = ((), ix) + cons (ShapeRsnoc shr) ix (sh, sz) = (cons shr ix sh, sz) + rnfArray :: ArrayR a -> a -> () rnfArray (ArrayR shr tp) (Array sh ad) = rnfShape shr sh `seq` rnfArrayData tp ad From f08ccfac3229380e1513b5e9c992b604ec00d0be Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 20 May 2020 13:40:47 +0200 Subject: [PATCH 206/316] Fix parentheses of tuples in pretty printer --- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 6 ++--- src/Data/Array/Accelerate/Pretty/Print.hs | 25 ++++++++++---------- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index b99e8a369..4a82b9418 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -506,7 +506,7 @@ prettyDelayedOpenFun env0 aenv = next "\\\\" env0 nest shiftwidth (sep [ vs <> "→" , prettyDelayedOpenExp context0 env aenv body ]) next vs env (Lam lhs lam) = - let (env', arg) = prettyELhs env lhs + let (env', arg) = prettyELhs True env lhs in next (vs <> arg <> space) env' lam prettyDelayedOpenExp @@ -546,7 +546,7 @@ fvPreOpenFun fvPreOpenFun fvA env aenv (Body b) = fvPreOpenExp fvA env aenv b fvPreOpenFun fvA env aenv (Lam lhs f) = fvPreOpenFun fvA env' aenv f where - (env', _) = prettyELhs env lhs + (env', _) = prettyELhs True env lhs fvPreOpenExp :: forall acc env aenv exp. @@ -567,7 +567,7 @@ fvPreOpenExp fvA env aenv = fv -- fv (Let lhs e1 e2) = concat [ fv e1, fvPreOpenExp fvA env' aenv e2 ] where - (env', _) = prettyELhs env lhs + (env', _) = prettyELhs False env lhs fv Evar{} = [] fv Undef{} = [] fv Const{} = [] diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index df51931e0..b242d1027 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -114,7 +114,7 @@ prettyPreOpenAfun prettyAcc aenv0 = next (pretty '\\') aenv0 next :: Adoc -> Val aenv' -> PreOpenAfun acc aenv' f' -> Adoc next vs aenv (Abody body) = hang shiftwidth (sep [vs <> "->", prettyAcc context0 aenv body]) next vs aenv (Alam lhs lam) = - let (aenv', lhs') = prettyALhs aenv lhs + let (aenv', lhs') = prettyALhs True aenv lhs in next (vs <> lhs' <> space) aenv' lam prettyPreOpenAcc @@ -220,7 +220,7 @@ prettyAlet ctx prettyAcc extractAcc aenv0 collect aenv = \case Alet lhs a1 a2 -> - let (aenv', v) = prettyALhs aenv lhs + let (aenv', v) = prettyALhs False aenv lhs a1' = ppA aenv a1 bnd | isAlet a1 = nest shiftwidth (vsep [v <+> equals, a1']) | otherwise = v <+> align (equals <+> a1') @@ -270,11 +270,11 @@ prettyAtuple prettyAcc extractAcc aenv0 acc = case collect acc of collect _ = Nothing -- TODO: Should we also print the types of the declared variables? And the types of wildcards? -prettyALhs :: Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) -prettyALhs = prettyLhs False 'a' +prettyALhs :: Bool -> Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) +prettyALhs requiresParens = prettyLhs requiresParens 'a' -prettyELhs :: Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) -prettyELhs = prettyLhs False 'x' +prettyELhs :: Bool -> Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) +prettyELhs requiresParens = prettyLhs requiresParens 'x' prettyLhs :: forall s env env' arrs. Bool -> Char -> Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) prettyLhs requiresParens x env0 lhs = case collect lhs of @@ -329,7 +329,7 @@ prettyPreOpenFun prettyAcc extractAcc env0 aenv = next (pretty '\\') env0 = hang shiftwidth (sep [ vs <> "->" , prettyPreOpenExp context0 prettyAcc extractAcc env aenv body]) next vs env (Lam lhs lam) = - let (env', lhs') = prettyELhs env lhs + let (env', lhs') = prettyELhs True env lhs in next (vs <> lhs' <> space) env' lam prettyPreOpenExp @@ -354,7 +354,7 @@ prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = -- PrimConst c -> prettyPrimConst c Const tp c -> prettyConst (TupRsingle tp) c - Pair{} -> prettyTuple prettyAcc extractAcc env aenv exp + Pair{} -> prettyTuple ctx prettyAcc extractAcc env aenv exp Nil -> "()" VecPack _ e -> ppF1 "vecPack" (ppE e) VecUnpack _ e -> ppF1 "vecUnpack" (ppE e) @@ -436,7 +436,7 @@ prettyLet ctx prettyAcc extractAcc env0 aenv collect env = \case Let lhs e1 e2 -> - let (env', v) = prettyELhs env lhs + let (env', v) = prettyELhs False env lhs e1' = ppE env e1 bnd | isLet e1 = nest shiftwidth (vsep [v <+> equals, e1']) | otherwise = v <+> align (equals <+> e1') @@ -465,14 +465,15 @@ prettyLet ctx prettyAcc extractAcc env0 aenv prettyTuple :: forall acc env aenv t. - PrettyAcc acc + Context + -> PrettyAcc acc -> ExtractAcc acc -> Val env -> Val aenv -> PreOpenExp acc env aenv t -> Adoc -prettyTuple prettyAcc extractAcc env aenv exp = case collect exp of - Just tup -> align $ "T" <> pretty (length tup) <+> sep tup +prettyTuple ctx prettyAcc extractAcc env aenv exp = case collect exp of + Just tup -> align $ parensIf (ctxPrecedence ctx > 0) ("T" <> pretty (length tup) <+> sep tup) Nothing -> align $ ppPair exp where ppPair :: PreOpenExp acc env aenv t' -> Adoc From 54875b242f0d36dc5e612cc78ec2777b3e2cbc30 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 20 May 2020 13:42:01 +0200 Subject: [PATCH 207/316] Descend into Afuns in shrinking --- src/Data/Array/Accelerate/Trafo/Shrink.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index f9e25c9a0..ef3665079 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -520,10 +520,10 @@ usesOfPreAcc withShape countAcc idx = count Alet lhs bnd body -> countA bnd + countAcc withShape (weakenWithLHS lhs >:> idx) body Apair a1 a2 -> countA a1 + countA a2 Anil -> 0 - Apply _ _ a -> countA a --- XXX: It is suspicious that we don't descend into the function here. Same for awhile. + Apply _ f a -> countAF f idx + countA a Aforeign _ _ _ a -> countA a - Acond p t e -> countE p + countA t + countA e - Awhile _ _ a -> countA a + Acond p t e -> countE p + countA t + countA e + Awhile c f a -> countAF c idx + countAF f idx + countA a Use _ _ -> 0 Unit _ e -> countE e Reshape _ e a -> countE e + countA a @@ -579,11 +579,11 @@ usesOfPreAcc withShape countAcc idx = count 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 + countAF :: PreOpenAfun acc aenv' f + -> Idx aenv' s + -> Int + countAF (Alam lhs f) v = countAF f (weakenWithLHS lhs >:> v) + countAF (Abody a) v = countAcc withShape v a countF :: PreOpenFun acc env aenv f -> Int countF (Lam _ f) = countF f From ff80e4c11f2b43f94865dd933738f630d83d1317 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 May 2020 14:26:04 +0200 Subject: [PATCH 208/316] common build flags --- .github/workflows/ci.yml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2df126d7d..523dd6b0e 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -33,6 +33,8 @@ jobs: ghc: 8.4 - os: windows-latest ghc: 8.2 + env: + - flags: "--system-ghc --jobs 1 --flag accelerate:nofib" steps: - uses: actions/checkout@v2 @@ -53,10 +55,10 @@ jobs: - name: Build run: | ln -s stack-${{ matrix.ghc }}.yaml stack.yaml - stack build --test --no-run-tests --system-ghc --flag accelerate:nofib + stack build ${{ flags }} --test --no-run-tests - name: Test run: | - stack test accelerate:doctest --system-ghc --flag accelerate:nofib - stack test accelerate:nofib-interpreter --system-ghc --flag accelerate:nofib --test-arguments='--hedgehog-tests 25' + stack test accelerate:doctest ${{ flags }} + stack test accelerate:nofib-interpreter ${{ flags }} --test-arguments='--hedgehog-tests 25' From 3fbe79633305fd737ea3fa98572544187f0f430f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 May 2020 14:30:21 +0200 Subject: [PATCH 209/316] workflow syntax --- .github/workflows/ci.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 523dd6b0e..57e48d92e 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -34,7 +34,7 @@ jobs: - os: windows-latest ghc: 8.2 env: - - flags: "--system-ghc --jobs 1 --flag accelerate:nofib" + - FLAGS: "--system-ghc --jobs 1 --flag accelerate:nofib" steps: - uses: actions/checkout@v2 @@ -55,10 +55,10 @@ jobs: - name: Build run: | ln -s stack-${{ matrix.ghc }}.yaml stack.yaml - stack build ${{ flags }} --test --no-run-tests + stack build $FLAGS --test --no-run-tests - name: Test run: | - stack test accelerate:doctest ${{ flags }} - stack test accelerate:nofib-interpreter ${{ flags }} --test-arguments='--hedgehog-tests 25' + stack test accelerate:doctest $FLAGS + stack test accelerate:nofib-interpreter $FLAGS --test-arguments='--hedgehog-tests 25' From 7e11c8408daec054a6e2fea8b8f4d37204984e2a Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 May 2020 14:40:02 +0200 Subject: [PATCH 210/316] workflow env syntax --- .github/workflows/ci.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 57e48d92e..5686c7b53 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -33,8 +33,8 @@ jobs: ghc: 8.4 - os: windows-latest ghc: 8.2 - env: - - FLAGS: "--system-ghc --jobs 1 --flag accelerate:nofib" + env: + STACK_FLAGS: "--system-ghc --jobs 1 --flag accelerate:nofib" steps: - uses: actions/checkout@v2 @@ -55,10 +55,10 @@ jobs: - name: Build run: | ln -s stack-${{ matrix.ghc }}.yaml stack.yaml - stack build $FLAGS --test --no-run-tests + stack build $STACK_FLAGS --test --no-run-tests - name: Test run: | - stack test accelerate:doctest $FLAGS - stack test accelerate:nofib-interpreter $FLAGS --test-arguments='--hedgehog-tests 25' + stack test accelerate:doctest $STACK_FLAGS + stack test accelerate:nofib-interpreter $STACK_FLAGS --test-arguments='--hedgehog-tests 25' From 2061b69810f9691137eea2bdad143dab0f27a7c4 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Wed, 20 May 2020 14:40:43 +0200 Subject: [PATCH 211/316] Don't inline an Acc into an Awhile loop This may duplicate work --- src/Data/Array/Accelerate/Trafo/Shrink.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index ef3665079..0a5704c68 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -523,7 +523,11 @@ usesOfPreAcc withShape countAcc idx = count Apply _ f a -> countAF f idx + countA a Aforeign _ _ _ a -> countA a Acond p t e -> countE p + countA t + countA e - Awhile c f a -> countAF c idx + countAF f idx + countA a + -- Body and condition of the while loop may be evaluated multiple times. + -- We multiply the usage count, as a practical solution to this. As + -- we will check whether the count is at most 1, we will thus never + -- inline variables used in while loops. + Awhile c f a -> 2 * countAF c idx + 2 * countAF f idx + countA a Use _ _ -> 0 Unit _ e -> countE e Reshape _ e a -> countE e + countA a From 3b287e322b57dc74d9cf38e13268942c2808d754 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 May 2020 14:59:28 +0200 Subject: [PATCH 212/316] allow windows to fail --- .github/workflows/ci.yml | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 5686c7b53..ea9eed54e 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -11,30 +11,24 @@ jobs: stack: name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} runs-on: ${{ matrix.os }} + continue-on-error: ${{ matrix.allow_failure }} strategy: matrix: - os: [ubuntu-latest, macOS-latest, windows-latest] + os: [ubuntu-latest] stack: ["latest"] ghc: - "8.8" - "8.6" - "8.4" - "8.2" - exclude: + include: - os: macOS-latest - ghc: 8.6 - - os: macOS-latest - ghc: 8.4 - - os: macOS-latest - ghc: 8.2 - - os: windows-latest - ghc: 8.6 - - os: windows-latest - ghc: 8.4 + ghc: 8.8 - os: windows-latest - ghc: 8.2 + ghc: 8.8 + allow_failure: true env: - STACK_FLAGS: "--system-ghc --jobs 1 --flag accelerate:nofib" + STACK_FLAGS: "--system-ghc --flag accelerate:nofib" steps: - uses: actions/checkout@v2 From eca0251ce75e2e586fcd40a7b60cd8e7918fca2f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 May 2020 15:01:47 +0200 Subject: [PATCH 213/316] syntax? --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index ea9eed54e..4c96f8558 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -11,7 +11,7 @@ jobs: stack: name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} runs-on: ${{ matrix.os }} - continue-on-error: ${{ matrix.allow_failure }} + continue-on-error: ${{ matrix.experimental }} strategy: matrix: os: [ubuntu-latest] @@ -26,7 +26,7 @@ jobs: ghc: 8.8 - os: windows-latest ghc: 8.8 - allow_failure: true + experimental: true env: STACK_FLAGS: "--system-ghc --flag accelerate:nofib" From 9d89b08e9140b3419f97257d48c0c248e95b782c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 May 2020 15:11:12 +0200 Subject: [PATCH 214/316] syntax?? --- .github/workflows/ci.yml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 4c96f8558..b36d78acc 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -11,11 +11,12 @@ jobs: stack: name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} runs-on: ${{ matrix.os }} - continue-on-error: ${{ matrix.experimental }} + continue-on-error: ${{ matrix.allow_failure }} strategy: matrix: os: [ubuntu-latest] stack: ["latest"] + allow_failure: [false] ghc: - "8.8" - "8.6" @@ -26,7 +27,7 @@ jobs: ghc: 8.8 - os: windows-latest ghc: 8.8 - experimental: true + allow_failure: true env: STACK_FLAGS: "--system-ghc --flag accelerate:nofib" From 5ab6f52da38d95f0132e739cb8a9f8a8958f9ae6 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 May 2020 15:12:48 +0200 Subject: [PATCH 215/316] dis? --- .github/workflows/ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index b36d78acc..d58503b9b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -25,6 +25,7 @@ jobs: include: - os: macOS-latest ghc: 8.8 + allow_failure: false - os: windows-latest ghc: 8.8 allow_failure: true From 2bb5fcd97b1617cd73cc7f9c3eef9fb72895f9b5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 May 2020 16:02:55 +0200 Subject: [PATCH 216/316] =?UTF-8?q?don=E2=80=99t=20use=20system=20ghc?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/ci.yml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d58503b9b..5eb9f89da 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,7 +15,6 @@ jobs: strategy: matrix: os: [ubuntu-latest] - stack: ["latest"] allow_failure: [false] ghc: - "8.8" @@ -30,7 +29,7 @@ jobs: ghc: 8.8 allow_failure: true env: - STACK_FLAGS: "--system-ghc --flag accelerate:nofib" + STACK_FLAGS: "--flag accelerate:nofib" steps: - uses: actions/checkout@v2 @@ -39,8 +38,8 @@ jobs: name: Setup Haskell Stack with: enable-stack: true + stack-no-global: true ghc-version: ${{ matrix.ghc }} - stack-version: ${{ matrix.stack }} - uses: actions/cache@v1 name: Cache ~/.stack From 8776028500c1e3e6cf76baf6a535eac06dc964b2 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 20 May 2020 16:21:07 +0200 Subject: [PATCH 217/316] fine use system ghc then --- .github/workflows/ci.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 5eb9f89da..22dc33ae0 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -29,7 +29,7 @@ jobs: ghc: 8.8 allow_failure: true env: - STACK_FLAGS: "--flag accelerate:nofib" + STACK_FLAGS: "--system-ghc --no-install-ghc --flag accelerate:nofib" steps: - uses: actions/checkout@v2 @@ -38,7 +38,6 @@ jobs: name: Setup Haskell Stack with: enable-stack: true - stack-no-global: true ghc-version: ${{ matrix.ghc }} - uses: actions/cache@v1 From b82637fadea11005ec013cd0dcff81c0923e8a27 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 21 May 2020 00:37:34 +0200 Subject: [PATCH 218/316] fas --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 22dc33ae0..fef731591 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -29,7 +29,7 @@ jobs: ghc: 8.8 allow_failure: true env: - STACK_FLAGS: "--system-ghc --no-install-ghc --flag accelerate:nofib" + STACK_FLAGS: "--system-ghc --no-install-ghc --fast --flag accelerate:nofib" steps: - uses: actions/checkout@v2 From 39e0acbed6bbedc48b59d3c66aca218e201b60eb Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 21 May 2020 16:19:20 +0200 Subject: [PATCH 219/316] try to add os specific steps --- .github/workflows/ci.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index fef731591..d3bffb3be 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -46,6 +46,13 @@ jobs: path: ~/.stack key: ${{ runner.os }}-${{ matrix.ghc }}-stack + - name: Update PATH + run: echo "::add-path::$HOME/AppData/Roaming/local/bin" + if: ${{ matrix.os }} == 'windows-latest' + + - name: Echo PATH + run: echo $PATH + - name: Build run: | ln -s stack-${{ matrix.ghc }}.yaml stack.yaml From e43a9c8d6e0a317769b3272dbdb02399846e69c5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 21 May 2020 16:25:25 +0200 Subject: [PATCH 220/316] update os-specific syntax --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d3bffb3be..2326c34df 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -48,7 +48,7 @@ jobs: - name: Update PATH run: echo "::add-path::$HOME/AppData/Roaming/local/bin" - if: ${{ matrix.os }} == 'windows-latest' + if: runner.os == 'Windows' - name: Echo PATH run: echo $PATH From 8a9763007185b694a3f71c06053346c3915db947 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 22 May 2020 15:12:14 +0200 Subject: [PATCH 221/316] maybe ghc-8.6 works on windows? --- .github/workflows/ci.yml | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2326c34df..15411df2a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -26,7 +26,7 @@ jobs: ghc: 8.8 allow_failure: false - os: windows-latest - ghc: 8.8 + ghc: 8.6 allow_failure: true env: STACK_FLAGS: "--system-ghc --no-install-ghc --fast --flag accelerate:nofib" @@ -46,13 +46,6 @@ jobs: path: ~/.stack key: ${{ runner.os }}-${{ matrix.ghc }}-stack - - name: Update PATH - run: echo "::add-path::$HOME/AppData/Roaming/local/bin" - if: runner.os == 'Windows' - - - name: Echo PATH - run: echo $PATH - - name: Build run: | ln -s stack-${{ matrix.ghc }}.yaml stack.yaml From 9e2dadb9f98c432436bae8604223f8e692421033 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Mon, 25 May 2020 11:00:38 +0200 Subject: [PATCH 222/316] Replace acc type arg of Exp by ArrayVar --- src/Data/Array/Accelerate/AST.hs | 399 +++++++++--------- src/Data/Array/Accelerate/Analysis/Hash.hs | 136 +++--- src/Data/Array/Accelerate/Analysis/Match.hs | 272 ++++++------ src/Data/Array/Accelerate/Analysis/Shape.hs | 2 +- src/Data/Array/Accelerate/Interpreter.hs | 78 ++-- src/Data/Array/Accelerate/Pretty.hs | 22 +- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 110 ++--- src/Data/Array/Accelerate/Pretty/Print.hs | 101 ++--- src/Data/Array/Accelerate/Smart.hs | 4 +- src/Data/Array/Accelerate/Trafo.hs | 4 +- src/Data/Array/Accelerate/Trafo/Algebra.hs | 40 +- src/Data/Array/Accelerate/Trafo/Base.hs | 136 +++--- src/Data/Array/Accelerate/Trafo/Config.hs | 4 +- src/Data/Array/Accelerate/Trafo/Fusion.hs | 333 ++++++--------- src/Data/Array/Accelerate/Trafo/LetSplit.hs | 59 +-- src/Data/Array/Accelerate/Trafo/Sharing.hs | 34 +- src/Data/Array/Accelerate/Trafo/Shrink.hs | 45 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 88 ++-- .../Array/Accelerate/Trafo/Substitution.hs | 315 +++++++------- 19 files changed, 989 insertions(+), 1193 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 6e63336dd..425f94da8 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -92,7 +92,7 @@ module Data.Array.Accelerate.AST ( -- * Accelerated array expressions PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc, - PreBoundary(..), Boundary, StencilR(..), + Boundary(..), StencilR(..), HasArraysRepr(..), arrayRepr, lhsToTupR, PairIdx(..), ArrayR(..), ArraysR, ShapeR(..), SliceIndex(..), VecR(..), vecRvector, vecRtuple, @@ -101,19 +101,19 @@ module Data.Array.Accelerate.AST ( -- Producer(..), Consumer(..), -- * Scalar expressions - PreOpenFun(..), OpenFun, PreFun, Fun, PreOpenExp(..), OpenExp, PreExp, Exp, PrimConst(..), + OpenFun(..), Fun, OpenExp(..), Exp, PrimConst(..), PrimFun(..), expType, primConstType, primFunType, -- NFData NFDataAcc, - rnfPreOpenAfun, rnfPreOpenAcc, rnfPreOpenFun, rnfPreOpenExp, + rnfPreOpenAfun, rnfPreOpenAcc, rnfOpenFun, rnfOpenExp, rnfArrays, rnfArrayR, -- TemplateHaskell LiftAcc, liftIdx, liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, - liftPreOpenAfun, liftPreOpenAcc, liftPreOpenFun, liftPreOpenExp, + liftPreOpenAfun, liftPreOpenAcc, liftOpenFun, liftOpenExp, liftALhs, liftELhs, liftArray, liftArraysR, liftTupleType, liftArrayR, liftScalarType, liftShapeR, liftVecR, liftIntegralType, @@ -317,7 +317,7 @@ data Vars s env t where VarsNil :: Vars s aenv () VarsPair :: Vars s aenv a -> Vars s aenv b -> Vars s aenv (a, b) -evars :: ExpVars env tp -> PreOpenExp acc env aenv tp +evars :: ExpVars env tp -> OpenExp env aenv tp evars VarsNil = Nil evars (VarsSingle var) = Evar var evars (VarsPair v1 v2) = evars v1 `Pair` evars v2 @@ -346,7 +346,7 @@ varsType (VarsPair v1 v2) = varsType v1 `TupRpair` varsType v2 -- We use a non-recursive variant parametrised over the recursive closure, -- to facilitate attribute calculation in the backend. -- -data PreOpenAcc acc aenv a where +data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- Local non-recursive binding to represent sharing and demand -- explicitly. Note this is an eager binding! @@ -392,7 +392,7 @@ data PreOpenAcc acc aenv a where -- If-then-else for array-level computations -- - Acond :: PreExp acc aenv Bool + Acond :: Exp aenv Bool -> acc aenv arrs -> acc aenv arrs -> PreOpenAcc acc aenv arrs @@ -415,7 +415,7 @@ data PreOpenAcc acc aenv a where -- Capture a scalar (or a tuple of scalars) in a singleton array -- Unit :: TupleType e - -> PreExp acc aenv e + -> Exp aenv e -> PreOpenAcc acc aenv (Scalar e) -- Change the shape of an array without altering its contents. @@ -424,24 +424,24 @@ data PreOpenAcc acc aenv a where -- > dim == size dim' -- Reshape :: ShapeR sh - -> PreExp acc aenv sh -- new shape + -> Exp 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 :: ArrayR (Array sh e) - -> PreExp acc aenv sh -- output shape - -> PreFun acc aenv (sh -> e) -- representation function + -> Exp aenv sh -- output shape + -> Fun aenv (sh -> e) -- representation function -> PreOpenAcc acc aenv (Array sh e) -- Hybrid map/backpermute, where we separate the index and value -- transformations. -- Transform :: ArrayR (Array sh' b) - -> 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 + -> Exp aenv sh' -- dimension of the result + -> Fun aenv (sh' -> sh) -- index permutation function + -> Fun aenv (a -> b) -- function to apply at each element -> acc aenv (Array sh a) -- source array -> PreOpenAcc acc aenv (Array sh' b) @@ -452,7 +452,7 @@ data PreOpenAcc acc aenv a where sl co sh - -> PreExp acc aenv slix -- slice value specification + -> Exp aenv slix -- slice value specification -> acc aenv (Array sl e) -- data to be replicated -> PreOpenAcc acc aenv (Array sh e) @@ -464,13 +464,13 @@ data PreOpenAcc acc aenv a where co sh -> acc aenv (Array sh e) -- array to be indexed - -> PreExp acc aenv slix -- slice value specification + -> Exp aenv slix -- slice value specification -> PreOpenAcc acc aenv (Array sl e) -- Apply the given unary function to all elements of the given array -- Map :: TupleType e' - -> PreFun acc aenv (e -> e') + -> Fun aenv (e -> e') -> acc aenv (Array sh e) -> PreOpenAcc acc aenv (Array sh e') @@ -479,7 +479,7 @@ data PreOpenAcc acc aenv a where -- two argument arrays. -- ZipWith :: TupleType e3 - -> PreFun acc aenv (e1 -> e2 -> e3) + -> Fun aenv (e1 -> e2 -> e3) -> acc aenv (Array sh e1) -> acc aenv (Array sh e2) -> PreOpenAcc acc aenv (Array sh e3) @@ -487,14 +487,14 @@ data PreOpenAcc acc aenv a where -- Fold along the innermost dimension of an array with a given -- /associative/ function. -- - Fold :: PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- default value + Fold :: Fun aenv (e -> e -> e) -- combination function + -> Exp aenv e -- default value -> acc aenv (Array (sh, Int) e) -- folded array -> PreOpenAcc acc aenv (Array sh e) -- As 'Fold' without a default value -- - Fold1 :: PreFun acc aenv (e -> e -> e) -- combination function + Fold1 :: Fun aenv (e -> e -> e) -- combination function -> acc aenv (Array (sh, Int) e) -- folded array -> PreOpenAcc acc aenv (Array sh e) @@ -502,8 +502,8 @@ data PreOpenAcc acc aenv a where -- /associative/ function -- FoldSeg :: IntegralType i - -> PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- default value + -> Fun aenv (e -> e -> e) -- combination function + -> Exp 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) @@ -511,7 +511,7 @@ data PreOpenAcc acc aenv a where -- As 'FoldSeg' without a default value -- Fold1Seg :: IntegralType i - -> PreFun acc aenv (e -> e -> e) -- combination function + -> Fun 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) @@ -520,8 +520,8 @@ data PreOpenAcc acc aenv a where -- /associative/ function and an initial element (which does not need to -- be the neutral of the associative operations) -- - Scanl :: PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- initial value + Scanl :: Fun aenv (e -> e -> e) -- combination function + -> Exp aenv e -- initial value -> acc aenv (Array (sh, Int) e) -> PreOpenAcc acc aenv (Array (sh, Int) e) @@ -529,34 +529,34 @@ data PreOpenAcc acc aenv a where -- same length as the input array (the fold value would be the rightmost -- element in a Haskell-style scan) -- - Scanl' :: PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- initial value + Scanl' :: Fun aenv (e -> e -> e) -- combination function + -> Exp 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 :: PreFun acc aenv (e -> e -> e) -- combination function + Scanl1 :: Fun 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 :: PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- initial value + Scanr :: Fun aenv (e -> e -> e) -- combination function + -> Exp aenv e -- initial value -> acc aenv (Array (sh, Int) e) -> PreOpenAcc acc aenv (Array (sh, Int) e) -- Right-to-left version of 'Scanl\'' -- - Scanr' :: PreFun acc aenv (e -> e -> e) -- combination function - -> PreExp acc aenv e -- initial value + Scanr' :: Fun aenv (e -> e -> e) -- combination function + -> Exp 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 :: PreFun acc aenv (e -> e -> e) -- combination function + Scanr1 :: Fun aenv (e -> e -> e) -- combination function -> acc aenv (Array (sh, Int) e) -> PreOpenAcc acc aenv (Array (sh, Int) e) @@ -580,9 +580,9 @@ data PreOpenAcc acc aenv a where -- function is used to combine elements, which needs to be /associative/ -- and /commutative/. -- - Permute :: PreFun acc aenv (e -> e -> e) -- combination function + Permute :: Fun aenv (e -> e -> e) -- combination function -> acc aenv (Array sh' e) -- default values - -> PreFun acc aenv (sh -> sh') -- permutation function + -> Fun aenv (sh -> sh') -- permutation function -> acc aenv (Array sh e) -- source array -> PreOpenAcc acc aenv (Array sh' e) @@ -590,8 +590,8 @@ data PreOpenAcc acc aenv a where -- be between arrays of varying shape; the permutation function must be total -- Backpermute :: ShapeR sh' - -> PreExp acc aenv sh' -- dimensions of the result - -> PreFun acc aenv (sh' -> sh) -- permutation function + -> Exp aenv sh' -- dimensions of the result + -> Fun aenv (sh' -> sh) -- permutation function -> acc aenv (Array sh e) -- source array -> PreOpenAcc acc aenv (Array sh' e) @@ -600,8 +600,8 @@ data PreOpenAcc acc aenv a where -- Stencil :: StencilR sh e stencil -> TupleType e' - -> PreFun acc aenv (stencil -> e') -- stencil function - -> PreBoundary acc aenv (Array sh e) -- boundary condition + -> Fun aenv (stencil -> e') -- stencil function + -> Boundary aenv (Array sh e) -- boundary condition -> acc aenv (Array sh e) -- source array -> PreOpenAcc acc aenv (Array sh e') @@ -610,10 +610,10 @@ data PreOpenAcc acc aenv a where Stencil2 :: StencilR sh a stencil1 -> StencilR sh b stencil2 -> TupleType c - -> PreFun acc aenv (stencil1 -> stencil2 -> c) -- stencil function - -> PreBoundary acc aenv (Array sh a) -- boundary condition #1 + -> Fun aenv (stencil1 -> stencil2 -> c) -- stencil function + -> Boundary aenv (Array sh a) -- boundary condition #1 -> acc aenv (Array sh a) -- source array #1 - -> PreBoundary acc aenv (Array sh b) -- boundary condition #2 + -> Boundary aenv (Array sh b) -- boundary condition #2 -> acc aenv (Array sh b) -- source array #2 -> PreOpenAcc acc aenv (Array sh c) @@ -740,29 +740,25 @@ type Seq = PreOpenSeq OpenAcc () () --} --- | Vanilla stencil boundary condition +-- | Vanilla boundary condition specification for stencil operations -- -type Boundary = PreBoundary OpenAcc - --- | Boundary condition specification for stencil operations --- -data PreBoundary acc aenv t where +data Boundary aenv t where -- Clamp coordinates to the extent of the array - Clamp :: PreBoundary acc aenv t + Clamp :: Boundary aenv t -- Mirror coordinates beyond the array extent - Mirror :: PreBoundary acc aenv t + Mirror :: Boundary aenv t -- Wrap coordinates around on each dimension - Wrap :: PreBoundary acc aenv t + Wrap :: Boundary aenv t -- Use a constant value for outlying coordinates Constant :: e - -> PreBoundary acc aenv (Array sh e) + -> Boundary aenv (Array sh e) -- Apply the given function to outlying coordinates - Function :: PreFun acc aenv (sh -> e) - -> PreBoundary acc aenv (Array sh e) + Function :: Fun aenv (sh -> e) + -> Boundary aenv (Array sh e) data PairIdx p a where PairIdxLeft :: PairIdx (a, b) a @@ -826,161 +822,145 @@ instance HasArraysRepr OpenAcc where -- Embedded expressions -- -------------------- --- |Parametrised open function abstraction --- -data PreOpenFun acc env aenv t where - Body :: PreOpenExp acc env aenv t -> PreOpenFun acc env aenv t - Lam :: ELeftHandSide a env env' -> PreOpenFun acc env' 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 () +data OpenFun env aenv t where + Body :: OpenExp env aenv t -> OpenFun env aenv t + Lam :: ELeftHandSide a env env' -> OpenFun env' aenv t -> OpenFun env aenv (a -> t) -- |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 +-- |Vanilla 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 representation type (not the surface types). -- -data PreOpenExp acc env aenv t where +data OpenExp env aenv t where -- Local binding of a scalar expression Let :: ELeftHandSide bnd_t env env' - -> PreOpenExp acc env aenv bnd_t - -> PreOpenExp acc env' aenv body_t - -> PreOpenExp acc env aenv body_t + -> OpenExp env aenv bnd_t + -> OpenExp env' aenv body_t + -> OpenExp env aenv body_t -- Variable index, ranging only over tuples or scalars Evar :: ExpVar env t - -> PreOpenExp acc env aenv t + -> OpenExp env aenv t -- Apply a backend-specific foreign function Foreign :: Sugar.Foreign asm => TupleType 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 + -> asm (x -> y) -- foreign function + -> Fun () (x -> y) -- alternate implementation (for other backends) + -> OpenExp env aenv x + -> OpenExp env aenv y -- Tuples - Pair :: PreOpenExp acc env aenv t1 - -> PreOpenExp acc env aenv t2 - -> PreOpenExp acc env aenv (t1, t2) + Pair :: OpenExp env aenv t1 + -> OpenExp env aenv t2 + -> OpenExp env aenv (t1, t2) - Nil :: PreOpenExp acc env aenv () + Nil :: OpenExp env aenv () -- SIMD vectors VecPack :: KnownNat n => VecR n s tup - -> PreOpenExp acc env aenv tup - -> PreOpenExp acc env aenv (Vec n s) + -> OpenExp env aenv tup + -> OpenExp env aenv (Vec n s) VecUnpack :: KnownNat n => VecR n s tup - -> PreOpenExp acc env aenv (Vec n s) - -> PreOpenExp acc env aenv tup + -> OpenExp env aenv (Vec n s) + -> OpenExp env aenv tup -- Array indices & shapes IndexSlice :: SliceIndex slix sl co sh - -> PreOpenExp acc env aenv slix - -> PreOpenExp acc env aenv sh - -> PreOpenExp acc env aenv sl + -> OpenExp env aenv slix + -> OpenExp env aenv sh + -> OpenExp env aenv sl IndexFull :: SliceIndex slix sl co sh - -> PreOpenExp acc env aenv slix - -> PreOpenExp acc env aenv sl - -> PreOpenExp acc env aenv sh + -> OpenExp env aenv slix + -> OpenExp env aenv sl + -> OpenExp env aenv sh -- Shape and index conversion ToIndex :: ShapeR sh - -> PreOpenExp acc env aenv sh -- shape of the array - -> PreOpenExp acc env aenv sh -- index into the array - -> PreOpenExp acc env aenv Int + -> OpenExp env aenv sh -- shape of the array + -> OpenExp env aenv sh -- index into the array + -> OpenExp env aenv Int FromIndex :: ShapeR sh - -> PreOpenExp acc env aenv sh -- shape of the array - -> PreOpenExp acc env aenv Int -- index into linear representation - -> PreOpenExp acc env aenv sh + -> OpenExp env aenv sh -- shape of the array + -> OpenExp env aenv Int -- index into linear representation + -> OpenExp env aenv sh -- Conditional expression (non-strict in 2nd and 3rd argument) - Cond :: PreOpenExp acc env aenv Bool - -> PreOpenExp acc env aenv t - -> PreOpenExp acc env aenv t - -> PreOpenExp acc env aenv t + Cond :: OpenExp env aenv Bool + -> OpenExp env aenv t + -> OpenExp env aenv t + -> OpenExp env aenv t -- Value recursion - While :: 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 + While :: OpenFun env aenv (a -> Bool) -- continue while true + -> OpenFun env aenv (a -> a) -- function to iterate + -> OpenExp env aenv a -- initial value + -> OpenExp env aenv a -- Constant values Const :: ScalarType t -> t - -> PreOpenExp acc env aenv t + -> OpenExp env aenv t PrimConst :: PrimConst t - -> PreOpenExp acc env aenv t + -> OpenExp env aenv t -- Primitive scalar operations PrimApp :: PrimFun (a -> r) - -> PreOpenExp acc env aenv a - -> PreOpenExp acc env aenv r + -> OpenExp env aenv a + -> OpenExp env aenv r -- Project a single scalar from an array. -- The array expression can not contain any free scalar variables. - Index :: acc aenv (Array dim t) - -> PreOpenExp acc env aenv dim - -> PreOpenExp acc env aenv t + Index :: ArrayVar aenv (Array dim t) + -> OpenExp env aenv dim + -> OpenExp env aenv t - LinearIndex :: acc aenv (Array dim t) - -> PreOpenExp acc env aenv Int - -> PreOpenExp acc env aenv t + LinearIndex :: ArrayVar aenv (Array dim t) + -> OpenExp env aenv Int + -> OpenExp env aenv t -- Array shape. -- The array expression can not contain any free scalar variables. - Shape :: acc aenv (Array dim e) - -> PreOpenExp acc env aenv dim + Shape :: ArrayVar aenv (Array dim e) + -> OpenExp env aenv dim -- Number of elements of an array given its shape ShapeSize :: ShapeR dim - -> PreOpenExp acc env aenv dim - -> PreOpenExp acc env aenv Int + -> OpenExp env aenv dim + -> OpenExp env aenv Int -- Unsafe operations (may fail or result in undefined behaviour) -- An unspecified bit pattern Undef :: ScalarType t - -> PreOpenExp acc env aenv t + -> OpenExp env aenv t -- Reinterpret the bits of a value as a different type Coerce :: BitSizeEq a b => ScalarType a -> ScalarType b - -> PreOpenExp acc env aenv a - -> PreOpenExp acc env aenv b + -> OpenExp env aenv a + -> OpenExp env aenv b -expType :: HasArraysRepr acc => PreOpenExp acc aenv env t -> TupleType t +expType :: OpenExp aenv env t -> TupleType t expType expr = case expr of Let _ _ body -> expType body Evar (Var tp _) -> TupRsingle tp @@ -999,9 +979,9 @@ expType expr = case expr of Const tp _ -> TupRsingle tp PrimConst c -> TupRsingle $ SingleScalarType $ primConstType c PrimApp f _ -> snd $ primFunType f - Index a _ -> arrayRtype $ arrayRepr a - LinearIndex a _ -> arrayRtype $ arrayRepr a - Shape a -> shapeType $ arrayRshape $ arrayRepr a + Index (Var repr _) _ -> arrayRtype repr + LinearIndex (Var repr _) _ -> arrayRtype repr + Shape (Var repr _) -> shapeType $ arrayRshape repr ShapeSize _ _ -> TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType $ TypeInt Undef tp -> TupRsingle tp Coerce _ tp _ -> TupRsingle tp @@ -1272,10 +1252,10 @@ instance NFData (OpenAcc aenv t) where -- rnf = rnfPreOpenSeq rnfOpenAcc instance NFData (OpenExp env aenv t) where - rnf = rnfPreOpenExp rnfOpenAcc + rnf = rnfOpenExp instance NFData (OpenFun env aenv t) where - rnf = rnfPreOpenFun rnfOpenAcc + rnf = rnfOpenFun -- Array expressions @@ -1303,21 +1283,21 @@ rnfPreOpenAcc rnfA pacc = rnfAF :: PreOpenAfun acc aenv' t' -> () rnfAF = rnfPreOpenAfun rnfA - rnfE :: PreOpenExp acc env' aenv' t' -> () - rnfE = rnfPreOpenExp rnfA + rnfE :: OpenExp env' aenv' t' -> () + rnfE = rnfOpenExp - rnfF :: PreOpenFun acc env' aenv' t' -> () - rnfF = rnfPreOpenFun rnfA + rnfF :: OpenFun env' aenv' t' -> () + rnfF = rnfOpenFun -- rnfS :: PreOpenSeq acc aenv' senv' t' -> () -- rnfS = rnfPreOpenSeq rnfA - rnfB :: ArrayR (Array sh e) -> PreBoundary acc aenv' (Array sh e) -> () - rnfB = rnfBoundary rnfA + rnfB :: ArrayR (Array sh e) -> Boundary aenv' (Array sh e) -> () + rnfB = rnfBoundary in case pacc of Alet lhs bnd body -> rnfALhs lhs `seq` rnfA bnd `seq` rnfA body - Avar (Var repr ix) -> rnfArrayR repr `seq` rnfIdx ix + Avar var -> rnfArrayVar var Apair as bs -> rnfA as `seq` rnfA bs Anil -> () Apply repr afun acc -> rnfTupR rnfArrayR repr `seq` rnfAF afun `seq` rnfA acc @@ -1358,6 +1338,9 @@ rnfPreOpenAcc rnfA pacc = in rnfStencilR sr1 `seq` rnfStencilR sr2 `seq` rnfTupR rnfScalarType tp `seq` rnfF f `seq` rnfB repr1 b1 `seq` rnfB repr2 b2 `seq` rnfA a1 `seq` rnfA a2 -- Collect s -> rnfS s +rnfArrayVar :: ArrayVar aenv a -> () +rnfArrayVar (Var repr ix) = rnfArrayR repr `seq` rnfIdx ix + rnfLhs :: (forall b. s b -> ()) -> LeftHandSide s arrs env env' -> () rnfLhs rnfS (LeftHandSideWildcard r) = rnfTupR rnfS r rnfLhs rnfS (LeftHandSideSingle s) = rnfS s @@ -1402,12 +1385,12 @@ rnfStencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 `seq` rnfStencilR s6 `seq` rnfStencilR s7 `seq` rnfStencilR s8 `seq` rnfStencilR s9 -rnfBoundary :: forall acc aenv sh e. NFDataAcc acc -> ArrayR (Array sh e) -> PreBoundary acc aenv (Array sh e) -> () -rnfBoundary _ _ Clamp = () -rnfBoundary _ _ Mirror = () -rnfBoundary _ _ Wrap = () -rnfBoundary _ (ArrayR _ tp) (Constant c) = rnfConst tp c -rnfBoundary rnfA _ (Function f) = rnfPreOpenFun rnfA f +rnfBoundary :: forall aenv sh e. ArrayR (Array sh e) -> Boundary aenv (Array sh e) -> () +rnfBoundary _ Clamp = () +rnfBoundary _ Mirror = () +rnfBoundary _ Wrap = () +rnfBoundary (ArrayR _ tp) (Constant c) = rnfConst tp c +rnfBoundary _ (Function f) = rnfOpenFun f @@ -1442,11 +1425,11 @@ rnfSeqProducer rnfA topSeq = rnfAF :: PreOpenAfun acc aenv' t' -> () rnfAF = rnfPreOpenAfun rnfA - rnfF :: PreOpenFun acc env' aenv' t' -> () - rnfF = rnfPreOpenFun rnfA + rnfF :: OpenFun env' aenv' t' -> () + rnfF = rnfOpenFun rnfA - rnfE :: PreOpenExp acc env' aenv' t' -> () - rnfE = rnfPreOpenExp rnfA + rnfE :: OpenExp env' aenv' t' -> () + rnfE = rnfOpenExp rnfA in case topSeq of StreamIn as -> rnfArrs as @@ -1462,11 +1445,11 @@ rnfSeqConsumer rnfA topSeq = rnfAF :: PreOpenAfun acc aenv' t' -> () rnfAF = rnfPreOpenAfun rnfA - rnfF :: PreOpenFun acc env' aenv' t' -> () - rnfF = rnfPreOpenFun rnfA + rnfF :: OpenFun env' aenv' t' -> () + rnfF = rnfOpenFun rnfA - rnfE :: PreOpenExp acc env' aenv' t' -> () - rnfE = rnfPreOpenExp rnfA + rnfE :: OpenExp env' aenv' t' -> () + rnfE = rnfOpenExp rnfA in case topSeq of FoldSeq f z ix -> rnfF f `seq` rnfE z `seq` rnfIdx ix @@ -1481,18 +1464,18 @@ 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 lhs f) = rnfELhs lhs `seq` rnfPreOpenFun rnfA f +rnfOpenFun :: OpenFun env aenv t -> () +rnfOpenFun (Body b) = rnfOpenExp b +rnfOpenFun (Lam lhs f) = rnfELhs lhs `seq` rnfOpenFun f -rnfPreOpenExp :: forall acc env aenv t. NFDataAcc acc -> PreOpenExp acc env aenv t -> () -rnfPreOpenExp rnfA topExp = +rnfOpenExp :: forall env aenv t. OpenExp env aenv t -> () +rnfOpenExp topExp = let - rnfF :: PreOpenFun acc env' aenv' t' -> () - rnfF = rnfPreOpenFun rnfA + rnfF :: OpenFun env' aenv' t' -> () + rnfF = rnfOpenFun - rnfE :: PreOpenExp acc env' aenv' t' -> () - rnfE = rnfPreOpenExp rnfA + rnfE :: OpenExp env' aenv' t' -> () + rnfE = rnfOpenExp in case topExp of Let lhs bnd body -> rnfELhs lhs `seq` rnfE bnd `seq` rnfE body @@ -1512,9 +1495,9 @@ rnfPreOpenExp rnfA topExp = 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 + Index a ix -> rnfArrayVar a `seq` rnfE ix + LinearIndex a ix -> rnfArrayVar a `seq` rnfE ix + Shape a -> rnfArrayVar a ShapeSize shr sh -> rnfShapeR shr `seq` rnfE sh Coerce t1 t2 e -> rnfScalarType t1 `seq` rnfScalarType t2 `seq` rnfE e @@ -1669,22 +1652,22 @@ liftPreOpenAcc -> 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 + liftE :: OpenExp env aenv t -> Q (TExp (OpenExp env aenv t)) + liftE = liftOpenExp - liftF :: PreOpenFun acc env aenv t -> Q (TExp (PreOpenFun acc env aenv t)) - liftF = liftPreOpenFun liftA + liftF :: OpenFun env aenv t -> Q (TExp (OpenFun env aenv t)) + liftF = liftOpenFun liftAF :: PreOpenAfun acc aenv f -> Q (TExp (PreOpenAfun acc aenv f)) liftAF = liftPreOpenAfun liftA - liftB :: ArrayR (Array sh e) -> PreBoundary acc aenv (Array sh e) -> Q (TExp (PreBoundary acc aenv (Array sh e))) - liftB = liftBoundary liftA + liftB :: ArrayR (Array sh e) -> Boundary aenv (Array sh e) -> Q (TExp (Boundary aenv (Array sh e))) + liftB = liftBoundary in case pacc of Alet lhs bnd body -> [|| Alet $$(liftALhs lhs) $$(liftA bnd) $$(liftA body) ||] - Avar (Var tp ix) -> [|| Avar (Var $$(liftArrayR tp) $$(liftIdx ix)) ||] + Avar var -> [|| Avar $$(liftArrayVar var) ||] Apair as bs -> [|| Apair $$(liftA as) $$(liftA bs) ||] Anil -> [|| Anil ||] Apply repr f a -> [|| Apply $$(liftArraysR repr) $$(liftAF f) $$(liftA a) ||] @@ -1762,30 +1745,28 @@ liftStencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) = [|| StencilRtup9 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) $$(liftStencilR s6) $$(liftStencilR s7) $$(liftStencilR s8) $$(liftStencilR s9) ||] -liftPreOpenFun - :: LiftAcc acc - -> PreOpenFun acc env aenv t - -> Q (TExp (PreOpenFun acc env aenv t)) -liftPreOpenFun liftA (Lam lhs f) = [|| Lam $$(liftELhs lhs) $$(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 = +liftOpenFun + :: OpenFun env aenv t + -> Q (TExp (OpenFun env aenv t)) +liftOpenFun (Lam lhs f) = [|| Lam $$(liftELhs lhs) $$(liftOpenFun f) ||] +liftOpenFun (Body b) = [|| Body $$(liftOpenExp b) ||] + +liftOpenExp + :: forall env aenv t. + OpenExp env aenv t + -> Q (TExp (OpenExp env aenv t)) +liftOpenExp pexp = let - liftE :: PreOpenExp acc env aenv e -> Q (TExp (PreOpenExp acc env aenv e)) - liftE = liftPreOpenExp liftA + liftE :: OpenExp env aenv e -> Q (TExp (OpenExp env aenv e)) + liftE = liftOpenExp - liftF :: PreOpenFun acc env aenv f -> Q (TExp (PreOpenFun acc env aenv f)) - liftF = liftPreOpenFun liftA + liftF :: OpenFun env aenv f -> Q (TExp (OpenFun env aenv f)) + liftF = liftOpenFun in case pexp of - Let lhs bnd body -> [|| Let $$(liftELhs lhs) $$(liftPreOpenExp liftA bnd) $$(liftPreOpenExp liftA body) ||] + Let lhs bnd body -> [|| Let $$(liftELhs lhs) $$(liftOpenExp bnd) $$(liftOpenExp body) ||] Evar var -> [|| Evar $$(liftExpVar var) ||] - Foreign repr asm f x -> [|| Foreign $$(liftTupleType repr) $$(Sugar.liftForeign asm) $$(liftPreOpenFun liftA f) $$(liftE x) ||] + Foreign repr asm f x -> [|| Foreign $$(liftTupleType repr) $$(Sugar.liftForeign asm) $$(liftOpenFun f) $$(liftE x) ||] Const tp c -> [|| Const $$(liftScalarType tp) $$(liftConst (TupRsingle tp) c) ||] Undef tp -> [|| Undef $$(liftScalarType tp) ||] Pair a b -> [|| Pair $$(liftE a) $$(liftE b) ||] @@ -1800,15 +1781,18 @@ liftPreOpenExp liftA pexp = 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) ||] + Index a ix -> [|| Index $$(liftArrayVar a) $$(liftE ix) ||] + LinearIndex a ix -> [|| LinearIndex $$(liftArrayVar a) $$(liftE ix) ||] + Shape a -> [|| Shape $$(liftArrayVar a) ||] ShapeSize shr ix -> [|| ShapeSize $$(liftShapeR shr) $$(liftE ix) ||] Coerce t1 t2 e -> [|| Coerce $$(liftScalarType t1) $$(liftScalarType t2) $$(liftE e) ||] liftExpVar :: ExpVar env t -> Q (TExp (ExpVar env t)) liftExpVar (Var tp ix) = [|| Var $$(liftScalarType tp) $$(liftIdx ix) ||] +liftArrayVar :: ArrayVar aenv a -> Q (TExp (ArrayVar aenv a)) +liftArrayVar (Var repr ix) = [|| Var $$(liftArrayR repr) $$(liftIdx ix) ||] + liftArray :: forall sh e. ArrayR (Array sh e) -> Array sh e -> Q (TExp (Array sh e)) liftArray (ArrayR shr tp) (Array sh adata) = [|| Array $$(liftConst (shapeType shr) sh) $$(go tp adata) ||] `sigE` [t| Array $(typeToQType $ shapeType shr) $(typeToQType tp) |] @@ -1912,16 +1896,15 @@ liftArray (ArrayR shr tp) (Array sh adata) = goVector (NonNumSingleType TypeBool) = arr liftBoundary - :: forall acc aenv sh e. - LiftAcc acc - -> ArrayR (Array sh e) - -> PreBoundary acc aenv (Array sh e) - -> Q (TExp (PreBoundary acc aenv (Array sh e))) -liftBoundary _ _ Clamp = [|| Clamp ||] -liftBoundary _ _ Mirror = [|| Mirror ||] -liftBoundary _ _ Wrap = [|| Wrap ||] -liftBoundary _ (ArrayR _ tp) (Constant v) = [|| Constant $$(liftConst tp v) ||] -liftBoundary liftA _ (Function f) = [|| Function $$(liftPreOpenFun liftA f) ||] + :: forall aenv sh e. + ArrayR (Array sh e) + -> Boundary aenv (Array sh e) + -> Q (TExp (Boundary aenv (Array sh e))) +liftBoundary _ Clamp = [|| Clamp ||] +liftBoundary _ Mirror = [|| Mirror ||] +liftBoundary _ Wrap = [|| Wrap ||] +liftBoundary (ArrayR _ tp) (Constant v) = [|| Constant $$(liftConst tp v) ||] +liftBoundary _ (Function f) = [|| Function $$(liftOpenFun f) ||] liftSliceIndex :: SliceIndex ix slice coSlice sliceDim -> Q (TExp (SliceIndex ix slice coSlice sliceDim)) liftSliceIndex SliceNil = [|| SliceNil ||] @@ -2172,7 +2155,7 @@ showShortendArr repr@(ArrayR _ tp) arr elements = intercalate ", " $ map (showElement tp) $ take cutoff l -showPreExpOp :: forall acc aenv env t. PreOpenExp acc aenv env t -> String +showPreExpOp :: forall aenv env t. OpenExp aenv env t -> String showPreExpOp Let{} = "Let" showPreExpOp (Evar (Var _ ix)) = "Var x" ++ show (idxToInt ix) showPreExpOp (Const tp c) = "Const " ++ showElement (TupRsingle tp) c diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 862cbee09..f1eb6b5e1 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -23,14 +23,13 @@ module Data.Array.Accelerate.Analysis.Hash ( Hash, HashOptions(..), defaultHashOptions, hashPreOpenAcc, hashPreOpenAccWith, - hashPreOpenFun, hashPreOpenFunWith, - hashPreOpenExp, hashPreOpenExpWith, + hashOpenFun, hashOpenExp, -- auxiliary EncodeAcc, encodePreOpenAcc, - encodePreOpenExp, - encodePreOpenFun, + encodeOpenExp, + encodeOpenFun, encodeArraysType, hashQ, @@ -95,14 +94,6 @@ defaultHashOptions = HashOptions True hashPreOpenAcc :: HasArraysRepr acc => EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash hashPreOpenAcc = hashPreOpenAccWith defaultHashOptions -{-# INLINEABLE hashPreOpenFun #-} -hashPreOpenFun :: HasArraysRepr acc => EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash -hashPreOpenFun = hashPreOpenFunWith defaultHashOptions - -{-# INLINEABLE hashPreOpenExp #-} -hashPreOpenExp :: HasArraysRepr acc => EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash -hashPreOpenExp = hashPreOpenExpWith defaultHashOptions - {-# INLINEABLE hashPreOpenAccWith #-} hashPreOpenAccWith :: HasArraysRepr acc => HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash hashPreOpenAccWith options encodeAcc @@ -110,19 +101,19 @@ hashPreOpenAccWith options encodeAcc . toLazyByteString . encodePreOpenAcc options encodeAcc -{-# INLINEABLE hashPreOpenFunWith #-} -hashPreOpenFunWith :: HasArraysRepr acc => HashOptions -> EncodeAcc acc -> PreOpenFun acc env aenv f -> Hash -hashPreOpenFunWith options encodeAcc +{-# INLINEABLE hashOpenFun #-} +hashOpenFun :: OpenFun env aenv f -> Hash +hashOpenFun = hashlazy . toLazyByteString - . encodePreOpenFun options encodeAcc + . encodeOpenFun -{-# INLINEABLE hashPreOpenExpWith #-} -hashPreOpenExpWith :: HasArraysRepr acc => HashOptions -> EncodeAcc acc -> PreOpenExp acc env aenv t -> Hash -hashPreOpenExpWith options encodeAcc +{-# INLINEABLE hashOpenExp #-} +hashOpenExp :: OpenExp env aenv t -> Hash +hashOpenExp = hashlazy . toLazyByteString - . encodePreOpenExp options encodeAcc + . encodeOpenExp -- Array computations @@ -145,20 +136,17 @@ encodePreOpenAcc options encodeAcc pacc = travAF :: PreOpenAfun acc aenv' f -> Builder travAF = encodePreOpenAfun options encodeAcc - travE :: PreOpenExp acc env' aenv' e -> Builder - travE = encodePreOpenExp options encodeAcc + travE :: OpenExp env' aenv' e -> Builder + travE = encodeOpenExp - travF :: PreOpenFun acc env' aenv' f -> Builder - travF = encodePreOpenFun options encodeAcc - - travB :: TupleType e -> PreBoundary acc aenv' (Array sh e) -> Builder - travB = encodePreBoundary options encodeAcc + travF :: OpenFun env' aenv' f -> Builder + travF = encodeOpenFun deep :: Builder -> Builder deep | perfect options = id | otherwise = const mempty - deepE :: forall env' aenv' e. PreOpenExp acc env' aenv' e -> Builder + deepE :: forall env' aenv' e. OpenExp env' aenv' e -> Builder deepE e | perfect options = travE e | otherwise = encodeTupleType $ expType e @@ -195,8 +183,8 @@ encodePreOpenAcc options encodeAcc pacc = Scanr' f e a -> intHost $(hashQ "Scanr'") <> travF f <> travE e <> travA a Scanr1 f a -> intHost $(hashQ "Scanr1") <> travF f <> travA a Permute f1 a1 f2 a2 -> intHost $(hashQ "Permute") <> travF f1 <> travA a1 <> travF f2 <> travA a2 - Stencil s _ f b a -> intHost $(hashQ "Stencil") <> travF f <> travB (stencilElt s) b <> travA a - Stencil2 s1 s2 _ f b1 a1 b2 a2 -> intHost $(hashQ "Stencil2") <> travF f <> travB (stencilElt s1) b1 <> travA a1 <> travB (stencilElt s2) b2 <> travA a2 + Stencil s _ f b a -> intHost $(hashQ "Stencil") <> travF f <> encodeBoundary (stencilElt s) b <> travA a + Stencil2 s1 s2 _ f b1 a1 b2 a2 -> intHost $(hashQ "Stencil2") <> travF f <> encodeBoundary (stencilElt s1) b1 <> travA a1 <> encodeBoundary (stencilElt s2) b2 <> travA a2 {-- {-# INLINEABLE encodePreOpenSeq #-} @@ -206,14 +194,14 @@ encodePreOpenSeq encodeAcc s = travA :: acc aenv' a -> Builder travA = encodeAcc -- XXX: plus type information? - travE :: PreOpenExp acc env' aenv' e -> Builder - travE = encodePreOpenExp encodeAcc + travE :: OpenExp env' aenv' e -> Builder + travE = encodeOpenExp encodeAcc travAF :: PreOpenAfun acc aenv' f -> Builder travAF = encodePreOpenAfun encodeAcc - travF :: PreOpenFun acc env' aenv' f -> Builder - travF = encodePreOpenFun encodeAcc + travF :: OpenFun env' aenv' f -> Builder + travF = encodeOpenFun encodeAcc travS :: PreOpenSeq acc aenv senv' arrs' -> Builder travS = encodePreOpenSeq encodeAcc @@ -285,18 +273,15 @@ encodePreOpenAfun options travA afun = Alam lhs l -> intHost $(hashQ "Alam") <> travL lhs l -encodePreBoundary - :: forall acc aenv sh e. - HashOptions - -> EncodeAcc acc - -> TupleType e - -> PreBoundary acc aenv (Array sh e) +encodeBoundary + :: TupleType e + -> Boundary aenv (Array sh e) -> Builder -encodePreBoundary _ _ _ Wrap = intHost $(hashQ "Wrap") -encodePreBoundary _ _ _ Clamp = intHost $(hashQ "Clamp") -encodePreBoundary _ _ _ Mirror = intHost $(hashQ "Mirror") -encodePreBoundary _ _ tp (Constant c) = intHost $(hashQ "Constant") <> encodeConst tp c -encodePreBoundary o h _ (Function f) = intHost $(hashQ "Function") <> encodePreOpenFun o h f +encodeBoundary _ Wrap = intHost $(hashQ "Wrap") +encodeBoundary _ Clamp = intHost $(hashQ "Clamp") +encodeBoundary _ Mirror = intHost $(hashQ "Mirror") +encodeBoundary tp (Constant c) = intHost $(hashQ "Constant") <> encodeConst tp c +encodeBoundary _ (Function f) = intHost $(hashQ "Function") <> encodeOpenFun f encodeSliceIndex :: SliceIndex slix sl co sh -> Builder encodeSliceIndex SliceNil = intHost $(hashQ "SliceNil") @@ -307,31 +292,18 @@ encodeSliceIndex (SliceFixed r) = intHost $(hashQ "sliceFixed") <> encodeSlice -- Scalar expressions -- ------------------ -{-# INLINEABLE encodePreOpenExp #-} -encodePreOpenExp - :: forall acc env aenv exp. - HashOptions - -> EncodeAcc acc - -> PreOpenExp acc env aenv exp +{-# INLINEABLE encodeOpenExp #-} +encodeOpenExp + :: forall env aenv exp. + OpenExp env aenv exp -> Builder -encodePreOpenExp options encodeAcc exp = +encodeOpenExp exp = let - -- XXX: Temporary fix for hashing expressions which only depend on - -- free array variables. For the code generating backends it will - -- never pick up expressions which differ only at free array - -- variables. We know that this will always be an Avar (we depend on - -- array expressions being floated out already) so we should change - -- this in the AST. This problem occurred in the Quickhull program. - -- -- TLM 2020-01-08 - -- - travA :: forall aenv' a. acc aenv' a -> Builder - travA a = encodeAcc (options {perfect=True}) a - - travE :: forall env' aenv' e. PreOpenExp acc env' aenv' e -> Builder - travE e = encodePreOpenExp options encodeAcc e + travE :: forall env' aenv' e. OpenExp env' aenv' e -> Builder + travE e = encodeOpenExp e - travF :: PreOpenFun acc env' aenv' f -> Builder - travF = encodePreOpenFun options encodeAcc + travF :: OpenFun env' aenv' f -> Builder + travF = encodeOpenFun in case exp of Let lhs bnd body -> intHost $(hashQ "Let") <> encodeLeftHandSide encodeScalarType lhs <> travE bnd <> travE body @@ -350,32 +322,22 @@ encodePreOpenExp options encodeAcc exp = 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 + Index a ix -> intHost $(hashQ "Index") <> encodeArrayVar a <> travE ix + LinearIndex a ix -> intHost $(hashQ "LinearIndex") <> encodeArrayVar a <> travE ix + Shape a -> intHost $(hashQ "Shape") <> encodeArrayVar a ShapeSize _ sh -> intHost $(hashQ "ShapeSize") <> travE sh Foreign _ _ f e -> intHost $(hashQ "Foreign") <> travF f <> travE e Coerce _ tp e -> intHost $(hashQ "Coerce") <> encodeScalarType tp <> travE e +encodeArrayVar :: ArrayVar aenv a -> Builder +encodeArrayVar (Var repr v) = encodeArrayType repr <> encodeIdx v -{-# INLINEABLE encodePreOpenFun #-} -encodePreOpenFun - :: forall acc env aenv f. - HashOptions - -> EncodeAcc acc - -> PreOpenFun acc env aenv f +{-# INLINEABLE encodeOpenFun #-} +encodeOpenFun + :: OpenFun env aenv f -> Builder -encodePreOpenFun options travA fun = - let - travB :: forall env' aenv' e. PreOpenExp acc env' aenv' e -> Builder - travB b = encodePreOpenExp options travA b - - travL :: forall env' aenv' b. PreOpenFun acc env' aenv' b -> Builder - travL l = encodePreOpenFun options travA l - in - case fun of - Body b -> intHost $(hashQ "Body") <> travB b - Lam lhs l -> intHost $(hashQ "Lam") <> encodeLeftHandSide encodeScalarType lhs <> travL l +encodeOpenFun (Body b) = intHost $(hashQ "Body") <> encodeOpenExp b +encodeOpenFun (Lam lhs l) = intHost $(hashQ "Lam") <> encodeLeftHandSide encodeScalarType lhs <> encodeOpenFun l encodeConst :: TupleType t -> t -> Builder diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index 4e280bc57..c64b86e21 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -24,8 +24,8 @@ module Data.Array.Accelerate.Analysis.Match ( (:~:)(..), matchPreOpenAcc, matchPreOpenAfun, - matchPreOpenExp, - matchPreOpenFun, + matchOpenExp, + matchOpenFun, matchPrimFun, matchPrimFun', -- auxiliary @@ -69,11 +69,11 @@ matchPreOpenAcc -> 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 + matchFun :: OpenFun env' aenv' u -> OpenFun env' aenv' v -> Maybe (u :~: v) + matchFun = matchOpenFun - matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :~: v) - matchExp = matchPreOpenExp matchAcc encodeAcc + matchExp :: OpenExp env' aenv' u -> OpenExp env' aenv' v -> Maybe (u :~: v) + matchExp = matchOpenExp match :: PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t -> Maybe (s :~: t) match (Alet lhs1 x1 a1) (Alet lhs2 x2 a2) @@ -242,15 +242,15 @@ matchPreOpenAcc matchAcc encodeAcc = match match (Stencil s1 _ f1 b1 a1) (Stencil _ _ f2 b2 a2) | Just Refl <- matchFun f1 f2 , Just Refl <- matchAcc a1 a2 - , matchBoundary matchAcc encodeAcc (stencilElt s1) b1 b2 + , matchBoundary (stencilElt s1) b1 b2 = Just Refl match (Stencil2 s1 s2 _ 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 (stencilElt s1) b1 b1' - , matchBoundary matchAcc encodeAcc (stencilElt s2) b2 b2' + , matchBoundary (stencilElt s1) b1 b1' + , matchBoundary (stencilElt s2) b2 b2' = Just Refl -- match (Collect s1) (Collect s2) @@ -297,21 +297,18 @@ matchLeftHandSide _ _ _ = Nothing -- Match stencil boundaries -- matchBoundary - :: HasArraysRepr acc - => MatchAcc acc - -> EncodeAcc acc - -> TupleType t - -> PreBoundary acc aenv (Array sh t) - -> PreBoundary acc aenv (Array sh t) + :: TupleType t + -> Boundary aenv (Array sh t) + -> Boundary aenv (Array sh t) -> Bool -matchBoundary _ _ _ Clamp Clamp = True -matchBoundary _ _ _ Mirror Mirror = True -matchBoundary _ _ _ Wrap Wrap = True -matchBoundary _ _ tp (Constant s) (Constant t) = matchConst tp s t -matchBoundary m h _ (Function f) (Function g) - | Just Refl <- matchPreOpenFun m h f g +matchBoundary _ Clamp Clamp = True +matchBoundary _ Mirror Mirror = True +matchBoundary _ Wrap Wrap = True +matchBoundary tp (Constant s) (Constant t) = matchConst tp s t +matchBoundary _ (Function f) (Function g) + | Just Refl <- matchOpenFun f g = True -matchBoundary _ _ _ _ _ +matchBoundary _ _ _ = False @@ -327,11 +324,11 @@ matchSeq -> 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 + matchFun :: OpenFun env' aenv' u -> OpenFun env' aenv' v -> Maybe (u :~: v) + matchFun = matchOpenFun m h - matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :~: v) - matchExp = matchPreOpenExp m h + matchExp :: OpenExp env' aenv' u -> OpenExp env' aenv' v -> Maybe (u :~: v) + matchExp = matchOpenExp m h match :: PreOpenSeq acc aenv senv' u -> PreOpenSeq acc aenv senv' v -> Maybe (u :~: v) match (Producer p1 s1) (Producer p2 s2) @@ -442,145 +439,135 @@ matchArrayR _ _ = Nothing -- 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. HasArraysRepr acc - => MatchAcc acc - -> EncodeAcc acc - -> PreOpenExp acc env aenv s - -> PreOpenExp acc env aenv t +{-# INLINEABLE matchOpenExp #-} +matchOpenExp + :: forall env aenv s t. + OpenExp env aenv s + -> OpenExp 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 lhs1 x1 e1) (Let lhs2 x2 e2) - | Just Refl <- matchELeftHandSide lhs1 lhs2 - , Just Refl <- match x1 x2 - , Just Refl <- match e1 e2 - = Just Refl - match (Evar v1) (Evar v2) - = matchVar v1 v2 +matchOpenExp (Let lhs1 x1 e1) (Let lhs2 x2 e2) + | Just Refl <- matchELeftHandSide lhs1 lhs2 + , Just Refl <- matchOpenExp x1 x2 + , Just Refl <- matchOpenExp e1 e2 + = Just Refl - match (Foreign _ ff1 f1 e1) (Foreign _ ff2 f2 e2) - | Just Refl <- match e1 e2 - , unsafePerformIO $ do - sn1 <- makeStableName ff1 - sn2 <- makeStableName ff2 - return $! hashStableName sn1 == hashStableName sn2 - , Just Refl <- matchPreOpenFun matchAcc encodeAcc f1 f2 - = Just Refl +matchOpenExp (Evar v1) (Evar v2) + = matchVar v1 v2 - match (Const t1 c1) (Const t2 c2) - | Just Refl <- matchScalarType t1 t2 - , matchConst (TupRsingle t1) c1 c2 - = Just Refl +matchOpenExp (Foreign _ ff1 f1 e1) (Foreign _ ff2 f2 e2) + | Just Refl <- matchOpenExp e1 e2 + , unsafePerformIO $ do + sn1 <- makeStableName ff1 + sn2 <- makeStableName ff2 + return $! hashStableName sn1 == hashStableName sn2 + , Just Refl <- matchOpenFun f1 f2 + = Just Refl - match (Undef t1) (Undef t2) = matchScalarType t1 t2 +matchOpenExp (Const t1 c1) (Const t2 c2) + | Just Refl <- matchScalarType t1 t2 + , matchConst (TupRsingle t1) c1 c2 + = Just Refl - match (Coerce _ t1 e1) (Coerce _ t2 e2) - | Just Refl <- matchScalarType t1 t2 - , Just Refl <- match e1 e2 - = Just Refl +matchOpenExp (Undef t1) (Undef t2) = matchScalarType t1 t2 - match (Pair a1 b1) (Pair a2 b2) - | Just Refl <- match a1 a2 - , Just Refl <- match b1 b2 - = Just Refl +matchOpenExp (Coerce _ t1 e1) (Coerce _ t2 e2) + | Just Refl <- matchScalarType t1 t2 + , Just Refl <- matchOpenExp e1 e2 + = Just Refl - match Nil Nil - = Just Refl +matchOpenExp (Pair a1 b1) (Pair a2 b2) + | Just Refl <- matchOpenExp a1 a2 + , Just Refl <- matchOpenExp b1 b2 + = Just Refl - match (IndexSlice sliceIndex1 ix1 sh1) (IndexSlice sliceIndex2 ix2 sh2) - | Just Refl <- match ix1 ix2 - , Just Refl <- match sh1 sh2 - , Just Refl <- matchSliceIndex sliceIndex1 sliceIndex2 - = Just Refl +matchOpenExp Nil Nil + = Just Refl - match (IndexFull sliceIndex1 ix1 sl1) (IndexFull sliceIndex2 ix2 sl2) - | Just Refl <- match ix1 ix2 - , Just Refl <- match sl1 sl2 - , Just Refl <- matchSliceIndex sliceIndex1 sliceIndex2 - = Just Refl +matchOpenExp (IndexSlice sliceIndex1 ix1 sh1) (IndexSlice sliceIndex2 ix2 sh2) + | Just Refl <- matchOpenExp ix1 ix2 + , Just Refl <- matchOpenExp sh1 sh2 + , Just Refl <- matchSliceIndex sliceIndex1 sliceIndex2 + = Just Refl - match (ToIndex _ sh1 i1) (ToIndex _ sh2 i2) - | Just Refl <- match sh1 sh2 - , Just Refl <- match i1 i2 - = Just Refl +matchOpenExp (IndexFull sliceIndex1 ix1 sl1) (IndexFull sliceIndex2 ix2 sl2) + | Just Refl <- matchOpenExp ix1 ix2 + , Just Refl <- matchOpenExp sl1 sl2 + , Just Refl <- matchSliceIndex sliceIndex1 sliceIndex2 + = Just Refl - match (FromIndex _ sh1 i1) (FromIndex _ sh2 i2) - | Just Refl <- match i1 i2 - , Just Refl <- match sh1 sh2 - = Just Refl +matchOpenExp (ToIndex _ sh1 i1) (ToIndex _ sh2 i2) + | Just Refl <- matchOpenExp sh1 sh2 + , Just Refl <- matchOpenExp i1 i2 + = 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 +matchOpenExp (FromIndex _ sh1 i1) (FromIndex _ sh2 i2) + | Just Refl <- matchOpenExp i1 i2 + , Just Refl <- matchOpenExp sh1 sh2 + = 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 +matchOpenExp (Cond p1 t1 e1) (Cond p2 t2 e2) + | Just Refl <- matchOpenExp p1 p2 + , Just Refl <- matchOpenExp t1 t2 + , Just Refl <- matchOpenExp e1 e2 + = Just Refl - match (PrimConst c1) (PrimConst c2) - = matchPrimConst c1 c2 +matchOpenExp (While p1 f1 x1) (While p2 f2 x2) + | Just Refl <- matchOpenExp x1 x2 + , Just Refl <- matchOpenFun p1 p2 + , Just Refl <- matchOpenFun f1 f2 + = Just Refl - 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 +matchOpenExp (PrimConst c1) (PrimConst c2) + = matchPrimConst c1 c2 - | Just Refl <- match x1 x2 - , Just Refl <- matchPrimFun f1 f2 - = Just Refl +matchOpenExp (PrimApp f1 x1) (PrimApp f2 x2) + | Just x1' <- commutes f1 x1 + , Just x2' <- commutes f2 x2 + , Just Refl <- matchOpenExp 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 + | Just Refl <- matchOpenExp x1 x2 + , Just Refl <- matchPrimFun f1 f2 + = Just Refl - match (LinearIndex a1 x1) (LinearIndex a2 x2) - | Just Refl <- matchAcc a1 a2 - , Just Refl <- match x1 x2 - = Just Refl +matchOpenExp (Index a1 x1) (Index a2 x2) + | Just Refl <- matchVar a1 a2 -- should only be array indices + , Just Refl <- matchOpenExp x1 x2 + = Just Refl - match (Shape a1) (Shape a2) - | Just Refl <- matchAcc a1 a2 -- should only be array indices - = Just Refl +matchOpenExp (LinearIndex a1 x1) (LinearIndex a2 x2) + | Just Refl <- matchVar a1 a2 + , Just Refl <- matchOpenExp x1 x2 + = Just Refl - match (ShapeSize _ sh1) (ShapeSize _ sh2) - | Just Refl <- match sh1 sh2 - = Just Refl +matchOpenExp (Shape a1) (Shape a2) + | Just Refl <- matchVar a1 a2 -- should only be array indices + = Just Refl - match _ _ - = Nothing +matchOpenExp (ShapeSize _ sh1) (ShapeSize _ sh2) + | Just Refl <- matchOpenExp sh1 sh2 + = Just Refl + +matchOpenExp _ _ + = Nothing -- Match scalar functions -- -{-# INLINEABLE matchPreOpenFun #-} -matchPreOpenFun - :: HasArraysRepr acc - => MatchAcc acc - -> EncodeAcc acc - -> PreOpenFun acc env aenv s - -> PreOpenFun acc env aenv t +{-# INLINEABLE matchOpenFun #-} +matchOpenFun + :: OpenFun env aenv s + -> OpenFun env aenv t -> Maybe (s :~: t) -matchPreOpenFun m h (Lam lhs1 s) (Lam lhs2 t) +matchOpenFun (Lam lhs1 s) (Lam lhs2 t) | Just Refl <- matchELeftHandSide lhs1 lhs2 - , Just Refl <- matchPreOpenFun m h s t + , Just Refl <- matchOpenFun s t = Just Refl -matchPreOpenFun m h (Body s) (Body t) = matchPreOpenExp m h s t -matchPreOpenFun _ _ _ _ = Nothing +matchOpenFun (Body s) (Body t) = matchOpenExp s t +matchOpenFun _ _ = Nothing -- Matching constants -- @@ -928,12 +915,11 @@ matchNonNumType _ _ = Nothing -- commutativity. -- commutes - :: forall acc env aenv a r. HasArraysRepr acc - => EncodeAcc acc - -> PrimFun (a -> r) - -> PreOpenExp acc env aenv a - -> Maybe (PreOpenExp acc env aenv a) -commutes h f x = case f of + :: forall acc env aenv a r. + PrimFun (a -> r) + -> OpenExp env aenv a + -> Maybe (OpenExp env aenv a) +commutes f x = case f of PrimAdd{} -> Just (swizzle x) PrimMul{} -> Just (swizzle x) PrimBAnd{} -> Just (swizzle x) @@ -947,10 +933,10 @@ commutes h f x = case f of PrimLOr -> Just (swizzle x) _ -> Nothing where - swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a') + swizzle :: OpenExp env aenv (a',a') -> OpenExp env aenv (a',a') swizzle exp | (a `Pair` b) <- exp - , hashPreOpenExp h a > hashPreOpenExp h b = b `Pair` a + , hashOpenExp a > hashOpenExp b = b `Pair` a -- | otherwise = exp diff --git a/src/Data/Array/Accelerate/Analysis/Shape.hs b/src/Data/Array/Accelerate/Analysis/Shape.hs index 89884389a..416e77389 100644 --- a/src/Data/Array/Accelerate/Analysis/Shape.hs +++ b/src/Data/Array/Accelerate/Analysis/Shape.hs @@ -32,7 +32,7 @@ accDim = rank . arrayRshape . arrayRepr -- |Reify dimensionality of a scalar expression yielding a shape -- -expDim :: forall acc env aenv sh. HasArraysRepr acc => PreOpenExp acc env aenv sh -> Int +expDim :: forall env aenv sh. OpenExp env aenv sh -> Int expDim = ndim . expType -- Count the number of components to a tuple type diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index a5bb15e18..cdb7d6de6 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -68,7 +68,7 @@ import Unsafe.Coerce import Prelude hiding ( (!!), sum ) -- friends -import Data.Array.Accelerate.AST hiding ( Boundary, PreBoundary(..) ) +import Data.Array.Accelerate.AST hiding ( Boundary(..) ) import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Array.Representation @@ -153,8 +153,6 @@ data Delayed a where -- Array expression evaluation -- --------------------------- -type EvalAcc acc = forall aenv a. acc aenv a -> Val aenv -> WithReprs a - type WithReprs acc = (ArraysR acc, acc) fromFunction' :: ArrayR (Array sh e) -> sh -> (sh -> e) -> WithReprs (Array sh e) @@ -188,14 +186,14 @@ evalOpenAcc (AST.Manifest pacc) aenv = where (TupRsingle repr, a) = manifest a' - evalE :: DelayedExp aenv t -> t - evalE exp = evalPreExp evalOpenAcc exp aenv + evalE :: Exp aenv t -> t + evalE exp = evalExp exp aenv - evalF :: DelayedFun aenv f -> f - evalF fun = evalPreFun evalOpenAcc fun aenv + evalF :: Fun aenv f -> f + evalF fun = evalFun fun aenv - evalB :: AST.PreBoundary DelayedOpenAcc aenv t -> Boundary t - evalB bnd = evalPreBoundary evalOpenAcc bnd aenv + evalB :: AST.Boundary aenv t -> Boundary t + evalB bnd = evalBoundary bnd aenv in case pacc of Avar (Var repr ix) -> (TupRsingle repr, prj ix aenv) @@ -864,14 +862,14 @@ data Boundary t where Function :: (sh -> e) -> Boundary (Array sh e) -evalPreBoundary :: HasArraysRepr acc => EvalAcc acc -> AST.PreBoundary acc aenv t -> Val aenv -> Boundary t -evalPreBoundary evalAcc bnd aenv = +evalBoundary :: AST.Boundary aenv t -> Val aenv -> Boundary t +evalBoundary 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) + AST.Function f -> Function (evalFun f aenv) -- Scalar expression evaluation @@ -879,20 +877,20 @@ evalPreBoundary evalAcc bnd aenv = -- Evaluate a closed scalar expression -- -evalPreExp :: HasArraysRepr acc => EvalAcc acc -> PreExp acc aenv t -> Val aenv -> t -evalPreExp evalAcc e aenv = evalPreOpenExp evalAcc e Empty aenv +evalExp :: Exp aenv t -> Val aenv -> t +evalExp e aenv = evalOpenExp e Empty aenv -- Evaluate a closed scalar function -- -evalPreFun :: HasArraysRepr acc => EvalAcc acc -> PreFun acc aenv t -> Val aenv -> t -evalPreFun evalAcc f aenv = evalPreOpenFun evalAcc f Empty aenv +evalFun :: Fun aenv t -> Val aenv -> t +evalFun f aenv = evalOpenFun f Empty aenv -- Evaluate an open scalar function -- -evalPreOpenFun :: HasArraysRepr acc => EvalAcc acc -> PreOpenFun acc env aenv t -> Val env -> Val aenv -> t -evalPreOpenFun evalAcc (Body e) env aenv = evalPreOpenExp evalAcc e env aenv -evalPreOpenFun evalAcc (Lam lhs f) env aenv = - \x -> evalPreOpenFun evalAcc f (env `push` (lhs, x)) aenv +evalOpenFun :: OpenFun env aenv t -> Val env -> Val aenv -> t +evalOpenFun (Body e) env aenv = evalOpenExp e env aenv +evalOpenFun (Lam lhs f) env aenv = + \x -> evalOpenFun f (env `push` (lhs, x)) aenv -- Evaluate an open scalar expression @@ -903,33 +901,27 @@ evalPreOpenFun evalAcc (Lam lhs f) env aenv = -- mapped over an array, the array argument would be evaluated many times -- leading to a large amount of wasteful recomputation. -- --- TODO: If we change the argument of Shape, Index and LinearIndex to be an array --- variable (instead of an arbitrary array computation), we could remove the --- HasArraysRepr constraint and just pattern match on the Var. --- -evalPreOpenExp - :: forall acc env aenv t. - HasArraysRepr acc - => EvalAcc acc - -> PreOpenExp acc env aenv t +evalOpenExp + :: forall env aenv t. + OpenExp env aenv t -> Val env -> Val aenv -> t -evalPreOpenExp evalAcc pexp env aenv = +evalOpenExp pexp env aenv = let - evalE :: PreOpenExp acc env aenv t' -> t' - evalE e = evalPreOpenExp evalAcc e env aenv + evalE :: OpenExp env aenv t' -> t' + evalE e = evalOpenExp e env aenv - evalF :: PreOpenFun acc env aenv f' -> f' - evalF f = evalPreOpenFun evalAcc f env aenv + evalF :: OpenFun env aenv f' -> f' + evalF f = evalOpenFun f env aenv - evalA :: acc aenv a -> WithReprs a - evalA a = evalAcc a aenv + evalA :: ArrayVar aenv a -> WithReprs a + evalA (Var repr ix) = (TupRsingle repr, prj ix aenv) in case pexp of Let lhs exp1 exp2 -> let !v1 = evalE exp1 env' = env `push` (lhs, v1) - in evalPreOpenExp evalAcc exp2 env' aenv + in evalOpenExp exp2 env' aenv Evar (Var _ ix) -> prj ix env Const _ c -> c Undef tp -> evalUndefScalar tp @@ -985,7 +977,7 @@ evalPreOpenExp evalAcc pexp env aenv = in (repr, a) ! ix Shape acc -> shape $ snd $ evalA acc ShapeSize shr sh -> size shr (evalE sh) - Foreign _ _ f e -> evalPreOpenFun evalAcc f Empty Empty $ evalE e + Foreign _ _ f e -> evalOpenFun f Empty Empty $ evalE e Coerce t1 t2 e -> evalCoerceScalar t1 t2 (evalE e) @@ -1825,10 +1817,10 @@ evalSeq conf s aenv = evalSeq' s evalAF f = evalOpenAfun f aenv evalE :: DelayedExp aenv t -> t - evalE exp = evalPreExp evalOpenAcc exp aenv + evalE exp = evalExp exp aenv evalF :: DelayedFun aenv f -> f - evalF fun = evalPreFun evalOpenAcc fun aenv + evalF fun = evalFun fun aenv initProducer :: forall a senv. Producer DelayedOpenAcc aenv senv a @@ -1874,9 +1866,9 @@ evalSeq conf s aenv = evalSeq' s 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) + delayed AST.Delayed{..} = Delayed (evalExp extentD aenv) + (evalFun indexD aenv) + (evalFun linearIndexD aenv) produce :: Arrays a => ExecP senv a -> Val' senv -> (Chunk a, Maybe (ExecP senv a)) produce p senv = diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index 82ffffbb5..b5b32a97b 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -24,8 +24,8 @@ module Data.Array.Accelerate.Pretty ( PrettyAcc, ExtractAcc, prettyPreOpenAcc, prettyPreOpenAfun, - prettyPreOpenExp, - prettyPreOpenFun, + prettyOpenExp, + prettyOpenFun, -- ** Graphviz Graph, @@ -101,17 +101,11 @@ instance PrettyEnv aenv => Show (DelayedOpenAcc aenv a) where instance PrettyEnv aenv => Show (DelayedOpenAfun aenv f) where show = renderForTerminal . prettyPreOpenAfun prettyDelayedOpenAcc (prettyEnv (pretty 'a')) -instance (PrettyEnv env, PrettyEnv aenv) => Show (PreOpenExp OpenAcc env aenv e) where - show = renderForTerminal . prettyPreOpenExp context0 prettyOpenAcc extractOpenAcc (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) +instance (PrettyEnv env, PrettyEnv aenv) => Show (OpenExp env aenv e) where + show = renderForTerminal . prettyOpenExp context0 (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) -instance (PrettyEnv env, PrettyEnv aenv) => Show (PreOpenExp DelayedOpenAcc env aenv e) where - show = renderForTerminal . prettyPreOpenExp context0 prettyDelayedOpenAcc extractDelayedOpenAcc (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) - -instance (PrettyEnv env, PrettyEnv aenv) => Show (PreOpenFun OpenAcc env aenv e) where - show = renderForTerminal . prettyPreOpenFun prettyOpenAcc extractOpenAcc (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) - -instance (PrettyEnv env, PrettyEnv aenv) => Show (PreOpenFun DelayedOpenAcc env aenv e) where - show = renderForTerminal . prettyPreOpenFun prettyDelayedOpenAcc extractDelayedOpenAcc (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) +instance (PrettyEnv env, PrettyEnv aenv) => Show (OpenFun env aenv e) where + show = renderForTerminal . prettyOpenFun (prettyEnv (pretty 'x')) (prettyEnv (pretty 'a')) -- Internals @@ -162,8 +156,8 @@ prettyDelayedOpenAcc _ aenv (Delayed _ sh f _) = parens $ nest shiftwidth $ sep [ delayed "delayed" - , prettyPreOpenExp app prettyDelayedOpenAcc extractDelayedOpenAcc Empty aenv sh - , parens $ prettyPreOpenFun prettyDelayedOpenAcc extractDelayedOpenAcc Empty aenv f + , prettyOpenExp app Empty aenv sh + , parens $ prettyOpenFun Empty aenv f ] extractDelayedOpenAcc :: DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv a diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 4a82b9418..3533a6472 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -280,21 +280,17 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = -- Free variables -- - fvA :: FVAcc DelayedOpenAcc - fvA env (Manifest (Avar (Var _ ix))) = [ Vertex (fst $ aprj ix env) Nothing ] - fvA _ _ = $internalError "graphviz" "expected array variable" + fvF :: Fun aenv t -> [Vertex] + fvF = fvOpenFun Empty aenv - fvF :: DelayedFun aenv t -> [Vertex] - fvF = fvPreOpenFun fvA Empty aenv - - fvE :: DelayedExp aenv t -> [Vertex] - fvE = fvPreOpenExp fvA Empty aenv + fvE :: Exp aenv t -> [Vertex] + fvE = fvOpenExp Empty aenv -- Pretty-printing -- avar :: ArrayVar aenv t -> PDoc avar (Var _ ix) = let (ident, v) = aprj ix aenv - in PDoc (pretty v) [Vertex ident Nothing] + in PDoc (pretty v) [Vertex ident Nothing] aenv' :: Val aenv aenv' = avalToVal aenv @@ -312,14 +308,14 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = | Shape a <- sh -- identical shape , Just b <- isIdentityIndexing f -- function is `\ix -> b ! ix` , Just Refl <- match a b -- function thus is `\ix -> a ! ix` - = ppA a + = ppA $ Manifest $ Avar a ppA (Delayed _ sh f _) = do PDoc d v <- "Delayed" `fmt` [ ppE sh, ppF f ] return $ PDoc (parens d) v ppB :: forall sh e. TupleType e - -> PreBoundary DelayedOpenAcc aenv (Array sh e) + -> Boundary aenv (Array sh e) -> Dot PDoc ppB _ Clamp = return (PDoc "clamp" []) ppB _ Mirror = return (PDoc "mirror" []) @@ -327,11 +323,11 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = ppB tp (Constant e) = return (PDoc (prettyConst tp e) []) ppB _ (Function f) = ppF f - ppF :: DelayedFun aenv t -> Dot PDoc - ppF = return . uncurry PDoc . (parens . prettyDelayedFun aenv' &&& fvF) + ppF :: Fun aenv t -> Dot PDoc + ppF = return . uncurry PDoc . (parens . prettyFun aenv' &&& fvF) - ppE :: DelayedExp aenv t -> Dot PDoc - ppE = return . uncurry PDoc . (prettyDelayedExp aenv' &&& fvE) + ppE :: Exp aenv t -> Dot PDoc + ppE = return . uncurry PDoc . (prettyExp aenv' &&& fvE) lift :: DelayedOpenAcc aenv a -> Dot Vertex lift Delayed{} = $internalError "prettyDelayedOpenAcc" "expected manifest array" @@ -483,49 +479,6 @@ replant pnode@(PNode ident tree _) = -- nodes. -- -prettyDelayedFun :: Val aenv -> DelayedFun aenv f -> Adoc -prettyDelayedFun = prettyDelayedOpenFun Empty - -prettyDelayedExp :: Val aenv -> DelayedExp aenv t -> Adoc -prettyDelayedExp = prettyDelayedOpenExp context0 Empty - - -prettyDelayedOpenFun - :: forall env aenv f. - Val env - -> Val aenv - -> DelayedOpenFun env aenv f - -> Adoc -prettyDelayedOpenFun env0 aenv = next "\\\\" env0 - 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 :: Adoc -> Val env' -> PreOpenFun DelayedOpenAcc env' aenv f' -> Adoc - next vs env (Body body) = - nest shiftwidth (sep [ vs <> "→" - , prettyDelayedOpenExp context0 env aenv body ]) - next vs env (Lam lhs lam) = - let (env', arg) = prettyELhs True env lhs - in next (vs <> arg <> space) env' lam - -prettyDelayedOpenExp - :: Context - -> Val env - -> Val aenv - -> DelayedOpenExp env aenv t - -> Adoc -prettyDelayedOpenExp context = prettyPreOpenExp context pp ex - where - pp :: PrettyAcc DelayedOpenAcc - pp _ aenv (Manifest (Avar (Var _ ix))) = prj ix aenv - pp _ _ _ = $internalError "prettyDelayedOpenExp" "expected array variable" - - ex :: ExtractAcc DelayedOpenAcc - ex (Manifest pacc) = pacc - ex Delayed{} = $internalError "prettyDelayedOpenExp" "expected manifest array" - - -- Data dependencies -- ----------------- -- @@ -534,38 +487,37 @@ prettyDelayedOpenExp context = prettyPreOpenExp context pp ex -- nodes (vertices) into the current term. -- -type FVAcc acc = forall aenv a. Aval aenv -> acc aenv a -> [Vertex] +fvAvar :: Aval aenv -> ArrayVar aenv a -> [Vertex] +fvAvar env (Var _ ix) = [ Vertex (fst $ aprj ix env) Nothing ] -fvPreOpenFun - :: forall acc env aenv fun. - FVAcc acc - -> Val env +fvOpenFun + :: forall env aenv fun. + Val env -> Aval aenv - -> PreOpenFun acc env aenv fun + -> OpenFun env aenv fun -> [Vertex] -fvPreOpenFun fvA env aenv (Body b) = fvPreOpenExp fvA env aenv b -fvPreOpenFun fvA env aenv (Lam lhs f) = fvPreOpenFun fvA env' aenv f +fvOpenFun env aenv (Body b) = fvOpenExp env aenv b +fvOpenFun env aenv (Lam lhs f) = fvOpenFun env' aenv f where (env', _) = prettyELhs True env lhs -fvPreOpenExp - :: forall acc env aenv exp. - FVAcc acc - -> Val env +fvOpenExp + :: forall env aenv exp. + Val env -> Aval aenv - -> PreOpenExp acc env aenv exp + -> OpenExp env aenv exp -> [Vertex] -fvPreOpenExp fvA env aenv = fv +fvOpenExp env aenv = fv where - fvF :: PreOpenFun acc env aenv f -> [Vertex] - fvF = fvPreOpenFun fvA env aenv + fvF :: OpenFun env aenv f -> [Vertex] + fvF = fvOpenFun 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 :: OpenExp env aenv e -> [Vertex] + fv (Shape acc) = if cfgIncludeShape then fvAvar aenv acc else [] + fv (Index acc i) = concat [ fvAvar aenv acc, fv i ] + fv (LinearIndex acc i) = concat [ fvAvar aenv acc, fv i ] -- - fv (Let lhs e1 e2) = concat [ fv e1, fvPreOpenExp fvA env' aenv e2 ] + fv (Let lhs e1 e2) = concat [ fv e1, fvOpenExp env' aenv e2 ] where (env', _) = prettyELhs False env lhs fv Evar{} = [] diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index b242d1027..f64bb347b 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -25,8 +25,8 @@ module Data.Array.Accelerate.Pretty.Print ( PrettyAcc, ExtractAcc, prettyPreOpenAcc, prettyPreOpenAfun, - prettyPreOpenExp, - prettyPreOpenFun, + prettyOpenExp, prettyExp, + prettyOpenFun, prettyFun, prettyArray, prettyConst, prettyELhs, @@ -187,15 +187,15 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = ppAF :: PreOpenAfun acc aenv f -> Adoc ppAF = parens . prettyPreOpenAfun prettyAcc aenv - ppE :: PreExp acc aenv t -> Adoc - ppE = prettyPreOpenExp app prettyAcc extractAcc Empty aenv + ppE :: Exp aenv t -> Adoc + ppE = prettyOpenExp app Empty aenv - ppF :: PreFun acc aenv t -> Adoc - ppF = parens . prettyPreOpenFun prettyAcc extractAcc Empty aenv + ppF :: Fun aenv t -> Adoc + ppF = parens . prettyOpenFun Empty aenv ppB :: forall sh e. TupleType e - -> PreBoundary acc aenv (Array sh e) + -> Boundary aenv (Array sh e) -> Adoc ppB _ Clamp = "clamp" ppB _ Mirror = "mirror" @@ -305,18 +305,21 @@ prettyArray repr = parens . fromString . showArray repr -- Scalar expressions -- ------------------ +prettyFun :: Val aenv -> Fun aenv f -> Adoc +prettyFun = prettyOpenFun Empty -prettyPreOpenFun - :: forall acc env aenv f. - PrettyAcc acc - -> ExtractAcc acc - -> Val env +prettyExp :: Val aenv -> Exp aenv t -> Adoc +prettyExp = prettyOpenExp context0 Empty + +prettyOpenFun + :: forall env aenv f. + Val env -> Val aenv - -> PreOpenFun acc env aenv f + -> OpenFun env aenv f -> Adoc -prettyPreOpenFun prettyAcc extractAcc env0 aenv = next (pretty '\\') env0 +prettyOpenFun env0 aenv = next (pretty '\\') env0 where - next :: Adoc -> Val env' -> PreOpenFun acc env' aenv f' -> Adoc + next :: Adoc -> Val env' -> OpenFun env' aenv f' -> Adoc next vs env (Body body) -- PrimApp f x <- body -- , op <- primOperator f @@ -327,24 +330,22 @@ prettyPreOpenFun prettyAcc extractAcc env0 aenv = next (pretty '\\') env0 -- = opName op -- surrounding context will add parens -- = hang shiftwidth (sep [ vs <> "->" - , prettyPreOpenExp context0 prettyAcc extractAcc env aenv body]) + , prettyOpenExp context0 env aenv body]) next vs env (Lam lhs lam) = let (env', lhs') = prettyELhs True env lhs in next (vs <> lhs' <> space) env' lam -prettyPreOpenExp - :: forall acc env aenv t. +prettyOpenExp + :: forall env aenv t. Context - -> PrettyAcc acc - -> ExtractAcc acc -> Val env -> Val aenv - -> PreOpenExp acc env aenv t + -> OpenExp env aenv t -> Adoc -prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = +prettyOpenExp ctx env aenv exp = case exp of Evar (Var _ idx) -> prj idx env - Let{} -> prettyLet ctx prettyAcc extractAcc env aenv exp + Let{} -> prettyLet ctx env aenv exp PrimApp f x | a `Pair` b <- x -> ppF2 op (ppE a) (ppE b) | otherwise -> ppF1 op' (ppE x) @@ -354,7 +355,7 @@ prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = -- PrimConst c -> prettyPrimConst c Const tp c -> prettyConst (TupRsingle tp) c - Pair{} -> prettyTuple ctx prettyAcc extractAcc env aenv exp + Pair{} -> prettyTuple ctx env aenv exp Nil -> "()" VecPack _ e -> ppF1 "vecPack" (ppE e) VecUnpack _ e -> ppF1 "vecUnpack" (ppE e) @@ -385,14 +386,14 @@ prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = Undef tp -> withTypeRep tp "undef" where - ppE :: PreOpenExp acc env aenv e -> Context -> Adoc - ppE e c = prettyPreOpenExp c prettyAcc extractAcc env aenv e + ppE :: OpenExp env aenv e -> Context -> Adoc + ppE e c = prettyOpenExp c env aenv e - ppA :: acc aenv a -> Context -> Adoc - ppA acc _ = prettyAcc app aenv acc + ppA :: ArrayVar aenv a -> Context -> Adoc + ppA acc _ = prettyArrayVar aenv acc - ppF :: PreOpenFun acc env aenv f -> Context -> Adoc - ppF f _ = parens $ prettyPreOpenFun prettyAcc extractAcc env aenv f + ppF :: OpenFun env aenv f -> Context -> Adoc + ppF f _ = parens $ prettyOpenFun env aenv f ppF1 :: Operator -> (Context -> Adoc) -> Adoc ppF1 op x @@ -418,21 +419,25 @@ prettyPreOpenExp ctx prettyAcc extractAcc env aenv exp = withTypeRep :: ScalarType t -> Adoc -> Adoc withTypeRep tp op = op <> enclose langle rangle (pretty (showScalarType tp)) +prettyArrayVar + :: forall aenv a. + Val aenv + -> ArrayVar aenv a + -> Adoc +prettyArrayVar aenv (Var _ idx) = prj idx aenv prettyLet - :: forall acc env aenv t. + :: forall env aenv t. Context - -> PrettyAcc acc - -> ExtractAcc acc -> Val env -> Val aenv - -> PreOpenExp acc env aenv t + -> OpenExp env aenv t -> Adoc -prettyLet ctx prettyAcc extractAcc env0 aenv +prettyLet ctx env0 aenv = parensIf (needsParens ctx "let") . align . wrap . collect env0 where - collect :: Val env' -> PreOpenExp acc env' aenv e -> ([Adoc], Adoc) + collect :: Val env' -> OpenExp env' aenv e -> ([Adoc], Adoc) collect env = \case Let lhs e1 e2 -> @@ -446,12 +451,12 @@ prettyLet ctx prettyAcc extractAcc env0 aenv -- next -> ([], ppE env next) - isLet :: PreOpenExp acc env' aenv t' -> Bool + isLet :: OpenExp env' aenv t' -> Bool isLet Let{} = True isLet _ = False - ppE :: Val env' -> PreOpenExp acc env' aenv t' -> Adoc - ppE env = prettyPreOpenExp context0 prettyAcc extractAcc env aenv + ppE :: Val env' -> OpenExp env' aenv t' -> Adoc + ppE env = prettyOpenExp context0 env aenv wrap :: ([Adoc], Adoc) -> Adoc wrap ([], body) = body -- shouldn't happen! @@ -464,27 +469,25 @@ prettyLet ctx prettyAcc extractAcc env0 aenv ] prettyTuple - :: forall acc env aenv t. + :: forall env aenv t. Context - -> PrettyAcc acc - -> ExtractAcc acc -> Val env -> Val aenv - -> PreOpenExp acc env aenv t + -> OpenExp env aenv t -> Adoc -prettyTuple ctx prettyAcc extractAcc env aenv exp = case collect exp of +prettyTuple ctx env aenv exp = case collect exp of Just tup -> align $ parensIf (ctxPrecedence ctx > 0) ("T" <> pretty (length tup) <+> sep tup) Nothing -> align $ ppPair exp where - ppPair :: PreOpenExp acc env aenv t' -> Adoc - ppPair (Pair e1 e2) = "(" <> ppPair e1 <> "," <+> prettyPreOpenExp context0 prettyAcc extractAcc env aenv e2 <> ")" - ppPair e = prettyPreOpenExp context0 prettyAcc extractAcc env aenv e + ppPair :: OpenExp env aenv t' -> Adoc + ppPair (Pair e1 e2) = "(" <> ppPair e1 <> "," <+> prettyOpenExp context0 env aenv e2 <> ")" + ppPair e = prettyOpenExp context0 env aenv e - collect :: PreOpenExp acc env aenv t' -> Maybe [Adoc] + collect :: OpenExp env aenv t' -> Maybe [Adoc] collect Nil = Just [] collect (Pair e1 e2) | Just tup <- collect e1 - = Just $ tup ++ [prettyPreOpenExp app prettyAcc extractAcc env aenv e2] + = Just $ tup ++ [prettyOpenExp app env aenv e2] collect _ = Nothing {- diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index efbf704ee..d48603093 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -80,8 +80,8 @@ import Data.Array.Accelerate.Array.Sugar (Elt, Arrays, EltRepr, ArrRep import qualified Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.Array.Representation hiding (DIM1) import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc - , PreOpenExp(..), OpenExp, PreExp, Exp - , PreBoundary(..), Boundary, HasArraysRepr(..), arrayRepr, expType + , OpenExp(..), Exp + , Boundary(..), HasArraysRepr(..), arrayRepr, expType , showPreAccOp, showPreExpOp ) import GHC.TypeNats diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 7266a3a1b..9cadbe8c4 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -38,8 +38,6 @@ module Data.Array.Accelerate.Trafo ( -- * Fusion DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun, - DelayedExp, DelayedOpenExp, - DelayedFun, DelayedOpenFun, -- * Substitution module Data.Array.Accelerate.Trafo.Substitution, @@ -60,7 +58,7 @@ import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Array.Sugar ( ArrRepr, EltRepr ) import Data.Array.Accelerate.Trafo.Base ( Match(..), matchDelayedOpenAcc, encodeDelayedOpenAcc ) import Data.Array.Accelerate.Trafo.Config -import Data.Array.Accelerate.Trafo.Fusion ( DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun, DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun ) +import Data.Array.Accelerate.Trafo.Fusion ( DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun ) import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr, EltReprFunctionR ) import Data.Array.Accelerate.Trafo.Substitution import qualified Data.Array.Accelerate.AST as AST diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index 429a861fa..775a237ec 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -52,13 +52,13 @@ import qualified Data.Array.Accelerate.Debug.Stats as Stats -- 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 + :: forall env aenv exp. + Gamma env env aenv + -> OpenExp env aenv exp -> Maybe exp propagate env = cvtE where - cvtE :: PreOpenExp acc env aenv e -> Maybe e + cvtE :: OpenExp env aenv e -> Maybe e cvtE exp = case exp of Const _ c -> Just c PrimConst c -> Just (evalPrimConst c) @@ -73,11 +73,11 @@ propagate env = cvtE -- Attempt to evaluate primitive function applications -- evalPrimApp - :: forall acc env aenv a r. (Kit acc) - => Gamma acc env env aenv + :: forall env aenv a r. + Gamma env env aenv -> PrimFun (a -> r) - -> PreOpenExp acc env aenv a - -> (Any, PreOpenExp acc env aenv r) + -> OpenExp env aenv a + -> (Any, OpenExp 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 @@ -159,11 +159,11 @@ evalPrimApp env f x -- 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) + :: forall env aenv a r. + PrimFun (a -> r) + -> OpenExp env aenv a + -> Gamma env env aenv + -> Maybe (OpenExp env aenv a) commutes f x env = case f of PrimAdd _ -> swizzle x PrimMul _ -> swizzle x @@ -176,7 +176,7 @@ commutes f x env = case f of PrimMin _ -> swizzle x _ -> Nothing where - swizzle :: PreOpenExp acc env aenv (b,b) -> Maybe (PreOpenExp acc env aenv (b,b)) + swizzle :: OpenExp env aenv (b,b) -> Maybe (OpenExp env aenv (b,b)) swizzle (Pair a b) | Nothing <- propagate env a , Just _ <- propagate env b @@ -213,8 +213,8 @@ commutes f x env = case f of associates :: (Elt a, Elt r) => PrimFun (a -> r) - -> PreOpenExp acc env aenv a - -> Maybe (PreOpenExp acc env aenv r) + -> OpenExp env aenv a + -> Maybe (OpenExp 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] @@ -226,7 +226,7 @@ associates fun exp = case fun of 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 :: (Elt a, Elt r) => PrimFun (a -> r) -> OpenExp env aenv a -> [PrimFun (a -> r)] -> Maybe (OpenExp env aenv r) swizzle f x lvl | Just Refl <- matches f ops , Just (a,bc) <- untup2 x @@ -253,7 +253,7 @@ associates fun exp = case fun of -- 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) +type a :-> b = forall env aenv. OpenExp env aenv a -> Gamma env env aenv -> Maybe (OpenExp env aenv b) eval1 :: SingleType b -> (a -> b) -> a :-> b eval1 tp f x env @@ -270,10 +270,10 @@ eval2 tp f (untup2 -> Just (x,y)) env eval2 _ _ _ _ = Nothing -tup2 :: (PreOpenExp acc env aenv a, PreOpenExp acc env aenv b) -> PreOpenExp acc env aenv (a, b) +tup2 :: (OpenExp env aenv a, OpenExp env aenv b) -> OpenExp env aenv (a, b) tup2 (a,b) = Pair a b -untup2 :: PreOpenExp acc env aenv (a, b) -> Maybe (PreOpenExp acc env aenv a, PreOpenExp acc env aenv b) +untup2 :: OpenExp env aenv (a, b) -> Maybe (OpenExp env aenv a, OpenExp env aenv b) untup2 exp | Pair a b <- exp = Just (a, b) | otherwise = Nothing diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index a21e7e433..a161f2017 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -37,8 +37,6 @@ module Data.Array.Accelerate.Trafo.Base ( -- Delayed Arrays DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun, - DelayedExp, DelayedOpenExp, - DelayedFun, DelayedOpenFun, matchDelayedOpenAcc, encodeDelayedOpenAcc, @@ -46,7 +44,7 @@ module Data.Array.Accelerate.Trafo.Base ( Gamma(..), incExp, prjExp, pushExp, Extend(..), pushArrayEnv, append, bind, Sink(..), SinkExp(..), sinkA, sink1, - PreOpenExp', bindExps, + OpenExp', bindExps, -- Adding new variables to the environment declareVars, DeclareVars(..), @@ -176,13 +174,13 @@ instance Match ArrayR where instance Match a => Match (TupR a) where match = matchTupR match -instance Kit acc => Match (PreOpenExp acc env aenv) where +instance Match (OpenExp env aenv) where {-# INLINEABLE match #-} - match = matchPreOpenExp matchAcc encodeAcc + match = matchOpenExp -instance Kit acc => Match (PreOpenFun acc env aenv) where +instance Match (OpenFun env aenv) where {-# INLINEABLE match #-} - match = matchPreOpenFun matchAcc encodeAcc + match = matchOpenFun instance Kit acc => Match (PreOpenAcc acc aenv) where {-# INLINEABLE match #-} @@ -203,17 +201,12 @@ instance {-# INCOHERENT #-} Kit acc => Match (acc aenv) where 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 @@ -221,9 +214,9 @@ data DelayedOpenAcc aenv a where Delayed :: { reprD :: ArrayR (Array sh e) - , extentD :: PreExp DelayedOpenAcc aenv sh - , indexD :: PreFun DelayedOpenAcc aenv (sh -> e) - , linearIndexD :: PreFun DelayedOpenAcc aenv (Int -> e) + , extentD :: Exp aenv sh + , indexD :: Fun aenv (sh -> e) + , linearIndexD :: Fun aenv (Int -> e) } -> DelayedOpenAcc aenv (Array sh e) instance HasArraysRepr DelayedOpenAcc where @@ -235,10 +228,10 @@ instance Rebuildable DelayedOpenAcc where {-# INLINEABLE rebuildPartial #-} rebuildPartial v acc = case acc of Manifest pacc -> Manifest <$> rebuildPartial v pacc - Delayed{..} -> Delayed reprD - <$> rebuildPartial v extentD - <*> rebuildPartial v indexD - <*> rebuildPartial v linearIndexD + Delayed{..} -> (\e i l -> Delayed reprD (unOpenAccExp e) (unOpenAccFun i) (unOpenAccFun l)) + <$> rebuildPartial v (OpenAccExp extentD) + <*> rebuildPartial v (OpenAccFun indexD) + <*> rebuildPartial v (OpenAccFun linearIndexD) instance Sink DelayedOpenAcc where weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) @@ -265,11 +258,11 @@ instance NFData (DelayedOpenAcc aenv t) where encodeDelayedOpenAcc :: EncodeAcc DelayedOpenAcc encodeDelayedOpenAcc options acc = let - travE :: DelayedExp aenv sh -> Builder - travE = encodePreOpenExp options encodeDelayedOpenAcc + travE :: Exp aenv sh -> Builder + travE = encodeOpenExp - travF :: DelayedFun aenv f -> Builder - travF = encodePreOpenFun options encodeDelayedOpenAcc + travF :: Fun aenv f -> Builder + travF = encodeOpenFun travA :: PreOpenAcc DelayedOpenAcc aenv a -> Builder travA = encodePreOpenAcc options encodeDelayedOpenAcc @@ -288,9 +281,9 @@ 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 <- matchOpenExp sh1 sh2 + , Just Refl <- matchOpenFun ix1 ix2 + , Just Refl <- matchOpenFun lx1 lx2 = Just Refl matchDelayedOpenAcc _ _ @@ -299,9 +292,9 @@ matchDelayedOpenAcc _ _ rnfDelayedOpenAcc :: DelayedOpenAcc aenv t -> () rnfDelayedOpenAcc (Manifest pacc) = rnfPreOpenAcc rnfDelayedOpenAcc pacc rnfDelayedOpenAcc (Delayed repr sh ix lx) = rnfArrayR repr - `seq` rnfPreOpenExp rnfDelayedOpenAcc sh - `seq` rnfPreOpenFun rnfDelayedOpenAcc ix - `seq` rnfPreOpenFun rnfDelayedOpenAcc lx + `seq` rnfOpenExp sh + `seq` rnfOpenFun ix + `seq` rnfOpenFun lx {-- rnfDelayedSeq :: DelayedSeq t -> () @@ -321,18 +314,18 @@ rnfExtend rnfA (PushEnv env a) = rnfExtend rnfA env `seq` rnfA a -- 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 +data Gamma env env' aenv where + EmptyExp :: Gamma env env' aenv - PushExp :: Gamma acc env env' aenv - -> WeakPreOpenExp acc env aenv t - -> Gamma acc env (env', t) aenv + PushExp :: Gamma env env' aenv + -> WeakOpenExp env aenv t + -> Gamma env (env', t) aenv -data WeakPreOpenExp acc env aenv t where +data WeakOpenExp env aenv t where Subst :: env :> env' - -> PreOpenExp acc env aenv t - -> PreOpenExp acc env' aenv t {- LAZY -} - -> WeakPreOpenExp acc env' aenv t + -> OpenExp env aenv t + -> OpenExp env' aenv t {- LAZY -} + -> WeakOpenExp 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 @@ -346,28 +339,26 @@ data WeakPreOpenExp acc env aenv t where -- -- incExp - :: Kit acc - => Gamma acc env env' aenv - -> Gamma acc (env,s) env' aenv + :: Gamma env env' aenv + -> Gamma (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 (weakenSucc' k) e (weakenE (weakenSucc' k) e) + subs :: forall env aenv s t. WeakOpenExp env aenv t -> WeakOpenExp (env,s) aenv t + subs (Subst k (e :: OpenExp env_ aenv t) _) = Subst (weakenSucc' k) e (weakenE (weakenSucc' k) e) -prjExp :: Idx env' t -> Gamma acc env env' aenv -> PreOpenExp acc env aenv t +prjExp :: Idx env' t -> Gamma env env' aenv -> OpenExp env aenv t prjExp ZeroIdx (PushExp _ (Subst _ _ e)) = e prjExp (SuccIdx ix) (PushExp env _) = prjExp ix env prjExp _ _ = $internalError "prjExp" "inconsistent valuation" -pushExp :: Gamma acc env env' aenv -> PreOpenExp acc env aenv t -> Gamma acc env (env',t) aenv +pushExp :: Gamma env env' aenv -> OpenExp env aenv t -> Gamma env (env',t) aenv pushExp env e = env `PushExp` Subst weakenId e e {-- lookupExp - :: Kit acc - => Gamma acc env env' aenv - -> PreOpenExp acc env aenv t + :: Gamma env env' aenv + -> OpenExp env aenv t -> Maybe (Idx env' t) lookupExp EmptyExp _ = Nothing lookupExp (PushExp env e) x @@ -375,17 +366,16 @@ lookupExp (PushExp env e) x | otherwise = SuccIdx `fmap` lookupExp env x weakenGamma1 - :: Kit acc - => Gamma acc env env' aenv - -> Gamma acc env env' (aenv,t) + :: Gamma env env' aenv + -> Gamma 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' + -> Gamma env env' aenv + -> Gamma env env' aenv' sinkGamma _ EmptyExp = EmptyExp sinkGamma ext (PushExp env e) = PushExp (sinkGamma ext env) (sinkA ext e) --} @@ -440,24 +430,22 @@ sinkWeaken (PushEnv e (LeftHandSidePair l1 l2) _) = sinkWeaken (PushEnv (PushEnv sink1 :: Sink f => Extend s acc env env' -> f (env,t') t -> f (env',t') t sink1 env = weaken $ sink $ sinkWeaken env --- Wrapper around PreOpenExp, with the order of type arguments env and aenv flipped -newtype PreOpenExp' acc aenv env e = PreOpenExp' (PreOpenExp acc env aenv e) +-- Wrapper around OpenExp, with the order of type arguments env and aenv flipped +newtype OpenExp' aenv env e = OpenExp' (OpenExp env aenv e) -bindExps :: Kit acc - => Extend ScalarType (PreOpenExp' acc aenv) env env' - -> PreOpenExp acc env' aenv e - -> PreOpenExp acc env aenv e +bindExps :: Extend ScalarType (OpenExp' aenv) env env' + -> OpenExp env' aenv e + -> OpenExp env aenv e bindExps BaseEnv = id -bindExps (PushEnv g lhs (PreOpenExp' b)) = bindExps g . Let lhs b +bindExps (PushEnv g lhs (OpenExp' b)) = bindExps g . Let lhs b -- Utilities for working with shapes -mkShapeBinary :: (HasArraysRepr acc, RebuildableAcc acc) - => (forall env'. PreOpenExp acc env' aenv Int -> PreOpenExp acc env' aenv Int -> PreOpenExp acc env' aenv Int) +mkShapeBinary :: (forall env'. OpenExp env' aenv Int -> OpenExp env' aenv Int -> OpenExp env' aenv Int) -> ShapeR sh - -> PreOpenExp acc env aenv sh - -> PreOpenExp acc env aenv sh - -> PreOpenExp acc env aenv sh + -> OpenExp env aenv sh + -> OpenExp env aenv sh + -> OpenExp env aenv sh mkShapeBinary _ ShapeRz _ _ = Nil mkShapeBinary f (ShapeRsnoc shr) (Pair as a) (Pair bs b) = mkShapeBinary f shr as bs `Pair` f a b mkShapeBinary f shr (Let lhs bnd a) b = Let lhs bnd $ mkShapeBinary f shr a (weakenE (weakenWithLHS lhs) b) @@ -469,20 +457,18 @@ mkShapeBinary f shr a b -- `b` is not a Pair | DeclareVars lhs k value <- declareVars $ shapeType shr = Let lhs b $ mkShapeBinary f shr (weakenE k a) (evars $ value weakenId) -mkIntersect :: (HasArraysRepr acc, RebuildableAcc acc) - => ShapeR sh - -> PreOpenExp acc env aenv sh - -> PreOpenExp acc env aenv sh - -> PreOpenExp acc env aenv sh +mkIntersect :: ShapeR sh + -> OpenExp env aenv sh + -> OpenExp env aenv sh + -> OpenExp env aenv sh mkIntersect = mkShapeBinary f where f a b = PrimApp (PrimMin singleType) $ Pair a b -mkUnion :: (HasArraysRepr acc, RebuildableAcc acc) - => ShapeR sh - -> PreOpenExp acc env aenv sh - -> PreOpenExp acc env aenv sh - -> PreOpenExp acc env aenv sh +mkUnion :: ShapeR sh + -> OpenExp env aenv sh + -> OpenExp env aenv sh + -> OpenExp env aenv sh mkUnion = mkShapeBinary f where f a b = PrimApp (PrimMax singleType) $ Pair a b diff --git a/src/Data/Array/Accelerate/Trafo/Config.hs b/src/Data/Array/Accelerate/Trafo/Config.hs index a3f984023..488d02001 100644 --- a/src/Data/Array/Accelerate/Trafo/Config.hs +++ b/src/Data/Array/Accelerate/Trafo/Config.hs @@ -17,7 +17,7 @@ module Data.Array.Accelerate.Trafo.Config ( defaultOptions, -- Other options not controlled by the command line flags - float_out_acc, + -- float_out_acc, ) where @@ -46,5 +46,5 @@ defaultOptions = unsafePerformIO $! -- Extra options not covered by command line flags -- -float_out_acc = Flag 31 +-- float_out_acc = Flag 31 diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index fb195c40d..174064e2f 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -38,7 +38,6 @@ module Data.Array.Accelerate.Trafo.Fusion ( -- ** Types DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun, - DelayedExp, DelayedFun, DelayedOpenExp, DelayedOpenFun, -- ** Conversion convertAcc, convertAccWith, @@ -133,21 +132,14 @@ delayed config (embedOpenAcc config -> Embed env cc) | BaseEnv <- env = case simplify cc of Done v -> avarsIn v - Yield repr (cvtE -> sh) (cvtF -> f) -> Delayed repr sh f (f `compose` fromIndex (arrayRshape repr) sh) - Step repr (cvtE -> sh) (cvtF -> p) (cvtF -> f) v + Yield repr sh f -> Delayed repr sh f (f `compose` fromIndex (arrayRshape repr) sh) + Step repr sh p f v | Just Refl <- match sh (arrayShape v) , Just Refl <- isIdentity p -> Delayed repr sh (f `compose` indexArray v) (f `compose` linearIndex v) | f' <- f `compose` indexArray v `compose` p -> Delayed repr sh f' (f' `compose` fromIndex (arrayRshape repr) sh) -- | otherwise = manifest config (computeAcc (Embed env cc)) - where - cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t - cvtE = convertOpenExp config - - cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f - cvtF (Lam lhs f) = Lam lhs (cvtF f) - cvtF (Body b) = Body (cvtE b) -- Convert array programs as manifest terms. @@ -161,9 +153,9 @@ manifest config (OpenAcc pacc) = -- ----------------- Avar ix -> Avar ix Use repr arr -> Use repr arr - Unit tp e -> Unit tp (cvtE e) + Unit tp e -> Unit tp e Alet lhs bnd body -> alet lhs (manifest config bnd) (manifest config body) - Acond p t e -> Acond (cvtE p) (manifest config t) (manifest config e) + Acond p t e -> Acond p (manifest config t) (manifest config e) Awhile p f a -> Awhile (cvtAF p) (cvtAF f) (manifest config a) Apair a1 a2 -> Apair (manifest config a1) (manifest config a2) Anil -> Anil @@ -178,11 +170,11 @@ manifest config (OpenAcc pacc) = -- of a let-binding to be used multiple times. The input array here -- should be a evaluated array term, else something went wrong. -- - Map tp f a -> Map tp (cvtF f) (delayed config a) - Generate repr sh f -> Generate repr (cvtE sh) (cvtF f) - Transform repr sh p f a -> Transform repr (cvtE sh) (cvtF p) (cvtF f) (delayed config a) - Backpermute shr sh p a -> Backpermute shr (cvtE sh) (cvtF p) (delayed config a) - Reshape slr sl a -> Reshape slr (cvtE sl) (manifest config a) + Map tp f a -> Map tp f (delayed config a) + Generate repr sh f -> Generate repr sh f + Transform repr sh p f a -> Transform repr sh p f (delayed config a) + Backpermute shr sh p a -> Backpermute shr sh p (delayed config a) + Reshape slr sl a -> Reshape slr sl (manifest config a) Replicate{} -> fusionError Slice{} -> fusionError @@ -195,20 +187,20 @@ manifest config (OpenAcc pacc) = -- with local bindings, these will have been floated up above the -- consumer already -- - Fold f z a -> Fold (cvtF f) (cvtE z) (delayed config a) - Fold1 f a -> Fold1 (cvtF f) (delayed config a) - FoldSeg i f z a s -> FoldSeg i (cvtF f) (cvtE z) (delayed config a) (delayed config s) - Fold1Seg i f a s -> Fold1Seg i (cvtF f) (delayed config a) (delayed config s) - Scanl f z a -> Scanl (cvtF f) (cvtE z) (delayed config a) - Scanl1 f a -> Scanl1 (cvtF f) (delayed config a) - Scanl' f z a -> Scanl' (cvtF f) (cvtE z) (delayed config a) - Scanr f z a -> Scanr (cvtF f) (cvtE z) (delayed config a) - Scanr1 f a -> Scanr1 (cvtF f) (delayed config a) - Scanr' f z a -> Scanr' (cvtF f) (cvtE z) (delayed config a) - Permute f d p a -> Permute (cvtF f) (manifest config d) (cvtF p) (delayed config a) - Stencil s tp f x a -> Stencil s tp (cvtF f) (cvtB x) (delayed config a) + Fold f z a -> Fold f z (delayed config a) + Fold1 f a -> Fold1 f (delayed config a) + FoldSeg i f z a s -> FoldSeg i f z (delayed config a) (delayed config s) + Fold1Seg i f a s -> Fold1Seg i f (delayed config a) (delayed config s) + Scanl f z a -> Scanl f z (delayed config a) + Scanl1 f a -> Scanl1 f (delayed config a) + Scanl' f z a -> Scanl' f z (delayed config a) + Scanr f z a -> Scanr f z (delayed config a) + Scanr1 f a -> Scanr1 f (delayed config a) + Scanr' f z a -> Scanr' f z (delayed config a) + Permute f d p a -> Permute f (manifest config d) p (delayed config a) + Stencil s tp f x a -> Stencil s tp f x (delayed config a) Stencil2 s1 s2 tp f x a y b - -> Stencil2 s1 s2 tp (cvtF f) (cvtB x) (delayed config a) (cvtB y) (delayed config b) + -> Stencil2 s1 s2 tp f x (delayed config a) y (delayed config b) -- Collect s -> Collect (cvtS s) where @@ -256,58 +248,6 @@ manifest config (OpenAcc pacc) = -- cvtS :: PreOpenSeq OpenAcc aenv senv s -> PreOpenSeq DelayedOpenAcc aenv senv s -- cvtS = convertOpenSeq config - -- Conversions for closed scalar functions and expressions - -- - cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f - cvtF (Lam lhs f) = Lam lhs (cvtF f) - cvtF (Body b) = Body (cvtE b) - - cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t - cvtE = convertOpenExp config - - 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 :: Config -> OpenExp env aenv t -> DelayedOpenExp env aenv t -convertOpenExp config exp = - case exp of - Let lhs bnd body -> Let lhs (cvtE bnd) (cvtE body) - Evar var -> Evar var - Const tp c -> Const tp c - Undef tp -> Undef tp - Nil -> Nil - Pair e1 e2 -> Pair (cvtE e1) (cvtE e2) - VecPack vec e -> VecPack vec (cvtE e) - VecUnpack vec e -> VecUnpack vec (cvtE e) - IndexSlice x ix sh -> IndexSlice x (cvtE ix) (cvtE sh) - IndexFull x ix sl -> IndexFull x (cvtE ix) (cvtE sl) - ToIndex shr sh ix -> ToIndex shr (cvtE sh) (cvtE ix) - FromIndex shr sh ix -> FromIndex shr (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 config a) (cvtE sh) - LinearIndex a i -> LinearIndex (manifest config a) (cvtE i) - Shape a -> Shape (manifest config a) - ShapeSize shr sh -> ShapeSize shr (cvtE sh) - Foreign tp ff f e -> Foreign tp ff (cvtF f) (cvtE e) - Coerce t1 t2 e -> Coerce t1 t2 (cvtE e) - where - -- Conversions for closed scalar functions and expressions - -- - cvtF :: OpenFun env aenv f -> DelayedOpenFun env aenv f - cvtF (Lam lhs f) = Lam lhs (cvtF f) - cvtF (Body b) = Body (cvtE b) - - cvtE :: OpenExp env aenv t -> DelayedOpenExp env aenv t - cvtE = convertOpenExp config - - convertOpenAfun :: Config -> OpenAfun aenv f -> DelayedOpenAfun aenv f convertOpenAfun c (Alam lhs f) = Alam lhs (convertOpenAfun c f) convertOpenAfun c (Abody b) = Abody (convertOpenAcc c b) @@ -512,13 +452,13 @@ embedPreAcc config embedAcc elimAcc pacc -- Conversions for closed scalar functions and expressions. This just -- applies scalar simplifications. -- - cvtF :: PreFun acc aenv' t -> PreFun acc aenv' t + cvtF :: Fun aenv' t -> Fun aenv' t cvtF = simplify - cvtE :: PreExp acc aenv' t -> PreExp acc aenv' t + cvtE :: Exp aenv' t -> Exp aenv' t cvtE = simplify - cvtB :: PreBoundary acc aenv' t -> PreBoundary acc aenv' t + cvtB :: Boundary aenv' t -> Boundary aenv' t cvtB Clamp = Clamp cvtB Mirror = Mirror cvtB Wrap = Wrap @@ -543,12 +483,12 @@ embedPreAcc config embedAcc elimAcc pacc -- directly on the delayed representation. See also: [Representing -- delayed arrays] -- - fuse :: (forall aenv'. Extend ArrayR acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs) + fuse :: (forall aenv'. Extend ArrayR acc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) -> acc aenv as -> Embed acc aenv bs fuse op (embedAcc -> Embed env cc) = Embed env (op env cc) - fuse2 :: (forall aenv'. Extend ArrayR acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs -> Cunctation acc aenv' cs) + fuse2 :: (forall aenv'. Extend ArrayR acc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs -> Cunctation aenv' cs) -> acc aenv as -> acc aenv bs -> Embed acc aenv cs @@ -709,10 +649,10 @@ embedSeq embedAcc s 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 :: Elt t => Exp aenv' t -> Exp aenv' t cvtE = simplify - cvtF :: PreFun acc aenv' t -> PreFun acc aenv' t + cvtF :: Fun aenv' t -> Fun aenv' t cvtF = simplify cvtA :: Arrays a => acc aenv' a -> acc aenv' a @@ -771,7 +711,7 @@ data ExtendProducer acc aenv senv arrs where -- data Embed acc aenv a where Embed :: Extend ArrayR acc aenv aenv' - -> Cunctation acc aenv' a + -> Cunctation aenv' a -> Embed acc aenv a instance HasArraysRepr acc => HasArraysRepr (Embed acc) where @@ -785,23 +725,23 @@ instance HasArraysRepr acc => HasArraysRepr (Embed acc) where -- element at each index, and fusing successive producers by combining these -- scalar functions. -- -data Cunctation acc aenv a where +data Cunctation 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'. -- - Done :: ArrayVars aenv arrs - -> Cunctation acc aenv arrs + Done :: ArrayVars aenv arrs + -> Cunctation aenv arrs -- We can represent an array by its shape and a function to compute an element -- at each index. -- Yield :: ArrayR (Array sh e) - -> PreExp acc aenv sh - -> PreFun acc aenv (sh -> e) - -> Cunctation acc aenv (Array sh e) + -> Exp aenv sh + -> Fun aenv (sh -> e) + -> Cunctation 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 @@ -810,13 +750,13 @@ data Cunctation acc aenv a where -- it is always possible to embed into a collective operation. -- Step :: ArrayR (Array sh' b) - -> PreExp acc aenv sh' - -> PreFun acc aenv (sh' -> sh) - -> PreFun acc aenv (a -> b) - -> ArrayVar aenv (Array sh a) - -> Cunctation acc aenv (Array sh' b) + -> Exp aenv sh' + -> Fun aenv (sh' -> sh) + -> Fun aenv (a -> b) + -> ArrayVar aenv (Array sh a) + -> Cunctation aenv (Array sh' b) -instance Kit acc => Simplify (Cunctation acc aenv a) where +instance Simplify (Cunctation aenv a) where simplify = \case Done v -> Done v Yield repr (simplify -> sh) (simplify -> f) -> Yield repr sh f @@ -826,7 +766,7 @@ instance Kit acc => Simplify (Cunctation acc aenv a) where , Just Refl <- isIdentity f -> Done $ VarsSingle v | otherwise -> Step repr sh p f v -instance HasArraysRepr (Cunctation acc) where +instance HasArraysRepr Cunctation where arraysRepr (Done v) = varsType v arraysRepr (Yield repr _ _) = TupRsingle repr arraysRepr (Step repr _ _ _ _) = TupRsingle repr @@ -839,14 +779,13 @@ done pacc | otherwise = case declareVars (arraysRepr pacc) of DeclareVars lhs _ value -> Embed (PushEnv BaseEnv lhs $ inject pacc) $ Done $ value weakenId -doneZeroIdx :: ArrayR (Array sh e) -> Cunctation acc (aenv, Array sh e) (Array sh e) +doneZeroIdx :: ArrayR (Array sh e) -> Cunctation (aenv, Array sh e) (Array sh e) doneZeroIdx repr = Done $ VarsSingle $ Var repr 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 :: Cunctation aenv (Array sh e) + -> Cunctation aenv (Array sh e) yield cc = case cc of Yield{} -> cc @@ -858,9 +797,8 @@ yield cc = -- 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 :: Cunctation aenv (Array sh e) + -> Maybe (Cunctation aenv (Array sh e)) step cc = case cc of Yield{} -> Nothing @@ -871,7 +809,7 @@ step cc = -- Get the shape of a delayed array -- -shape :: Kit acc => Cunctation acc aenv (Array sh e) -> PreExp acc aenv sh +shape :: Cunctation aenv (Array sh e) -> Exp aenv sh shape cc | Just (Step _ sh _ _ _) <- step cc = sh | Yield _ sh _ <- yield cc = sh @@ -880,7 +818,7 @@ shape cc -- Environment manipulation -- ======================== -instance Kit acc => Sink (Cunctation acc) where +instance Sink Cunctation where weaken k = \case Done v -> Done (weaken k v) Step repr sh p f v -> Step repr (weaken k sh) (weaken k p) (weaken k f) (weaken k v) @@ -957,25 +895,28 @@ computeAcc (Embed env@(PushEnv bot lhs top) cc) = -> case ix of ZeroIdx | LeftHandSideSingle ArrayR{} <- lhs - , Just g <- strengthen noTop f -> bindA bot (inject (Map (arrayRtype repr) g top)) - _ -> bindA env (inject (Map (arrayRtype repr) f (avarIn v))) + , Just (OpenAccFun g) <- strengthen noTop (OpenAccFun f) + -> bindA bot (inject (Map (arrayRtype repr) g top)) + _ -> bindA env (inject (Map (arrayRtype repr) f (avarIn v))) | Just Refl <- isIdentity f -> case ix of ZeroIdx | LeftHandSideSingle ArrayR{} <- lhs - , Just q <- strengthen noTop p - , Just sz <- strengthen noTop sh -> bindA bot (inject (Backpermute (arrayRshape repr) sz q top)) - _ -> bindA env (inject (Backpermute (arrayRshape repr) sh p (avarIn v))) + , Just (OpenAccFun q) <- strengthen noTop (OpenAccFun p) + , Just (OpenAccExp sz) <- strengthen noTop (OpenAccExp sh) + -> bindA bot (inject (Backpermute (arrayRshape repr) sz q top)) + _ -> bindA env (inject (Backpermute (arrayRshape repr) sh p (avarIn v))) | otherwise -> case ix of ZeroIdx | LeftHandSideSingle ArrayR{} <- lhs - , Just g <- strengthen noTop f - , Just q <- strengthen noTop p - , Just sz <- strengthen noTop sh -> bindA bot (inject (Transform repr sz q g top)) - _ -> bindA env (inject (Transform repr sh p f (avarIn v))) + , Just (OpenAccFun g) <- strengthen noTop (OpenAccFun f) + , Just (OpenAccFun q) <- strengthen noTop (OpenAccFun p) + , Just (OpenAccExp sz) <- strengthen noTop (OpenAccExp sh) + -> bindA bot (inject (Transform repr sz q g top)) + _ -> bindA env (inject (Transform repr sh p f (avarIn v))) where bindA :: Kit acc @@ -999,7 +940,7 @@ computeAcc (Embed env@(PushEnv bot lhs top) cc) = -- Convert the internal representation of delayed arrays into a real AST -- node. Use the most specific version of a combinator whenever possible. -- -compute :: Kit acc => Cunctation acc aenv arrs -> PreOpenAcc acc aenv arrs +compute :: Kit acc => Cunctation aenv arrs -> PreOpenAcc acc aenv arrs compute cc = case simplify cc of Done VarsNil -> Anil Done (VarsSingle v@(Var ArrayR{} _)) -> Avar v @@ -1015,8 +956,8 @@ compute cc = case simplify cc of -- Representation of a generator as a delayed array -- generateD :: ArrayR (Array sh e) - -> PreExp acc aenv sh - -> PreFun acc aenv (sh -> e) + -> Exp aenv sh + -> Fun aenv (sh -> e) -> Embed acc aenv (Array sh e) generateD repr sh f = Stats.ruleFired "generateD" @@ -1028,7 +969,7 @@ generateD repr sh f -- mapD :: Kit acc => TupleType b - -> PreFun acc aenv (a -> b) + -> Fun aenv (a -> b) -> Embed acc aenv (Array sh a) -> Embed acc aenv (Array sh b) mapD tp f (unzipD tp f -> Just a) = a @@ -1046,7 +987,7 @@ mapD tp f (Embed env cc) unzipD :: Kit acc => TupleType b - -> PreFun acc aenv (a -> b) + -> Fun aenv (a -> b) -> Embed acc aenv (Array sh a) -> Maybe (Embed acc aenv (Array sh b)) unzipD tp f (Embed env cc@(Done v)) @@ -1062,12 +1003,11 @@ unzipD _ _ _ -- the destination array read there data from in the source array. -- backpermuteD - :: Kit acc - => ShapeR sh' - -> PreExp acc aenv sh' - -> PreFun acc aenv (sh' -> sh) - -> Cunctation acc aenv (Array sh e) - -> Cunctation acc aenv (Array sh' e) + :: ShapeR sh' + -> Exp aenv sh' + -> Fun aenv (sh' -> sh) + -> Cunctation aenv (Array sh e) + -> Cunctation aenv (Array sh' e) backpermuteD shr' sh' p = Stats.ruleFired "backpermuteD" . go where go (step -> Just (Step (ArrayR _ tp) _ q f v)) = Step (ArrayR shr' tp) sh' (q `compose` p) f v @@ -1079,9 +1019,9 @@ backpermuteD shr' sh' p = Stats.ruleFired "backpermuteD" . go transformD :: Kit acc => ArrayR (Array sh' b) - -> PreExp acc aenv sh' - -> PreFun acc aenv (sh' -> sh) - -> PreFun acc aenv (a -> b) + -> Exp aenv sh' + -> Fun aenv (sh' -> sh) + -> Fun aenv (a -> b) -> Embed acc aenv (Array sh a) -> Embed acc aenv (Array sh' b) transformD (ArrayR shr' tp) sh' p f @@ -1089,7 +1029,7 @@ transformD (ArrayR shr' tp) sh' p f . fuse (into2 (backpermuteD shr') sh' p) . mapD tp f where - fuse :: (forall aenv'. Extend ArrayR acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs) + fuse :: (forall aenv'. Extend ArrayR acc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) -> Embed acc aenv as -> Embed acc aenv bs fuse op (Embed env cc) = Embed env (op env cc) @@ -1106,11 +1046,10 @@ transformD (ArrayR shr' tp) sh' p f -- expensive and/or `sh` is large. -- replicateD - :: Kit acc - => SliceIndex slix sl co sh - -> PreExp acc aenv slix - -> Cunctation acc aenv (Array sl e) - -> Cunctation acc aenv (Array sh e) + :: SliceIndex slix sl co sh + -> Exp aenv slix + -> Cunctation aenv (Array sl e) + -> Cunctation aenv (Array sh e) replicateD sliceIndex slix cc = Stats.ruleFired "replicateD" $ backpermuteD (sliceDomainR sliceIndex) (IndexFull sliceIndex slix (shape cc)) (extend sliceIndex slix) cc @@ -1119,11 +1058,10 @@ replicateD sliceIndex slix cc -- Dimensional slice as a backwards permutation -- sliceD - :: Kit acc - => SliceIndex slix sl co sh - -> PreExp acc aenv slix - -> Cunctation acc aenv (Array sh e) - -> Cunctation acc aenv (Array sl e) + :: SliceIndex slix sl co sh + -> Exp aenv slix + -> Cunctation aenv (Array sh e) + -> Cunctation aenv (Array sl e) sliceD sliceIndex slix cc = Stats.ruleFired "sliceD" $ backpermuteD (sliceShapeR sliceIndex) (IndexSlice sliceIndex slix (shape cc)) (restrict sliceIndex slix) cc @@ -1143,7 +1081,7 @@ reshapeD :: Kit acc => ShapeR sl -> Embed acc aenv (Array sh e) - -> PreExp acc aenv sl + -> Exp aenv sl -> Embed acc aenv (Array sl e) reshapeD slr (Embed env cc) (sinkA env -> sl) | Done v <- cc @@ -1161,12 +1099,11 @@ reshapeD slr (Embed env cc) (sinkA env -> sl) -- Combine two arrays element-wise with a binary function to produce a delayed -- array. -- -zipWithD :: Kit acc - => TupleType 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 :: TupleType c + -> Fun aenv (a -> b -> c) + -> Cunctation aenv (Array sh a) + -> Cunctation aenv (Array sh b) + -> Cunctation aenv (Array sh c) zipWithD tp f cc1 cc0 -- Two stepper functions identically accessing the same array can be kept in -- stepping form. This might yield a simpler final term. @@ -1187,11 +1124,11 @@ zipWithD tp f cc1 cc0 $ Yield (ArrayR shr tp) (mkIntersect shr sh1 sh0) (combine f f1 f0) where - combine :: forall acc aenv a b c e. Kit acc - => PreFun acc aenv (a -> b -> c) - -> PreFun acc aenv (e -> a) - -> PreFun acc aenv (e -> b) - -> PreFun acc aenv (e -> c) + combine :: forall aenv a b c e. + Fun aenv (a -> b -> c) + -> Fun aenv (e -> a) + -> Fun aenv (e -> b) + -> Fun aenv (e -> c) combine c ixa ixb | Lam lhs1 (Body ixa') <- ixa -- else the skolem 'e' will escape , Lam lhs2 (Body ixb') <- ixb @@ -1378,7 +1315,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en -- eliminate :: forall aenv aenv' sh e brrs. Extend ArrayR acc aenv aenv' - -> Cunctation acc aenv' (Array sh e) + -> Cunctation aenv' (Array sh e) -> acc (aenv', Array sh e) brrs -> Embed acc aenv brrs eliminate env1 cc1 body @@ -1390,7 +1327,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en bnd :: PreOpenAcc acc aenv' (Array sh e) bnd = compute cc1 - elim :: ArrayR (Array sh e) -> PreExp acc aenv' sh -> PreFun acc aenv' (sh -> e) -> Embed acc aenv brrs + elim :: ArrayR (Array sh e) -> Exp aenv' sh -> Fun aenv' (sh -> e) -> Embed acc aenv brrs elim r sh1 f1 | sh1' <- weaken (weakenSucc' weakenId) sh1 , f1' <- weaken (weakenSucc' weakenId) f1 @@ -1407,9 +1344,9 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en -- things, but that is limited in what it looks for. -- replaceE :: forall env aenv sh e t. - PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> ArrayVar aenv (Array sh e) - -> PreOpenExp acc env aenv t - -> PreOpenExp acc env aenv t + OpenExp env aenv sh -> OpenFun env aenv (sh -> e) -> ArrayVar aenv (Array sh e) + -> OpenExp env aenv t + -> OpenExp env aenv t replaceE sh' f' avar@(Var (ArrayR shr _) _) exp = case exp of Let lhs x y -> let k = weakenWithLHS lhs @@ -1432,16 +1369,16 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en Coerce t1 t2 e -> Coerce t1 t2 (cvtE e) Shape a - | Just Refl <- match a a' -> Stats.substitution "replaceE/shape" sh' + | Just Refl <- match a avar -> Stats.substitution "replaceE/shape" sh' | otherwise -> exp Index a sh - | Just Refl <- match a a' + | Just Refl <- match a avar , Lam lhs (Body b) <- f' -> Stats.substitution "replaceE/!" . cvtE $ Let lhs sh b | otherwise -> Index a (cvtE sh) LinearIndex a i - | Just Refl <- match a a' + | Just Refl <- match a avar , Lam lhs (Body b) <- f' -> Stats.substitution "replaceE/!!" . cvtE $ Let lhs @@ -1450,16 +1387,13 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en | 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 :: OpenExp env aenv s -> OpenExp env aenv s cvtE = replaceE sh' f' avar replaceF :: forall env aenv sh e t. - PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> e) -> ArrayVar aenv (Array sh e) - -> PreOpenFun acc env aenv t - -> PreOpenFun acc env aenv t + OpenExp env aenv sh -> OpenFun env aenv (sh -> e) -> ArrayVar aenv (Array sh e) + -> OpenFun env aenv t + -> OpenFun env aenv t replaceF sh' f' avar fun = case fun of Body e -> Body (replaceE sh' f' avar e) @@ -1467,7 +1401,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en in Lam lhs (replaceF (weakenE k sh') (weakenE k f') avar f) replaceA :: forall aenv sh e a. - PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> ArrayVar aenv (Array sh e) + Exp aenv sh -> Fun aenv (sh -> e) -> ArrayVar aenv (Array sh e) -> PreOpenAcc acc aenv a -> PreOpenAcc acc aenv a replaceA sh' f' avar pacc = @@ -1520,13 +1454,13 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en cvtA :: acc aenv s -> acc aenv s cvtA = kmap (replaceA sh' f' avar) - cvtE :: PreExp acc aenv s -> PreExp acc aenv s + cvtE :: Exp aenv s -> Exp aenv s cvtE = replaceE sh' f' avar - cvtF :: PreFun acc aenv s -> PreFun acc aenv s + cvtF :: Fun aenv s -> Fun aenv s cvtF = replaceF sh' f' avar - cvtB :: PreBoundary acc aenv s -> PreBoundary acc aenv s + cvtB :: Boundary aenv s -> Boundary aenv s cvtB Clamp = Clamp cvtB Mirror = Mirror cvtB Wrap = Wrap @@ -1537,7 +1471,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en cvtAF = cvt sh' f' avar where cvt :: forall aenv a. - PreExp acc aenv sh -> PreFun acc aenv (sh -> e) -> ArrayVar aenv (Array sh e) + Exp aenv sh -> Fun aenv (sh -> e) -> ArrayVar 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 @@ -1601,7 +1535,7 @@ aletD' _ _ lhs (Embed env1 cc1) (Embed env0 cc0) -- acondD :: Kit acc => EmbedAcc acc - -> PreExp acc aenv Bool + -> Exp aenv Bool -> acc aenv arrs -> acc aenv arrs -> Embed acc aenv arrs @@ -1616,53 +1550,50 @@ acondD embedAcc p t e -- Scalar expressions -- ------------------ -identity :: TupleType a -> PreOpenFun acc env aenv (a -> a) +identity :: TupleType a -> OpenFun env aenv (a -> a) identity tp | DeclareVars lhs _ value <- declareVars tp = Lam lhs $ Body $ evars $ value weakenId -toIndex :: Kit acc => ShapeR sh -> PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (sh -> Int) +toIndex :: ShapeR sh -> OpenExp env aenv sh -> OpenFun env aenv (sh -> Int) toIndex shr sh | DeclareVars lhs k value <- declareVars $ shapeType shr = Lam lhs $ Body $ ToIndex shr (weakenE k sh) $ evars $ value weakenId -fromIndex :: Kit acc => ShapeR sh -> PreOpenExp acc env aenv sh -> PreOpenFun acc env aenv (Int -> sh) +fromIndex :: ShapeR sh -> OpenExp env aenv sh -> OpenFun env aenv (Int -> sh) fromIndex shr sh = Lam (LeftHandSideSingle scalarTypeInt) $ Body $ FromIndex shr (weakenE (weakenSucc' weakenId) sh) $ Evar $ Var scalarTypeInt ZeroIdx -reindex :: Kit acc - => ShapeR sh' - -> PreOpenExp acc env aenv sh' +reindex :: ShapeR sh' + -> OpenExp env aenv sh' -> ShapeR sh - -> PreOpenExp acc env aenv sh - -> PreOpenFun acc env aenv (sh -> sh') + -> OpenExp env aenv sh + -> OpenFun env aenv (sh -> sh') reindex shr' sh' shr sh | Just Refl <- match sh sh' = identity (shapeType shr') | otherwise = fromIndex shr' sh' `compose` toIndex shr sh -extend :: Kit acc - => SliceIndex slix sl co sh - -> PreExp acc aenv slix - -> PreFun acc aenv (sh -> sl) +extend :: SliceIndex slix sl co sh + -> Exp aenv slix + -> Fun aenv (sh -> sl) extend sliceIndex slix | DeclareVars lhs k value <- declareVars $ shapeType $ sliceDomainR sliceIndex = Lam lhs $ Body $ IndexSlice sliceIndex (weakenE k slix) $ evars $ value weakenId -restrict :: Kit acc - => SliceIndex slix sl co sh - -> PreExp acc aenv slix - -> PreFun acc aenv (sl -> sh) +restrict :: SliceIndex slix sl co sh + -> Exp aenv slix + -> Fun aenv (sl -> sh) restrict sliceIndex slix | DeclareVars lhs k value <- declareVars $ shapeType $ sliceShapeR sliceIndex = Lam lhs $ Body $ IndexFull sliceIndex (weakenE k slix) $ evars $ value weakenId -arrayShape :: Kit acc => ArrayVar aenv (Array sh e) -> PreExp acc aenv sh -arrayShape = simplify . Shape . avarIn +arrayShape :: ArrayVar aenv (Array sh e) -> Exp aenv sh +arrayShape = simplify . Shape -indexArray :: Kit acc => ArrayVar aenv (Array sh e) -> PreFun acc aenv (sh -> e) +indexArray :: ArrayVar aenv (Array sh e) -> Fun aenv (sh -> e) indexArray v@(Var (ArrayR shr _) _) | DeclareVars lhs _ value <- declareVars $ shapeType shr - = Lam lhs $ Body $ Index (avarIn v) $ evars $ value weakenId + = Lam lhs $ Body $ Index v $ evars $ value weakenId -linearIndex :: Kit acc => ArrayVar aenv (Array sh e) -> PreFun acc aenv (Int -> e) -linearIndex v = Lam (LeftHandSideSingle scalarTypeInt) $ Body $ LinearIndex (avarIn v) $ Evar $ Var scalarTypeInt ZeroIdx +linearIndex :: ArrayVar aenv (Array sh e) -> Fun aenv (Int -> e) +linearIndex v = Lam (LeftHandSideSingle scalarTypeInt) $ Body $ LinearIndex v $ Evar $ Var scalarTypeInt ZeroIdx diff --git a/src/Data/Array/Accelerate/Trafo/LetSplit.hs b/src/Data/Array/Accelerate/Trafo/LetSplit.hs index 3376090fc..cbb0e2e7b 100644 --- a/src/Data/Array/Accelerate/Trafo/LetSplit.hs +++ b/src/Data/Array/Accelerate/Trafo/LetSplit.hs @@ -16,7 +16,6 @@ module Data.Array.Accelerate.Trafo.LetSplit ( ) where import Prelude hiding ( exp ) -import Data.Array.Accelerate.Array.Representation import Data.Array.Accelerate.AST import Data.Array.Accelerate.Trafo.Base @@ -32,31 +31,31 @@ travA (Apair a1 a2) = inject $ Apair (convertAcc a1) (conver travA Anil = inject $ Anil travA (Apply repr f a) = inject $ Apply repr (convertAfun f) (convertAcc a) travA (Aforeign repr asm f a) = inject $ Aforeign repr asm (convertAfun f) (convertAcc a) -travA (Acond e a1 a2) = inject $ Acond (travE e) (convertAcc a1) (convertAcc a2) +travA (Acond e a1 a2) = inject $ Acond e (convertAcc a1) (convertAcc a2) travA (Awhile c f a) = inject $ Awhile (convertAfun c) (convertAfun f) (convertAcc a) travA (Use repr arr) = inject $ Use repr arr -travA (Unit tp e) = inject $ Unit tp (travE e) -travA (Reshape shr e a) = inject $ Reshape shr (travE e) a -travA (Generate repr e f) = inject $ Generate repr (travE e) (travF f) -travA (Transform repr sh f g a) = inject $ Transform repr (travE sh) (travF f) (travF g) (convertAcc a) -travA (Replicate slix sl a) = inject $ Replicate slix (travE sl) (convertAcc a) -travA (Slice slix a sl) = inject $ Slice slix (convertAcc a) (travE sl) -travA (Map tp f a) = inject $ Map tp (travF f) (convertAcc a) -travA (ZipWith tp f a1 a2) = inject $ ZipWith tp (travF f) (convertAcc a1) (convertAcc a2) -travA (Fold f e a) = inject $ Fold (travF f) (travE e) (convertAcc a) -travA (Fold1 f a) = inject $ Fold1 (travF f) (convertAcc a) -travA (FoldSeg i f e a s) = inject $ FoldSeg i (travF f) (travE e) (convertAcc a) (convertAcc s) -travA (Fold1Seg i f a s) = inject $ Fold1Seg i (travF f) (convertAcc a) (convertAcc s) -travA (Scanl f e a) = inject $ Scanl (travF f) (travE e) (convertAcc a) -travA (Scanl' f e a) = inject $ Scanl' (travF f) (travE e) (convertAcc a) -travA (Scanl1 f a) = inject $ Scanl1 (travF f) (convertAcc a) -travA (Scanr f e a) = inject $ Scanr (travF f) (travE e) (convertAcc a) -travA (Scanr' f e a) = inject $ Scanr' (travF f) (travE e) (convertAcc a) -travA (Scanr1 f a) = inject $ Scanr1 (travF f) (convertAcc a) -travA (Permute f a1 g a2) = inject $ Permute (travF f) (convertAcc a1) (travF g) (convertAcc a2) -travA (Backpermute shr sh f a) = inject $ Backpermute shr (travE sh) (travF f) (convertAcc a) -travA (Stencil s tp f b a) = inject $ Stencil s tp (travF f) (travB b) (convertAcc a) -travA (Stencil2 s1 s2 tp f b1 a1 b2 a2) = inject $ Stencil2 s1 s2 tp (travF f) (travB b1) (convertAcc a1) (travB b2) (convertAcc a2) +travA (Unit tp e) = inject $ Unit tp e +travA (Reshape shr e a) = inject $ Reshape shr e a +travA (Generate repr e f) = inject $ Generate repr e f +travA (Transform repr sh f g a) = inject $ Transform repr sh f g (convertAcc a) +travA (Replicate slix sl a) = inject $ Replicate slix sl (convertAcc a) +travA (Slice slix a sl) = inject $ Slice slix (convertAcc a) sl +travA (Map tp f a) = inject $ Map tp f (convertAcc a) +travA (ZipWith tp f a1 a2) = inject $ ZipWith tp f (convertAcc a1) (convertAcc a2) +travA (Fold f e a) = inject $ Fold f e (convertAcc a) +travA (Fold1 f a) = inject $ Fold1 f (convertAcc a) +travA (FoldSeg i f e a s) = inject $ FoldSeg i f e (convertAcc a) (convertAcc s) +travA (Fold1Seg i f a s) = inject $ Fold1Seg i f (convertAcc a) (convertAcc s) +travA (Scanl f e a) = inject $ Scanl f e (convertAcc a) +travA (Scanl' f e a) = inject $ Scanl' f e (convertAcc a) +travA (Scanl1 f a) = inject $ Scanl1 f (convertAcc a) +travA (Scanr f e a) = inject $ Scanr f e (convertAcc a) +travA (Scanr' f e a) = inject $ Scanr' f e (convertAcc a) +travA (Scanr1 f a) = inject $ Scanr1 f (convertAcc a) +travA (Permute f a1 g a2) = inject $ Permute f (convertAcc a1) g (convertAcc a2) +travA (Backpermute shr sh f a) = inject $ Backpermute shr sh f (convertAcc a) +travA (Stencil s tp f b a) = inject $ Stencil s tp f b (convertAcc a) +travA (Stencil2 s1 s2 tp f b1 a1 b2 a2) = inject $ Stencil2 s1 s2 tp f b1 (convertAcc a1) b2 (convertAcc a2) travBinding :: Kit acc => ALeftHandSide bnd aenv aenv' -> acc aenv bnd -> acc aenv' a -> acc aenv a travBinding (LeftHandSideWildcard _) _ a = a @@ -65,18 +64,6 @@ travBinding lhs@(LeftHandSidePair l1 l2) bnd a = case extract bnd of Just (Apair b1 b2) -> travBinding l1 b1 $ travBinding l2 (weaken (weakenWithLHS l1) b2) a _ -> inject $ Alet lhs bnd a --- XXX: We assume that any Acc contained in an expression is Avar. --- We thus do not have to descend into expressions. --- This isn't yet enforced using the types however. -travE :: PreExp acc aenv t -> PreExp acc aenv t -travE = id - -travF :: PreFun acc aenv t -> PreFun acc aenv t -travF = id - -travB :: PreBoundary acc aenv (Array sh e) -> PreBoundary acc aenv (Array sh e) -travB = id - convertAfun :: Kit acc => PreOpenAfun acc aenv f -> PreOpenAfun acc aenv f convertAfun (Alam lhs f) = Alam lhs $ convertAfun f convertAfun (Abody a) = Abody $ convertAcc a diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index c8fd98b68..5f584d1c3 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -70,8 +70,8 @@ import Data.Array.Accelerate.Array.Representation hiding ((!!)) import Data.Array.Accelerate.Array.Sugar ( Elt, EltRepr, Arrays, ArrRepr, eltType ) import qualified Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc - , PreOpenExp(..), OpenExp, PreExp, Exp - , PreBoundary(..), Boundary + , OpenExp(..), Exp + , Boundary(..) , showPreAccOp, showPreExpOp, expType, HasArraysRepr(..), arraysRepr ) import qualified Data.Array.Accelerate.AST as AST import Data.Array.Accelerate.Debug.Trace as Debug @@ -537,7 +537,7 @@ convertSharingBoundary -> [StableSharingAcc] -> ShapeR sh -> PreBoundary ScopedAcc ScopedExp (Array sh e) - -> AST.PreBoundary AST.OpenAcc aenv (Array sh e) + -> AST.Boundary aenv (Array sh e) convertSharingBoundary config alyt aenv shr = cvt where cvt :: PreBoundary ScopedAcc ScopedExp (Array sh e) -> AST.Boundary aenv (Array sh e) @@ -573,7 +573,7 @@ convertSharingBoundary config alyt aenv shr = cvt convertFun :: Function f => f -> AST.Fun () (EltReprFunctionR f) convertFun = convertFunWith - $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing, float_out_acc] } + $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing] } convertFunWith :: Function f => Config -> f -> AST.Fun () (EltReprFunctionR f) convertFunWith config = convertOpenFun config EmptyLayout @@ -633,7 +633,7 @@ convertSmartFun config tp f convertExp :: Exp e -> AST.Exp () (EltRepr e) convertExp = convertExpWith - $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing, float_out_acc] } + $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing] } convertExpWith :: Config -> Exp e -> AST.Exp () (EltRepr e) convertExpWith config (Exp e) = convertOpenExp config EmptyLayout e @@ -743,9 +743,9 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp While tp p it i -> AST.While (cvtFun1 tp p) (cvtFun1 tp 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) + Index _ a e -> AST.Index (cvtAvar a) (cvt e) + LinearIndex _ a i -> AST.LinearIndex (cvtAvar a) (cvt i) + Shape _ a -> AST.Shape (cvtAvar a) ShapeSize shr e -> AST.ShapeSize shr (cvt e) Foreign repr ff f e -> AST.Foreign repr ff (convertSmartFun config (expType e) f) (cvt e) Coerce t1 t2 e -> AST.Coerce t1 t2 (cvt e) @@ -760,6 +760,11 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp cvtA :: ScopedAcc a -> AST.OpenAcc aenv a cvtA = convertSharingAcc config alyt aenv + cvtAvar :: ScopedAcc a -> AST.ArrayVar aenv a + cvtAvar a = case cvtA a of + AST.OpenAcc (AST.Avar var) -> var + _ -> $internalError "convertSharingExp" "Expected array computation in expression to be floated out" + cvtFun1 :: TupleType a -> (SmartExp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b) cvtFun1 tp f | DeclareVars lhs k value <- declareVars tp = @@ -2550,7 +2555,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp travA :: (ScopedAcc a -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedAcc a -> (ScopedExp t, NodeCounts) - travA c acc = maybeFloatOutAcc c acc' accCount + travA c acc = floatOutAcc c acc' accCount where (acc', accCount) = scopesAcc acc @@ -2558,20 +2563,19 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp -> UnscopedAcc a -> UnscopedExp b -> (ScopedExp t, NodeCounts) - travAE c acc e = maybeFloatOutAcc (`c` e') acc' (accCountA +++ accCountE) + travAE c acc e = floatOutAcc (`c` e') acc' (accCountA +++ accCountE) where (acc', accCountA) = scopesAcc acc (e' , accCountE) = scopesExp e - maybeFloatOutAcc :: (ScopedAcc a -> PreSmartExp ScopedAcc ScopedExp t) + floatOutAcc :: (ScopedAcc a -> PreSmartExp ScopedAcc ScopedExp t) -> ScopedAcc a -> NodeCounts -> (ScopedExp t, NodeCounts) - maybeFloatOutAcc c acc@(ScopedAcc _ (AvarSharing _ _)) accCount -- nothing to float out + floatOutAcc c acc@(ScopedAcc _ (AvarSharing _ _)) accCount -- nothing to float out = reconstruct (c acc) accCount - maybeFloatOutAcc c acc accCount - | float_out_acc `member` options config = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount) - | otherwise = reconstruct (c acc) accCount + floatOutAcc c acc accCount + = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount) where (var, stableAcc) = abstract acc (\(ScopedAcc _ s) -> s) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 0a5704c68..057b0223d 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -67,10 +67,10 @@ class Shrink f where shrink = snd . shrink' -instance Kit acc => Shrink (PreOpenExp acc env aenv e) where +instance Shrink (OpenExp env aenv e) where shrink' = shrinkExp -instance Kit acc => Shrink (PreOpenFun acc env aenv f) where +instance Shrink (OpenFun env aenv f) where shrink' = shrinkFun data VarsRange env = VarsRange !(Exists (Idx env)) !Int !(Maybe RangeTuple) -- rightmost variable, count, tuple @@ -110,10 +110,10 @@ weakenVarsRange lhs (VarsRange ix n t) = VarsRange (go lhs ix) n t go (LeftHandSideSingle _) (Exists ix') = Exists (SuccIdx ix') go (LeftHandSidePair l1 l2) ix' = go l2 $ go l1 ix' -matchEVarsRange :: VarsRange env -> PreOpenExp acc env aenv t -> Bool +matchEVarsRange :: VarsRange env -> OpenExp env aenv t -> Bool matchEVarsRange (VarsRange (Exists first) _ (Just rt)) expr = isJust $ go (idxToInt first) rt expr where - go :: Int -> RangeTuple -> PreOpenExp acc env aenv t -> Maybe Int + go :: Int -> RangeTuple -> OpenExp env aenv t -> Maybe Int go i RTNil Nil = Just i go i RTSingle (Evar (Var _ ix)) | checkIdx i ix = Just (i + 1) @@ -217,7 +217,7 @@ strengthenShrunkLHS _ _ _ = $inter -- 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 :: OpenExp env aenv t -> (Bool, OpenExp env aenv t) shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE where -- If the bound variable is used at most this many times, it will be inlined @@ -227,7 +227,7 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE lIMIT :: Int lIMIT = 1 - cheap :: PreOpenExp acc env aenv t -> Bool + cheap :: OpenExp env aenv t -> Bool cheap (Evar _) = True cheap (Pair e1 e2) = cheap e1 && cheap e2 cheap Nil = True @@ -237,7 +237,7 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE cheap (Coerce _ _ e) = cheap e cheap _ = False - shrinkE :: Kit acc => PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t) + shrinkE :: OpenExp env aenv t -> (Any, OpenExp env aenv t) shrinkE exp = case exp of Let (LeftHandSideSingle _) bnd@Evar{} body -> Stats.inline "Var" . yes $ shrinkE (inline body bnd) Let lhs bnd body @@ -294,7 +294,7 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE Foreign repr ff f e -> Foreign repr ff <$> shrinkF f <*> shrinkE e Coerce t1 t2 e -> Coerce t1 t2 <$> shrinkE e - shrinkF :: Kit acc => PreOpenFun acc env aenv t -> (Any, PreOpenFun acc env aenv t) + shrinkF :: OpenFun env aenv t -> (Any, OpenFun env aenv t) shrinkF = first Any . shrinkFun first :: (a -> a') -> (a,b) -> (a',b) @@ -303,7 +303,7 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE 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 :: OpenFun env aenv f -> (Bool, OpenFun env aenv f) shrinkFun (Lam lhs f) = case lhsVarsRange lhs of Left Refl -> let b' = case lhs of @@ -409,7 +409,7 @@ shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrinkA" shrinkA shrinkCT (SnocAtup t c) = SnocAtup (shrinkCT t) (shrinkC c) --} - shrinkE :: PreOpenExp acc env aenv' t -> PreOpenExp acc env aenv' t + shrinkE :: OpenExp env aenv' t -> OpenExp env aenv' t shrinkE exp = case exp of Let bnd body -> Let (shrinkE bnd) (shrinkE body) Var idx -> Var idx @@ -439,11 +439,11 @@ shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrinkA" shrinkA 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 :: OpenFun env aenv' f -> OpenFun 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 :: Tuple (OpenExp env aenv') t -> Tuple (OpenExp env aenv') t shrinkT NilTup = NilTup shrinkT (SnocTup t e) = shrinkT t `SnocTup` shrinkE e @@ -457,10 +457,10 @@ shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrinkA" shrinkA -- 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 t. VarsRange env -> PreOpenExp acc env aenv t -> Count +usesOfExp :: forall env aenv t. VarsRange env -> OpenExp env aenv t -> Count usesOfExp range = countE where - countE :: PreOpenExp acc env aenv e -> Count + countE :: OpenExp env aenv e -> Count countE exp | matchEVarsRange range exp = Finite 1 countE exp = case exp of Evar v -> case varInRange range v of @@ -489,7 +489,7 @@ usesOfExp range = countE Foreign _ _ _ e -> countE e Coerce _ _ e -> countE e -usesOfFun :: VarsRange env -> PreOpenFun acc env aenv f -> Count +usesOfFun :: VarsRange env -> OpenFun env aenv f -> Count usesOfFun range (Lam lhs f) = usesOfFun (weakenVarsRange lhs range) f usesOfFun range (Body b) = usesOfExp range b @@ -515,7 +515,7 @@ usesOfPreAcc withShape countAcc idx = count count :: PreOpenAcc acc aenv a -> Int count pacc = case pacc of - Avar (Var _ this) -> countIdx this + Avar var -> countAvar var -- Alet lhs bnd body -> countA bnd + countAcc withShape (weakenWithLHS lhs >:> idx) body Apair a1 a2 -> countA a1 + countA a2 @@ -553,7 +553,7 @@ usesOfPreAcc withShape countAcc idx = count Stencil2 _ _ _ f _ a1 _ a2 -> countF f + countA a1 + countA a2 -- Collect s -> countS s - countE :: PreOpenExp acc env aenv e -> Int + countE :: OpenExp env aenv e -> Int countE exp = case exp of Let _ bnd body -> countE bnd + countE body Evar _ -> 0 @@ -571,11 +571,11 @@ usesOfPreAcc withShape countAcc idx = count 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 + Index a sh -> countAvar a + countE sh + LinearIndex a i -> countAvar a + countE i ShapeSize _ sh -> countE sh Shape a - | withShape -> countA a + | withShape -> countAvar a | otherwise -> 0 Foreign _ _ _ e -> countE e Coerce _ _ e -> countE e @@ -583,13 +583,16 @@ usesOfPreAcc withShape countAcc idx = count countA :: acc aenv a -> Int countA = countAcc withShape idx + countAvar :: ArrayVar aenv a -> Int + countAvar (Var _ this) = countIdx this + countAF :: PreOpenAfun acc aenv' f -> Idx aenv' s -> Int countAF (Alam lhs f) v = countAF f (weakenWithLHS lhs >:> v) countAF (Abody a) v = countAcc withShape v a - countF :: PreOpenFun acc env aenv f -> Int + countF :: OpenFun env aenv f -> Int countF (Lam _ f) = countF f countF (Body b) = countE b diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index df797bebd..c92701e05 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -52,10 +52,10 @@ import qualified Data.Array.Accelerate.Debug.Trace as Debug class Simplify f where simplify :: f -> f -instance Kit acc => Simplify (PreFun acc aenv f) where +instance Simplify (Fun aenv f) where simplify = simplifyFun -instance Kit acc => Simplify (PreExp acc aenv e) where +instance Simplify (Exp aenv e) where simplify = simplifyExp @@ -86,9 +86,9 @@ instance Kit acc => Simplify (PreExp acc aenv e) where -- 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) + -> OpenExp env aenv a + -> OpenExp (env,a) aenv b + -> Maybe (OpenExp env aenv b) localCSE env bnd body | Just ix <- lookupExp env bnd = Stats.ruleFired "CSE" . Just $ inline body (Var ix) | otherwise = Nothing @@ -102,8 +102,8 @@ localCSE env bnd body -- globalCSE :: (Kit acc, Elt t) => Gamma acc env env aenv - -> PreOpenExp acc env aenv t - -> Maybe (PreOpenExp acc env aenv t) + -> OpenExp env aenv t + -> Maybe (OpenExp env aenv t) globalCSE env exp | Just ix <- lookupExp env exp = Stats.ruleFired "CSE" . Just $ Var ix | otherwise = Nothing @@ -140,9 +140,9 @@ globalCSE env exp 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) + -> OpenExp env aenv a + -> OpenExp (env,a) aenv b + -> Maybe (OpenExp env aenv b) recoverLoops _ bnd e3 -- To introduce scaler loops, we look for expressions of the form: -- @@ -177,15 +177,15 @@ recoverLoops _ bnd e3 = Nothing where - plus :: PreOpenExp acc env aenv Int -> PreOpenExp acc env aenv Int -> PreOpenExp acc env aenv Int + plus :: OpenExp env aenv Int -> OpenExp env aenv Int -> OpenExp env aenv Int plus x y = PrimApp (PrimAdd numType) $ Tuple $ NilTup `SnocTup` x `SnocTup` y - constant :: Int -> PreOpenExp acc env aenv Int + constant :: Int -> OpenExp env aenv Int constant i = Const ((),i) matchEnvTop :: (Elt s, Elt t) - => PreOpenExp acc (env,s) aenv f - -> PreOpenExp acc (env,t) aenv g + => OpenExp (env,s) aenv f + -> OpenExp (env,t) aenv g -> Maybe (s :=: t) matchEnvTop _ _ = gcast Refl --} @@ -203,13 +203,13 @@ recoverLoops _ bnd e3 -- Eg, for `let x = -y in -x`, the inlining would allow us to shorten it to `y`. -- If we do not want to do inlining, we should remove the environment here. simplifyOpenExp - :: forall acc env aenv e. (Kit acc) - => Gamma acc env env aenv - -> PreOpenExp acc env aenv e - -> (Bool, PreOpenExp acc env aenv e) + :: forall env aenv e. + Gamma env env aenv + -> OpenExp env aenv e + -> (Bool, OpenExp env aenv e) simplifyOpenExp env = first getAny . cvtE where - cvtE :: PreOpenExp acc env aenv t -> (Any, PreOpenExp acc env aenv t) + cvtE :: OpenExp env aenv t -> (Any, OpenExp env aenv t) cvtE exp = case exp of Let lhs bnd body -> (u <> v, exp') where @@ -240,13 +240,13 @@ simplifyOpenExp env = first getAny . cvtE While p f x -> While <$> cvtF env p <*> cvtF env f <*> cvtE x Coerce t1 t2 e -> Coerce t1 t2 <$> cvtE e - cvtE' :: Gamma acc env' env' aenv -> PreOpenExp acc env' aenv e' -> (Any, PreOpenExp acc env' aenv e') + cvtE' :: Gamma env' env' aenv -> OpenExp env' aenv e' -> (Any, OpenExp 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 :: Gamma env' env' aenv -> OpenFun env' aenv f -> (Any, OpenFun env' aenv f) cvtF env' = first Any . simplifyOpenFun env' - cvtLet :: Gamma acc env' env' aenv -> ELeftHandSide bnd env' env'' -> PreOpenExp acc env' aenv bnd -> (Gamma acc env'' env'' aenv -> (Any, PreOpenExp acc env'' aenv t)) -> (Any, PreOpenExp acc env' aenv t) + cvtLet :: Gamma env' env' aenv -> ELeftHandSide bnd env' env'' -> OpenExp env' aenv bnd -> (Gamma env'' env'' aenv -> (Any, OpenExp env'' aenv t)) -> (Any, OpenExp env' aenv t) cvtLet env' lhs@(LeftHandSideSingle _) bnd body = Let lhs bnd <$> body (incExp $ env' `pushExp` bnd) -- Single variable on the LHS, add binding to the environment cvtLet env' (LeftHandSideWildcard _) _ body = body env' -- Binding not used, remove let binding cvtLet env' (LeftHandSidePair l1 l2) (Pair e1 e2) body = -- Split binding to multiple bindings @@ -259,10 +259,10 @@ simplifyOpenExp env = first getAny . cvtE -- when the predicate is a known constant. -- cond :: forall 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) + (Any, OpenExp env aenv Bool) + -> (Any, OpenExp env aenv t) + -> (Any, OpenExp env aenv t) + -> (Any, OpenExp 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') @@ -272,23 +272,22 @@ simplifyOpenExp env = first getAny . cvtE -- Shape manipulations -- - shape :: forall sh t. acc aenv (Array sh t) -> (Any, PreOpenExp acc env aenv sh) - shape a - | ArrayR ShapeRz _ <- arrayRepr a + shape :: forall sh t. ArrayVar aenv (Array sh t) -> (Any, OpenExp env aenv sh) + shape (Var (ArrayR ShapeRz _) _) = Stats.ruleFired "shape/Z" $ yes Nil shape a = pure $ Shape a - shapeSize :: forall sh. ShapeR sh -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) + shapeSize :: forall sh. ShapeR sh -> (Any, OpenExp env aenv sh) -> (Any, OpenExp env aenv Int) shapeSize shr (_, extractConstTuple -> Just c) = Stats.ruleFired "shapeSize/const" $ yes (Const scalarTypeInt (product (shapeToList shr c))) shapeSize shr sh = ShapeSize shr <$> sh - toIndex :: forall sh. ShapeR sh -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) + toIndex :: forall sh. ShapeR sh -> (Any, OpenExp env aenv sh) -> (Any, OpenExp env aenv sh) -> (Any, OpenExp env aenv Int) toIndex _ (_,sh) (_,FromIndex _ sh' ix) | Just Refl <- match sh sh' = Stats.ruleFired "toIndex/fromIndex" $ yes ix toIndex shr sh ix = ToIndex shr <$> sh <*> ix - fromIndex :: forall sh. ShapeR sh -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) -> (Any, PreOpenExp acc env aenv sh) + fromIndex :: forall sh. ShapeR sh -> (Any, OpenExp env aenv sh) -> (Any, OpenExp env aenv Int) -> (Any, OpenExp env aenv sh) fromIndex _ (_,sh) (_,ToIndex _ sh' ix) | Just Refl <- match sh sh' = Stats.ruleFired "fromIndex/toIndex" $ yes ix fromIndex shr sh ix = FromIndex shr <$> sh <*> ix @@ -299,7 +298,7 @@ simplifyOpenExp env = first getAny . cvtE yes :: x -> (Any, x) yes x = (Any True, x) -extractConstTuple :: PreOpenExp acc env aenv t -> Maybe t +extractConstTuple :: OpenExp env aenv t -> Maybe t extractConstTuple Nil = Just () extractConstTuple (Pair e1 e2) = (,) <$> extractConstTuple e1 <*> extractConstTuple e2 extractConstTuple (Const _ c) = Just c @@ -308,16 +307,15 @@ extractConstTuple _ = Nothing -- Simplification for open functions -- simplifyOpenFun - :: Kit acc - => Gamma acc env env aenv - -> PreOpenFun acc env aenv f - -> (Bool, PreOpenFun acc env aenv f) + :: Gamma env env aenv + -> OpenFun env aenv f + -> (Bool, OpenFun env aenv f) simplifyOpenFun env (Body e) = Body <$> simplifyOpenExp env e simplifyOpenFun env (Lam lhs f) = Lam lhs <$> simplifyOpenFun env' f where env' = lhsExpr lhs env -lhsExpr :: Kit acc => ELeftHandSide t env env' -> Gamma acc env env aenv -> Gamma acc env' env' aenv +lhsExpr :: ELeftHandSide t env env' -> Gamma env env aenv -> Gamma env' env' aenv lhsExpr (LeftHandSideWildcard _) env = env lhsExpr (LeftHandSideSingle tp) env = incExp env `pushExp` Evar (Var tp ZeroIdx) lhsExpr (LeftHandSidePair l1 l2) env = lhsExpr l2 $ lhsExpr l1 env @@ -325,10 +323,10 @@ lhsExpr (LeftHandSidePair l1 l2) env = lhsExpr l2 $ lhsExpr l1 env -- Simplify closed expressions and functions. The process is applied -- repeatedly until no more changes are made. -- -simplifyExp :: Kit acc => PreExp acc aenv t -> PreExp acc aenv t +simplifyExp :: Exp aenv t -> Exp aenv t simplifyExp = iterate summariseOpenExp (simplifyOpenExp EmptyExp) -simplifyFun :: Kit acc => PreFun acc aenv f -> PreFun acc aenv f +simplifyFun :: Fun aenv f -> Fun aenv f simplifyFun = iterate summariseOpenFun (simplifyOpenFun EmptyExp) @@ -428,19 +426,19 @@ ops = lens _ops (\Stats{..} v -> Stats { _ops = v, ..}) {-# INLINE vars #-} {-# INLINE ops #-} -summariseOpenFun :: PreOpenFun acc env aenv f -> Stats +summariseOpenFun :: OpenFun 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 :: OpenExp env aenv t -> Stats summariseOpenExp = (terms +~ 1) . goE where zero = Stats 0 0 0 0 0 - travE :: PreOpenExp acc env aenv t -> Stats + travE :: OpenExp env aenv t -> Stats travE = summariseOpenExp - travF :: PreOpenFun acc env aenv t -> Stats + travF :: OpenFun env aenv t -> Stats travF = summariseOpenFun travA :: acc aenv a -> Stats @@ -484,7 +482,7 @@ summariseOpenExp = (terms +~ 1) . goE -- travVectorType (Vector16Type t) = travSingleType t & types +~ 1 -- The scrutinee has already been counted - goE :: PreOpenExp acc env aenv t -> Stats + goE :: OpenExp env aenv t -> Stats goE exp = case exp of Let _ bnd body -> travE bnd +++ travE body & binders +~ 1 diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 747919789..1f3869c50 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -6,6 +6,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} @@ -36,6 +37,7 @@ module Data.Array.Accelerate.Trafo.Substitution ( -- ** Rebuilding terms RebuildAcc, Rebuildable(..), RebuildableAcc, RebuildableExp(..), rebuildWeakenVar, rebuildLHS, + OpenAccFun(..), OpenAccExp(..), -- ** Checks isIdentity, isIdentityIndexing, extractExpVars, @@ -51,6 +53,7 @@ import Prelude hiding ( exp, seq ) import Data.Array.Accelerate.AST import Data.Array.Accelerate.Array.Representation import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Error import qualified Data.Array.Accelerate.Debug.Stats as Stats @@ -98,33 +101,31 @@ bindingIsTrivial lhs vars , Just Refl <- matchVars vars lhsVars = Just Refl bindingIsTrivial _ _ = Nothing -isIdentity :: PreOpenFun acc env aenv (a -> b) -> Maybe (a :~: b) +isIdentity :: OpenFun env aenv (a -> b) -> Maybe (a :~: b) isIdentity (Lam lhs (Body (extractExpVars -> Just vars))) = bindingIsTrivial lhs vars isIdentity _ = Nothing -- Detects whether the function is of the form \ix -> a ! ix -isIdentityIndexing :: PreOpenFun acc env aenv (a -> b) -> Maybe (acc aenv (Array a b)) +isIdentityIndexing :: OpenFun env aenv (a -> b) -> Maybe (ArrayVar aenv (Array a b)) isIdentityIndexing (Lam lhs (Body body)) - | Index a ix <- body + | Index avar ix <- body , Just vars <- extractExpVars ix - , Just Refl <- bindingIsTrivial lhs vars = Just a + , Just Refl <- bindingIsTrivial lhs vars = Just avar isIdentityIndexing _ = Nothing -- | 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 :: OpenExp (env, s) aenv t + -> OpenExp env aenv s + -> OpenExp env aenv t inline f g = Stats.substitution "inline" $ rebuildE (subTop g) f -inlineVars :: forall acc env env' aenv t1 t2. - RebuildableAcc acc - => ELeftHandSide t1 env env' - -> PreOpenExp acc env' aenv t2 - -> PreOpenExp acc env aenv t1 - -> Maybe (PreOpenExp acc env aenv t2) +inlineVars :: forall env env' aenv t1 t2. + ELeftHandSide t1 env env' + -> OpenExp env' aenv t2 + -> OpenExp env aenv t1 + -> Maybe (OpenExp env aenv t2) inlineVars lhsBound expr bound | Just vars <- lhsFullVars lhsBound = substitute (strengthenWithLHS lhsBound) weakenId vars expr where @@ -132,8 +133,8 @@ inlineVars lhsBound expr bound env1 :?> env2 -> env :> env2 -> ExpVars env1 t1 - -> PreOpenExp acc env1 aenv t - -> Maybe (PreOpenExp acc env2 aenv t) + -> OpenExp env1 aenv t + -> Maybe (OpenExp env2 aenv t) substitute _ k2 vars (extractExpVars -> Just vars') | Just Refl <- matchVars vars vars' = Just $ weakenE k2 bound substitute k1 k2 vars e = case e of @@ -163,18 +164,18 @@ inlineVars lhsBound expr bound Coerce t1 t2 e1 -> Coerce t1 t2 <$> travE e1 where - travE :: PreOpenExp acc env1 aenv s -> Maybe (PreOpenExp acc env2 aenv s) + travE :: OpenExp env1 aenv s -> Maybe (OpenExp env2 aenv s) travE = substitute k1 k2 vars - travF :: PreOpenFun acc env1 aenv s -> Maybe (PreOpenFun acc env2 aenv s) + travF :: OpenFun env1 aenv s -> Maybe (OpenFun env2 aenv s) travF = substituteF k1 k2 vars substituteF :: forall env1 env2 t. env1 :?> env2 -> env :> env2 -> ExpVars env1 t1 - -> PreOpenFun acc env1 aenv t - -> Maybe (PreOpenFun acc env2 aenv t) + -> OpenFun env1 aenv t + -> Maybe (OpenFun env2 aenv t) substituteF k1 k2 vars (Body e) = Body <$> substitute k1 k2 vars e substituteF k1 k2 vars (Lam lhs f) | Exists lhs' <- rebuildLHS lhs = Lam lhs' <$> substituteF (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weaken` vars) f @@ -185,33 +186,30 @@ inlineVars _ _ _ = Nothing -- | 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 - => PreOpenExp acc (env, b) aenv c - -> PreOpenExp acc (env, a) aenv b - -> PreOpenExp acc (env, a) aenv c +{- substitute' :: OpenExp (env, b) aenv c + -> OpenExp (env, a) aenv b + -> OpenExp (env, a) aenv c substitute' f g | Stats.substitution "substitute" False = undefined | isIdentity f = g -- don't rebind an identity function | isIdentity g = f | otherwise = Let g $ rebuildE split f where - split :: Idx (env,b) c -> PreOpenExp acc ((env,a),b) aenv c + split :: Idx (env,b) c -> OpenExp ((env,a),b) aenv c split ZeroIdx = Var ZeroIdx split (SuccIdx ix) = Var (SuccIdx (SuccIdx ix)) -substitute :: RebuildableAcc acc - => LeftHandSide b env envb - -> PreOpenExp acc envb c +substitute :: LeftHandSide b env envb + -> OpenExp envb c -> LeftHandSide a env enva - -> PreOpenExp acc enva b + -> OpenExp enva b -} -- | Composition of unary functions. -- -compose :: RebuildableAcc acc - => PreOpenFun acc env aenv (b -> c) - -> PreOpenFun acc env aenv (a -> b) - -> PreOpenFun acc env aenv (a -> c) +compose :: OpenFun env aenv (b -> c) + -> OpenFun env aenv (a -> b) + -> OpenFun env aenv (a -> c) compose f@(Lam lhsB (Body c)) g@(Lam lhsA (Body b)) | Stats.substitution "compose" False = undefined | Just Refl <- isIdentity f = g -- don't rebind an identity function @@ -222,7 +220,7 @@ compose f@(Lam lhsB (Body c)) g@(Lam lhsA (Body b)) -- = Stats.substitution "compose" . Lam lhs2 . Body $ substitute' f g compose _ _ = error "compose: impossible evaluation" -subTop :: PreOpenExp acc env aenv s -> ExpVar (env, s) t -> PreOpenExp acc env aenv t +subTop :: OpenExp env aenv s -> ExpVar (env, s) t -> OpenExp env aenv t subTop s (Var _ ZeroIdx ) = s subTop _ (Var tp (SuccIdx ix)) = Evar $ Var tp ix @@ -265,13 +263,13 @@ class Rebuildable f where class RebuildableExp f where {-# MINIMAL rebuildPartialE #-} rebuildPartialE :: (Applicative f', SyntacticExp fe) - => (forall e'. ExpVar env e' -> f' (fe (AccClo (f env)) env' aenv e')) - -> f env aenv e + => (forall e'. ExpVar env e' -> f' (fe env' aenv e')) + -> f env aenv e -> f' (f env' aenv e) {-# INLINEABLE rebuildE #-} rebuildE :: SyntacticExp fe - => (forall e'. ExpVar env e' -> fe (AccClo (f env)) env' aenv e') + => (forall e'. ExpVar env e' -> fe env' aenv e') -> f env aenv e -> f env' aenv e rebuildE v = runIdentity . rebuildPartialE (Identity . v) @@ -280,17 +278,25 @@ class RebuildableExp f where -- type RebuildableAcc acc = (Rebuildable acc, AccClo acc ~ acc) +-- Wrappers which add the 'acc' type argument +-- +data OpenAccExp (acc :: Type -> Type -> Type) env aenv a where + OpenAccExp :: { unOpenAccExp :: OpenExp env aenv a } -> OpenAccExp acc env aenv a + +data OpenAccFun (acc :: Type -> Type -> Type) env aenv a where + OpenAccFun :: { unOpenAccFun :: OpenFun env aenv a } -> OpenAccFun acc env aenv a + -- 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 +instance Rebuildable (OpenAccExp acc env) where + type AccClo (OpenAccExp acc env) = acc {-# INLINEABLE rebuildPartial #-} - rebuildPartial x = Stats.substitution "rebuild" $ rebuildPreOpenExp rebuildPartial (pure . IE) x + rebuildPartial v (OpenAccExp e) = OpenAccExp <$> Stats.substitution "rebuild" (rebuildOpenExp (pure . IE) (reindexAvar v) e) -instance RebuildableAcc acc => Rebuildable (PreOpenFun acc env) where - type AccClo (PreOpenFun acc env) = acc +instance Rebuildable (OpenAccFun acc env) where + type AccClo (OpenAccFun acc env) = acc {-# INLINEABLE rebuildPartial #-} - rebuildPartial x = Stats.substitution "rebuild" $ rebuildFun rebuildPartial (pure . IE) x + rebuildPartial v (OpenAccFun f) = OpenAccFun <$> Stats.substitution "rebuild" (rebuildFun (pure . IE) (reindexAvar v) f) instance RebuildableAcc acc => Rebuildable (PreOpenAcc acc) where type AccClo (PreOpenAcc acc) = acc @@ -307,13 +313,13 @@ instance Rebuildable OpenAcc where {-# INLINEABLE rebuildPartial #-} rebuildPartial x = Stats.substitution "rebuild" $ rebuildOpenAcc x -instance RebuildableAcc acc => RebuildableExp (PreOpenExp acc) where +instance RebuildableExp OpenExp where {-# INLINEABLE rebuildPartialE #-} - rebuildPartialE v x = Stats.substitution "rebuild" $ rebuildPreOpenExp rebuildPartial v (pure . IA) x + rebuildPartialE v x = Stats.substitution "rebuild" $ rebuildOpenExp v (ReindexAvar pure) x -instance RebuildableAcc acc => RebuildableExp (PreOpenFun acc) where +instance RebuildableExp OpenFun where {-# INLINEABLE rebuildPartialE #-} - rebuildPartialE v x = Stats.substitution "rebuild" $ rebuildFun rebuildPartial v (pure . IA) x + rebuildPartialE v x = Stats.substitution "rebuild" $ rebuildFun v (ReindexAvar pure) x -- NOTE: [Weakening] -- @@ -359,7 +365,7 @@ instance Sink (Vars s) where rebuildWeakenVar :: env :> env' -> ArrayVar env (Array sh e) -> PreOpenAcc acc env' (Array sh e) rebuildWeakenVar k (Var s idx) = Avar $ Var s $ k >:> idx -rebuildWeakenEvar :: env :> env' -> ExpVar env t -> PreOpenExp acc env' aenv t +rebuildWeakenEvar :: env :> env' -> ExpVar env t -> OpenExp env' aenv t rebuildWeakenEvar k (Var s idx) = Evar $ Var s $ k >:> idx instance RebuildableAcc acc => Sink (PreOpenAcc acc) where @@ -370,15 +376,15 @@ instance RebuildableAcc acc => Sink (PreOpenAfun acc) where {-# INLINEABLE weaken #-} weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) -instance RebuildableAcc acc => Sink (PreOpenExp acc env) where +instance Sink (OpenExp env) where {-# INLINEABLE weaken #-} - weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) + weaken k = Stats.substitution "weaken" . runIdentity . rebuildOpenExp (Identity . Evar) (ReindexAvar (Identity . weaken k)) -instance RebuildableAcc acc => Sink (PreOpenFun acc env) where +instance Sink (OpenFun env) where {-# INLINEABLE weaken #-} - weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) + weaken k = Stats.substitution "weaken" . runIdentity . rebuildFun (Identity . Evar) (ReindexAvar (Identity . weaken k)) -instance RebuildableAcc acc => Sink (PreBoundary acc) where +instance Sink Boundary where {-# INLINEABLE weaken #-} weaken k bndy = case bndy of @@ -408,11 +414,11 @@ class SinkExp f where -- 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 +instance SinkExp OpenExp where {-# INLINEABLE weakenE #-} weakenE v = Stats.substitution "weakenE" . rebuildE (rebuildWeakenEvar v) -instance RebuildableAcc acc => SinkExp (PreOpenFun acc) where +instance SinkExp OpenFun where {-# INLINEABLE weakenE #-} weakenE v = Stats.substitution "weakenE" . rebuildE (rebuildWeakenEvar v) @@ -467,57 +473,51 @@ strengthenAfter _ _ _ = error "Substitution.strengthenAfter: left hand sides do -- SEE: [Weakening] -- class SyntacticExp f where - varIn :: ExpVar env t -> f acc env aenv t - expOut :: f acc env aenv t -> PreOpenExp acc env aenv t - weakenExp :: RebuildAcc acc -> f acc env aenv t -> f acc (env, s) aenv t - -- weakenExpAcc :: RebuildAcc acc -> f acc env aenv t -> f acc env (aenv, s) t + varIn :: ExpVar env t -> f env aenv t + expOut :: f env aenv t -> OpenExp env aenv t + weakenExp :: f env aenv t -> f (env, s) aenv t -newtype IdxE (acc :: Type -> Type -> Type) env aenv t = IE { unIE :: ExpVar env t } +newtype IdxE env aenv t = IE { unIE :: ExpVar env t } instance SyntacticExp IdxE where varIn = IE expOut = Evar . unIE - weakenExp _ (IE (Var tp ix)) = IE $ Var tp $ SuccIdx ix - -- weakenExpAcc _ = IE . unIE + weakenExp (IE (Var tp ix)) = IE $ Var tp $ SuccIdx ix -instance SyntacticExp PreOpenExp where +instance SyntacticExp OpenExp where varIn = Evar expOut = id - weakenExp k = runIdentity . rebuildPreOpenExp k (Identity . weakenExp k . IE) (Identity . IA) - -- weakenExpAcc k = runIdentity . rebuildPreOpenExp k (Identity . IE) (Identity . weakenAcc k . IA) + weakenExp = runIdentity . rebuildOpenExp (Identity . weakenExp . IE) (ReindexAvar Identity) {-# INLINEABLE shiftE #-} shiftE :: (Applicative f, SyntacticExp fe) - => RebuildAcc acc - -> RebuildEvar f fe acc env env' aenv - -> RebuildEvar f fe acc (env, s) (env', s) aenv -shiftE _ _ (Var tp ZeroIdx) = pure $ varIn (Var tp ZeroIdx) -shiftE k v (Var tp (SuccIdx ix)) = weakenExp k <$> v (Var tp ix) + => RebuildEvar f fe env env' aenv + -> RebuildEvar f fe (env, s) (env', s) aenv +shiftE _ (Var tp ZeroIdx) = pure $ varIn (Var tp ZeroIdx) +shiftE v (Var tp (SuccIdx ix)) = weakenExp <$> v (Var tp ix) {-# INLINEABLE shiftE' #-} shiftE' :: (Applicative f, SyntacticExp fa) => ELeftHandSide t env1 env1' -> ELeftHandSide t env2 env2' - -> RebuildAcc acc - -> RebuildEvar f fa acc env1 env2 aenv - -> RebuildEvar f fa acc env1' env2' aenv -shiftE' (LeftHandSideWildcard _) (LeftHandSideWildcard _) _ v = v -shiftE' (LeftHandSideSingle _) (LeftHandSideSingle _) k v = shiftE k v -shiftE' (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k v = shiftE' b1 b2 k $ shiftE' a1 a2 k v -shiftE' _ _ _ _ = error "Substitution: left hand sides do not match" + -> RebuildEvar f fa env1 env2 aenv + -> RebuildEvar f fa env1' env2' aenv +shiftE' (LeftHandSideWildcard _) (LeftHandSideWildcard _) v = v +shiftE' (LeftHandSideSingle _) (LeftHandSideSingle _) v = shiftE v +shiftE' (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) v = shiftE' b1 b2 $ shiftE' a1 a2 v +shiftE' _ _ _ = error "Substitution: left hand sides do not match" -{-# INLINEABLE rebuildPreOpenExp #-} -rebuildPreOpenExp - :: (Applicative f, SyntacticExp fe, SyntacticAcc fa) - => RebuildAcc acc - -> RebuildEvar f fe acc env env' aenv' - -> RebuildAvar f fa acc aenv aenv' - -> PreOpenExp acc env aenv t - -> f (PreOpenExp acc env' aenv' t) -rebuildPreOpenExp k v av exp = +{-# INLINEABLE rebuildOpenExp #-} +rebuildOpenExp + :: (Applicative f, SyntacticExp fe) + => RebuildEvar f fe env env' aenv' + -> ReindexAvar f aenv aenv' + -> OpenExp env aenv t + -> f (OpenExp env' aenv' t) +rebuildOpenExp v av@(ReindexAvar reindex) exp = case exp of Const t c -> pure $ Const t c PrimConst c -> pure $ PrimConst c @@ -525,39 +525,38 @@ rebuildPreOpenExp k v av exp = Evar var -> expOut <$> v var Let lhs a b | Exists lhs' <- rebuildLHS lhs - -> Let lhs' <$> rebuildPreOpenExp k v av a <*> rebuildPreOpenExp k (shiftE' lhs lhs' k v) av b - Pair e1 e2 -> Pair <$> rebuildPreOpenExp k v av e1 <*> rebuildPreOpenExp k v av e2 + -> Let lhs' <$> rebuildOpenExp v av a <*> rebuildOpenExp (shiftE' lhs lhs' v) av b + Pair e1 e2 -> Pair <$> rebuildOpenExp v av e1 <*> rebuildOpenExp v av e2 Nil -> pure $ Nil - VecPack vec e -> VecPack vec <$> rebuildPreOpenExp k v av e - VecUnpack vec e -> VecUnpack vec <$> rebuildPreOpenExp k v av e - 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 shr sh ix -> ToIndex shr <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av ix - FromIndex shr sh ix -> FromIndex shr <$> 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 shr sh -> ShapeSize shr <$> rebuildPreOpenExp k v av sh - Foreign tp ff f e -> Foreign tp ff f <$> rebuildPreOpenExp k v av e - Coerce t1 t2 e -> Coerce t1 t2 <$> rebuildPreOpenExp k v av e + VecPack vec e -> VecPack vec <$> rebuildOpenExp v av e + VecUnpack vec e -> VecUnpack vec <$> rebuildOpenExp v av e + IndexSlice x ix sh -> IndexSlice x <$> rebuildOpenExp v av ix <*> rebuildOpenExp v av sh + IndexFull x ix sl -> IndexFull x <$> rebuildOpenExp v av ix <*> rebuildOpenExp v av sl + ToIndex shr sh ix -> ToIndex shr <$> rebuildOpenExp v av sh <*> rebuildOpenExp v av ix + FromIndex shr sh ix -> FromIndex shr <$> rebuildOpenExp v av sh <*> rebuildOpenExp v av ix + Cond p t e -> Cond <$> rebuildOpenExp v av p <*> rebuildOpenExp v av t <*> rebuildOpenExp v av e + While p f x -> While <$> rebuildFun v av p <*> rebuildFun v av f <*> rebuildOpenExp v av x + PrimApp f x -> PrimApp f <$> rebuildOpenExp v av x + Index a sh -> Index <$> reindex a <*> rebuildOpenExp v av sh + LinearIndex a i -> LinearIndex <$> reindex a <*> rebuildOpenExp v av i + Shape a -> Shape <$> reindex a + ShapeSize shr sh -> ShapeSize shr <$> rebuildOpenExp v av sh + Foreign tp ff f e -> Foreign tp ff f <$> rebuildOpenExp v av e + Coerce t1 t2 e -> Coerce t1 t2 <$> rebuildOpenExp v av e {-# INLINEABLE rebuildFun #-} rebuildFun - :: (Applicative f, SyntacticExp fe, SyntacticAcc fa) - => RebuildAcc acc - -> RebuildEvar f fe acc env env' aenv' - -> RebuildAvar f fa acc aenv aenv' - -> PreOpenFun acc env aenv t - -> f (PreOpenFun acc env' aenv' t) -rebuildFun k v av fun = + :: (Applicative f, SyntacticExp fe) + => RebuildEvar f fe env env' aenv' + -> ReindexAvar f aenv aenv' + -> OpenFun env aenv t + -> f (OpenFun env' aenv' t) +rebuildFun v av fun = case fun of - Body e -> Body <$> rebuildPreOpenExp k v av e + Body e -> Body <$> rebuildOpenExp v av e Lam lhs f | Exists lhs' <- rebuildLHS lhs - -> Lam lhs' <$> rebuildFun k (shiftE' lhs lhs' k v) av f + -> Lam lhs' <$> rebuildFun (shiftE' lhs lhs' v) av f -- The array environment -- ----------------- @@ -588,16 +587,33 @@ instance SyntacticAcc PreOpenAcc where type RebuildAvar f (fa :: (Type -> Type -> Type) -> Type -> Type -> Type) acc aenv aenv' = forall sh e. ArrayVar aenv (Array sh e) -> f (fa acc aenv' (Array sh e)) -type RebuildEvar f fe (acc :: Type -> Type -> Type) env env' aenv' = - forall t'. ExpVar env t' -> f (fe acc env' aenv' t') +type RebuildEvar f fe env env' aenv' = + forall t'. ExpVar env t' -> f (fe env' aenv' t') + +newtype ReindexAvar f aenv aenv' = + ReindexAvar (forall sh e. ArrayVar aenv (Array sh e) -> f (ArrayVar aenv' (Array sh e))) + +reindexAvar + :: forall f fa acc aenv aenv'. + (Applicative f, SyntacticAcc fa) + => RebuildAvar f fa acc aenv aenv' + -> ReindexAvar f aenv aenv' +reindexAvar v = ReindexAvar f where + f :: forall sh e. ArrayVar aenv (Array sh e) -> f (ArrayVar aenv' (Array sh e)) + f var = g <$> v var + + g fa = case accOut fa of + Avar var' -> var' + _ -> $internalError "reindexAvar" "An Avar which was used in an Exp was mapped to an array term other than Avar. This mapping is invalid as an Exp can only contain array variables." + {-# INLINEABLE shiftA #-} shiftA :: (Applicative f, SyntacticAcc fa) => RebuildAcc acc -> RebuildAvar f fa acc aenv aenv' - -> ArrayVar (aenv, s) (Array sh e) - -> f (fa acc (aenv', s) (Array sh e)) + -> ArrayVar (aenv, s) (Array sh e) + -> f (fa acc (aenv', s) (Array sh e)) shiftA _ _ (Var s ZeroIdx) = pure $ avarIn $ Var s ZeroIdx shiftA k v (Var s (SuccIdx ix)) = weakenAcc k <$> v (Var s ix) @@ -636,32 +652,34 @@ rebuildPreOpenAcc k av acc = Apair as bs -> Apair <$> k av as <*> k av bs Anil -> pure Anil Apply repr f a -> Apply repr <$> rebuildAfun k av f <*> k av a - Acond p t e -> Acond <$> rebuildPreOpenExp k (pure . IE) av p <*> k av t <*> k av e + Acond p t e -> Acond <$> rebuildOpenExp (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 tp e -> Unit tp <$> rebuildPreOpenExp k (pure . IE) av e - Reshape shr e a -> Reshape shr <$> rebuildPreOpenExp k (pure . IE) av e <*> k av a - Generate repr e f -> Generate repr <$> rebuildPreOpenExp k (pure . IE) av e <*> rebuildFun k (pure . IE) av f - Transform repr sh ix f a -> Transform repr <$> 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 tp f a -> Map tp <$> rebuildFun k (pure . IE) av f <*> k av a - ZipWith tp f a1 a2 -> ZipWith tp <$> 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 itp f z a s -> FoldSeg itp <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a <*> k av s - Fold1Seg itp f a s -> Fold1Seg itp <$> 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 shr sh f a -> Backpermute shr <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av f <*> k av a - Stencil sr tp f b a -> Stencil sr tp <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b <*> k av a - Stencil2 s1 s2 tp f b1 a1 b2 a2 -> Stencil2 s1 s2 tp <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b1 <*> k av a1 <*> rebuildBoundary k av b2 <*> k av a2 + Unit tp e -> Unit tp <$> rebuildOpenExp (pure . IE) av' e + Reshape shr e a -> Reshape shr <$> rebuildOpenExp (pure . IE) av' e <*> k av a + Generate repr e f -> Generate repr <$> rebuildOpenExp (pure . IE) av' e <*> rebuildFun (pure . IE) av' f + Transform repr sh ix f a -> Transform repr <$> rebuildOpenExp (pure . IE) av' sh <*> rebuildFun (pure . IE) av' ix <*> rebuildFun (pure . IE) av' f <*> k av a + Replicate sl slix a -> Replicate sl <$> rebuildOpenExp (pure . IE) av' slix <*> k av a + Slice sl a slix -> Slice sl <$> k av a <*> rebuildOpenExp (pure . IE) av' slix + Map tp f a -> Map tp <$> rebuildFun (pure . IE) av' f <*> k av a + ZipWith tp f a1 a2 -> ZipWith tp <$> rebuildFun (pure . IE) av' f <*> k av a1 <*> k av a2 + Fold f z a -> Fold <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a + Fold1 f a -> Fold1 <$> rebuildFun (pure . IE) av' f <*> k av a + FoldSeg itp f z a s -> FoldSeg itp <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a <*> k av s + Fold1Seg itp f a s -> Fold1Seg itp <$> rebuildFun (pure . IE) av' f <*> k av a <*> k av s + Scanl f z a -> Scanl <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a + Scanl' f z a -> Scanl' <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a + Scanl1 f a -> Scanl1 <$> rebuildFun (pure . IE) av' f <*> k av a + Scanr f z a -> Scanr <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a + Scanr' f z a -> Scanr' <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a + Scanr1 f a -> Scanr1 <$> rebuildFun (pure . IE) av' f <*> k av a + Permute f1 a1 f2 a2 -> Permute <$> rebuildFun (pure . IE) av' f1 <*> k av a1 <*> rebuildFun (pure . IE) av' f2 <*> k av a2 + Backpermute shr sh f a -> Backpermute shr <$> rebuildOpenExp (pure . IE) av' sh <*> rebuildFun (pure . IE) av' f <*> k av a + Stencil sr tp f b a -> Stencil sr tp <$> rebuildFun (pure . IE) av' f <*> rebuildBoundary av' b <*> k av a + Stencil2 s1 s2 tp f b1 a1 b2 a2 -> Stencil2 s1 s2 tp <$> rebuildFun (pure . IE) av' f <*> rebuildBoundary av' b1 <*> k av a1 <*> rebuildBoundary av' b2 <*> k av a2 -- Collect seq -> Collect <$> rebuildSeq k av seq Aforeign repr ff afun as -> Aforeign repr ff afun <$> k av as + where + av' = reindexAvar av {-# INLINEABLE rebuildAfun #-} rebuildAfun @@ -697,18 +715,17 @@ rebuildLHS (LeftHandSidePair as bs) = case rebuildLHS as of {-# INLINEABLE rebuildBoundary #-} rebuildBoundary - :: (Applicative f, SyntacticAcc fa) - => RebuildAcc acc - -> RebuildAvar f fa acc aenv aenv' - -> PreBoundary acc aenv t - -> f (PreBoundary acc aenv' t) -rebuildBoundary k av bndy = + :: Applicative f + => ReindexAvar f aenv aenv' + -> Boundary aenv t + -> f (Boundary aenv' t) +rebuildBoundary 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 + Function f -> Function <$> rebuildFun (pure . IE) av f {-- {-# INLINEABLE rebuildSeq #-} @@ -737,7 +754,7 @@ rebuildP k v p = 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 + ScanSeq f e x -> ScanSeq <$> rebuildFun (pure . IE) v f <*> rebuildOpenExp (pure . IE) v e <*> pure x {-# INLINEABLE rebuildC #-} rebuildC :: forall acc fa f aenv aenv' senv a. (SyntacticAcc fa, Applicative f) @@ -747,7 +764,7 @@ rebuildC :: forall acc fa f aenv aenv' senv a. (SyntacticAcc fa, Applicative f) -> 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 + FoldSeq f e x -> FoldSeq <$> rebuildFun (pure . IE) v f <*> rebuildOpenExp (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 @@ -756,7 +773,7 @@ rebuildC k v c = rebuildT (SnocAtup t s) = SnocAtup <$> (rebuildT t) <*> (rebuildC k v s) --} -extractExpVars :: PreOpenExp acc env aenv a -> Maybe (ExpVars env a) +extractExpVars :: OpenExp env aenv a -> Maybe (ExpVars env a) extractExpVars Nil = Just VarsNil extractExpVars (Pair e1 e2) = VarsPair <$> extractExpVars e1 <*> extractExpVars e2 extractExpVars (Evar v) = Just $ VarsSingle v From eb10416c98da92e38c54724c3014f54de9d09817 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Mon, 25 May 2020 12:50:04 +0200 Subject: [PATCH 223/316] Fix compile errors on old GHCs and warnings --- src/Data/Array/Accelerate/Analysis/Match.hs | 5 ++--- src/Data/Array/Accelerate/Trafo/Base.hs | 6 +++--- src/Data/Array/Accelerate/Trafo/Substitution.hs | 1 + 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index c64b86e21..1779504e3 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -63,11 +63,10 @@ type MatchAcc acc = forall aenv s t. acc aenv s -> acc aenv t -> Maybe (s :~: t) matchPreOpenAcc :: forall acc aenv s t. HasArraysRepr acc => MatchAcc acc - -> EncodeAcc acc -> PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t -> Maybe (s :~: t) -matchPreOpenAcc matchAcc encodeAcc = match +matchPreOpenAcc matchAcc = match where matchFun :: OpenFun env' aenv' u -> OpenFun env' aenv' v -> Maybe (u :~: v) matchFun = matchOpenFun @@ -915,7 +914,7 @@ matchNonNumType _ _ = Nothing -- commutativity. -- commutes - :: forall acc env aenv a r. + :: forall env aenv a r. PrimFun (a -> r) -> OpenExp env aenv a -> Maybe (OpenExp env aenv a) diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index a161f2017..cfdaef3a5 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -103,7 +103,7 @@ encodeOpenAcc :: EncodeAcc OpenAcc encodeOpenAcc options (OpenAcc pacc) = encodePreOpenAcc options encodeAcc pacc matchOpenAcc :: MatchAcc OpenAcc -matchOpenAcc (OpenAcc pacc1) (OpenAcc pacc2) = matchPreOpenAcc matchAcc encodeAcc pacc1 pacc2 +matchOpenAcc (OpenAcc pacc1) (OpenAcc pacc2) = matchPreOpenAcc matchAcc pacc1 pacc2 avarIn :: forall acc aenv a. Kit acc => ArrayVar aenv a -> acc aenv a avarIn v@(Var ArrayR{} _) = inject $ Avar v @@ -184,7 +184,7 @@ instance Match (OpenFun env aenv) where instance Kit acc => Match (PreOpenAcc acc aenv) where {-# INLINEABLE match #-} - match = matchPreOpenAcc matchAcc encodeAcc + match = matchPreOpenAcc matchAcc instance {-# INCOHERENT #-} Kit acc => Match (acc aenv) where {-# INLINEABLE match #-} @@ -278,7 +278,7 @@ encodeDelayedOpenAcc options acc = {-# INLINEABLE matchDelayedOpenAcc #-} matchDelayedOpenAcc :: MatchAcc DelayedOpenAcc matchDelayedOpenAcc (Manifest pacc1) (Manifest pacc2) - = matchPreOpenAcc matchDelayedOpenAcc encodeDelayedOpenAcc pacc1 pacc2 + = matchPreOpenAcc matchDelayedOpenAcc pacc1 pacc2 matchDelayedOpenAcc (Delayed _ sh1 ix1 lx1) (Delayed _ sh2 ix2 lx2) | Just Refl <- matchOpenExp sh1 sh2 diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 1f3869c50..e20ea4d90 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -602,6 +602,7 @@ reindexAvar v = ReindexAvar f where f :: forall sh e. ArrayVar aenv (Array sh e) -> f (ArrayVar aenv' (Array sh e)) f var = g <$> v var + g :: fa acc aenv' (Array sh e) -> ArrayVar aenv' (Array sh e) g fa = case accOut fa of Avar var' -> var' _ -> $internalError "reindexAvar" "An Avar which was used in an Exp was mapped to an array term other than Avar. This mapping is invalid as an Exp can only contain array variables." From 0e2e37f7d9c456bb352eaada9e4025ef9d886e90 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Mon, 25 May 2020 13:11:43 +0200 Subject: [PATCH 224/316] Fix missing loopCount in While --- src/Data/Array/Accelerate/Trafo/Shrink.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 0a5704c68..c1cd4a2d1 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -479,7 +479,7 @@ usesOfExp range = countE FromIndex _ sh i -> countE sh <> countE i ToIndex _ sh e -> countE sh <> countE e Cond p t e -> countE p <> countE t <> countE e - While p f x -> countE x <> loopCount (usesOfFun range p) <> usesOfFun range f + While p f x -> countE x <> loopCount (usesOfFun range p) <> loopCount (usesOfFun range f) PrimConst _ -> Finite 0 PrimApp _ x -> countE x Index _ sh -> countE sh From 8718f07f943275aca487686172411009b06c49ca Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 2 Jun 2020 11:34:33 +0200 Subject: [PATCH 225/316] use bash shell on all platforms --- .github/workflows/ci.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 15411df2a..18643ef85 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -7,6 +7,10 @@ on: # but only for the master branch # branches: [master] +defaults: + run: + shell: bash + jobs: stack: name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} From 9aa2b5a1fbb9df9d430b88f49ea52daa31b7a299 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 2 Jun 2020 12:00:25 +0200 Subject: [PATCH 226/316] maybe ghc-8.8 works on windows under bash? --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 18643ef85..576205854 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -30,7 +30,7 @@ jobs: ghc: 8.8 allow_failure: false - os: windows-latest - ghc: 8.6 + ghc: 8.8 allow_failure: true env: STACK_FLAGS: "--system-ghc --no-install-ghc --fast --flag accelerate:nofib" From 345c4fb4e0fb0b02ce7601f8984e62e28d47d3b7 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 2 Jun 2020 14:53:08 +0200 Subject: [PATCH 227/316] nope --- .github/workflows/ci.yml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 576205854..7154e666b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -29,9 +29,12 @@ jobs: - os: macOS-latest ghc: 8.8 allow_failure: false + # ghc-8.8 currently doesn't work on the windows test machines due to a + # 32-bit linker problem, failing with the error: + # Access violation in generated code when writing 0x0 - os: windows-latest - ghc: 8.8 - allow_failure: true + ghc: 8.6 + allow_failure: false env: STACK_FLAGS: "--system-ghc --no-install-ghc --fast --flag accelerate:nofib" From 3ec3d2270efd8e2092b685a1c67b0adb3b90cf65 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 4 Jun 2020 15:28:43 +0200 Subject: [PATCH 228/316] stack/8.8: update resolver --- stack-8.8.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-8.8.yaml b/stack-8.8.yaml index 7a07b5e36..529de0274 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-15.4 +resolver: lts-15.15 packages: - . From 0f5d7316f96cae64940aafe0ef8f2d8ff6b699a0 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 4 Jun 2020 19:26:06 +0200 Subject: [PATCH 229/316] git mv -> icebox --- {src/Data/Array/Accelerate/Array => icebox}/Lifted.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) rename {src/Data/Array/Accelerate/Array => icebox}/Lifted.hs (99%) diff --git a/src/Data/Array/Accelerate/Array/Lifted.hs b/icebox/Lifted.hs similarity index 99% rename from src/Data/Array/Accelerate/Array/Lifted.hs rename to icebox/Lifted.hs index 957e4695b..c43a2a88c 100644 --- a/src/Data/Array/Accelerate/Array/Lifted.hs +++ b/icebox/Lifted.hs @@ -54,7 +54,7 @@ type family LiftedRepr r a where LiftedRepr (Array sh e) (Array sh e) = (((),Segments sh), Vector e) LiftedRepr (l,r) a = LiftedTupleRepr (TupleRepr a) -type family LiftedTupleRepr t :: * +type family LiftedTupleRepr t :: Type type instance LiftedTupleRepr () = () type instance LiftedTupleRepr (b, a) = (LiftedTupleRepr b, Vector' a) From e936d0bf323008c345ce3209fe2fc6944477914a Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 4 Jun 2020 21:01:44 +0200 Subject: [PATCH 230/316] minor formatting --- accelerate.cabal | 8 +- src/Data/Array/Accelerate/AST.hs | 5 +- src/Data/Array/Accelerate/Analysis/Match.hs | 24 ++- src/Data/Array/Accelerate/Analysis/Stencil.hs | 3 +- src/Data/Array/Accelerate/Array/Data.hs | 38 ++--- src/Data/Array/Accelerate/Array/Remote/LRU.hs | 62 ++++---- .../Array/Accelerate/Array/Remote/Table.hs | 30 ++-- .../Array/Accelerate/Array/Representation.hs | 45 +++--- src/Data/Array/Accelerate/Classes/Bounded.hs | 8 +- src/Data/Array/Accelerate/Classes/Eq.hs | 8 +- src/Data/Array/Accelerate/Classes/Floating.hs | 1 + .../Array/Accelerate/Classes/Fractional.hs | 1 + src/Data/Array/Accelerate/Classes/Integral.hs | 33 ++-- src/Data/Array/Accelerate/Classes/Ord.hs | 8 +- src/Data/Array/Accelerate/Data/Complex.hs | 21 +-- src/Data/Array/Accelerate/Interpreter.hs | 18 +-- src/Data/Array/Accelerate/Language.hs | 14 +- src/Data/Array/Accelerate/Lift.hs | 2 +- src/Data/Array/Accelerate/Orphans.hs | 1 + src/Data/Array/Accelerate/Pattern.hs | 3 +- src/Data/Array/Accelerate/Smart.hs | 7 - src/Data/Array/Accelerate/Trafo/Algebra.hs | 54 ------- src/Data/Array/Accelerate/Trafo/Base.hs | 6 +- src/Data/Array/Accelerate/Trafo/Fusion.hs | 13 +- src/Data/Array/Accelerate/Trafo/LetSplit.hs | 1 + src/Data/Array/Accelerate/Trafo/Sharing.hs | 46 +++--- src/Data/Array/Accelerate/Trafo/Shrink.hs | 49 +++--- src/Data/Array/Accelerate/Trafo/Simplify.hs | 54 ++++--- .../Array/Accelerate/Trafo/Substitution.hs | 143 +++++++++--------- src/Data/Array/Accelerate/Trafo/Vectorise.hs | 2 +- src/Data/Array/Accelerate/Type.hs | 3 +- src/Data/Array/Accelerate/Unsafe.hs | 4 +- 32 files changed, 332 insertions(+), 383 deletions(-) diff --git a/accelerate.cabal b/accelerate.cabal index 29957e9d5..f7a168b8a 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -522,8 +522,8 @@ Library -Wcompat -Wmissed-specialisations -- -Wredundant-constraints - -freduction-depth=50 - -fspec-constr-count=25 + -freduction-depth=100 + -fspec-constr-count=50 -funbox-strict-fields ghc-prof-options: @@ -554,8 +554,8 @@ test-suite doctest -rtsopts x-doctest-options: - -fspec-constr-count=25 - -freduction-depth=50 + -freduction-depth=100 + -fspec-constr-count=50 test-suite nofib-interpreter diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 6e63336dd..704083907 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -254,6 +254,8 @@ lhsToTupR (LeftHandSideSingle s) = TupRsingle s lhsToTupR (LeftHandSideWildcard r) = r lhsToTupR (LeftHandSidePair as bs) = TupRpair (lhsToTupR as) (lhsToTupR bs) +-- TODO: We should move the weakening utilities elsewhere + -- The type of shifting terms from one context into another -- This is defined as a newtype, as a type synonym containing a forall quantifier -- may give issues with impredicative polymorphism which GHC does not support. @@ -1345,7 +1347,7 @@ rnfPreOpenAcc rnfA pacc = 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 shr sh f a -> rnfShapeR shr `seq` rnfE sh `seq` rnfF f `seq` rnfA a - Stencil sr tp f b a -> + Stencil sr tp f b a -> let TupRsingle (ArrayR shr _) = arraysRepr a repr = ArrayR shr $ stencilElt sr @@ -2195,3 +2197,4 @@ showPreExpOp LinearIndex{} = "LinearIndex" showPreExpOp Shape{} = "Shape" showPreExpOp ShapeSize{} = "ShapeSize" showPreExpOp Coerce{} = "Coerce" + diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index 4e280bc57..6c0e8db77 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -44,11 +44,11 @@ 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 -import qualified Data.Array.Accelerate.Array.Sugar as Sugar -import Data.Array.Accelerate.AST import Data.Array.Accelerate.Type +import qualified Data.Array.Accelerate.Array.Sugar as Sugar -- The type of matching array computations @@ -275,13 +275,26 @@ matchPreOpenAfun m (Alam lhs1 s) (Alam lhs2 t) matchPreOpenAfun m (Abody s) (Abody t) = m s t matchPreOpenAfun _ _ _ = Nothing -matchALeftHandSide :: forall aenv aenv1 aenv2 t1 t2. ALeftHandSide t1 aenv aenv1 -> ALeftHandSide t2 aenv aenv2 -> Maybe (ALeftHandSide t1 aenv aenv1 :~: ALeftHandSide t2 aenv aenv2) +matchALeftHandSide + :: forall aenv aenv1 aenv2 t1 t2. + ALeftHandSide t1 aenv aenv1 + -> ALeftHandSide t2 aenv aenv2 + -> Maybe (ALeftHandSide t1 aenv aenv1 :~: ALeftHandSide t2 aenv aenv2) matchALeftHandSide = matchLeftHandSide matchArrayR -matchELeftHandSide :: forall env env1 env2 t1 t2. ELeftHandSide t1 env env1 -> ELeftHandSide t2 env env2 -> Maybe (ELeftHandSide t1 env env1 :~: ELeftHandSide t2 env env2) +matchELeftHandSide + :: forall env env1 env2 t1 t2. + ELeftHandSide t1 env env1 + -> ELeftHandSide t2 env env2 + -> Maybe (ELeftHandSide t1 env env1 :~: ELeftHandSide t2 env env2) matchELeftHandSide = matchLeftHandSide matchScalarType -matchLeftHandSide :: forall s env env1 env2 t1 t2. (forall x y. s x -> s y -> Maybe (x :~: y)) -> LeftHandSide s t1 env env1 -> LeftHandSide s t2 env env2 -> Maybe (LeftHandSide s t1 env env1 :~: LeftHandSide s t2 env env2) +matchLeftHandSide + :: forall s env env1 env2 t1 t2. + (forall x y. s x -> s y -> Maybe (x :~: y)) + -> LeftHandSide s t1 env env1 + -> LeftHandSide s t2 env env2 + -> Maybe (LeftHandSide s t1 env env1 :~: LeftHandSide s t2 env env2) matchLeftHandSide f (LeftHandSideWildcard repr1) (LeftHandSideWildcard repr2) | Just Refl <- matchTupR f repr1 repr2 = Just Refl @@ -406,7 +419,6 @@ matchArray :: ArrayR (Array sh1 e1) matchArray repr1 repr2 (Array _ ad1) (Array _ ad2) | Just Refl <- matchArrayR repr1 repr2 , unsafePerformIO $ do - sn1 <- makeStableName ad1 sn2 <- makeStableName ad2 return $! hashStableName sn1 == hashStableName sn2 diff --git a/src/Data/Array/Accelerate/Analysis/Stencil.hs b/src/Data/Array/Accelerate/Analysis/Stencil.hs index cf465f565..cc9f05c13 100644 --- a/src/Data/Array/Accelerate/Analysis/Stencil.hs +++ b/src/Data/Array/Accelerate/Analysis/Stencil.hs @@ -13,7 +13,8 @@ -- Portability : non-portable (GHC extensions) -- -module Data.Array.Accelerate.Analysis.Stencil (positionsR) where +module Data.Array.Accelerate.Analysis.Stencil ( positionsR ) + where import Data.Array.Accelerate.AST import Data.Array.Accelerate.Array.Representation diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index ba8bafdd0..6f06bbe57 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -125,30 +125,30 @@ type MutableArrayData e = GArrayData e -- representation, but this is now fixed to our UniqueArray type. -- type family GArrayData a where - GArrayData () = () - GArrayData (a, b) = (GArrayData a, GArrayData b) -- XXX: fields of tuple are non-strict, which enables lazy device-host copying - GArrayData a = ScalarData a + GArrayData () = () + GArrayData (a, b) = (GArrayData a, GArrayData b) -- XXX: fields of tuple are non-strict, which enables lazy device-host copying + GArrayData a = ScalarData a type ScalarData a = UniqueArray (ScalarDataRepr a) -- Mapping from scalar type to the type as represented in memory in an array. -- Booleans are stored as Word8, other types are represented as itself. type family ScalarDataRepr tp where - ScalarDataRepr Int = Int - ScalarDataRepr Int8 = Int8 - ScalarDataRepr Int16 = Int16 - ScalarDataRepr Int32 = Int32 - ScalarDataRepr Int64 = Int64 - ScalarDataRepr Word = Word - ScalarDataRepr Word8 = Word8 - ScalarDataRepr Word16 = Word16 - ScalarDataRepr Word32 = Word32 - ScalarDataRepr Word64 = Word64 - ScalarDataRepr Half = Half - ScalarDataRepr Float = Float - ScalarDataRepr Double = Double - ScalarDataRepr Bool = Word8 - ScalarDataRepr Char = Char + ScalarDataRepr Int = Int + ScalarDataRepr Int8 = Int8 + ScalarDataRepr Int16 = Int16 + ScalarDataRepr Int32 = Int32 + ScalarDataRepr Int64 = Int64 + ScalarDataRepr Word = Word + ScalarDataRepr Word8 = Word8 + ScalarDataRepr Word16 = Word16 + ScalarDataRepr Word32 = Word32 + ScalarDataRepr Word64 = Word64 + ScalarDataRepr Half = Half + ScalarDataRepr Float = Float + ScalarDataRepr Double = Double + ScalarDataRepr Bool = Word8 + ScalarDataRepr Char = Char ScalarDataRepr (Vec n tp) = ScalarDataRepr tp -- Utilities for working with the type families & type class instances @@ -197,7 +197,7 @@ unsafeIndexArrayData (TupRsingle (SingleScalarType tp)) arr ix unsafeIndexArrayData !tp !arr !ix = unsafePerformIO $! unsafeReadArrayData tp arr ix ptrOfArrayData :: ScalarType e -> ArrayData e -> Ptr (ScalarDataRepr e) -ptrOfArrayData tp arr +ptrOfArrayData tp arr | (_, ScalarDict) <- scalarDict tp = unsafeUniqueArrayPtr arr touchArrayData :: TupleType e -> ArrayData e -> IO () diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs index 67783ff55..f4b251226 100644 --- a/src/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/src/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -142,32 +142,31 @@ withRemote -> ArrayData a -> (RemotePtr m (ScalarDataRepr a) -> m (task, c)) -> m (Maybe c) -withRemote (MemoryTable !mt !ref _) !tp !arr run - | (ScalarDict, _, _) <- singleDict tp = do - key <- Basic.makeStableArray tp 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 @m mt tp 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) +withRemote (MemoryTable !mt !ref _) !tp !arr run | (ScalarDict, _, _) <- singleDict tp = do + key <- Basic.makeStableArray tp arr + mp <- withMVar' ref $ \utbl -> do + mu <- liftIO . HT.mutate utbl key $ \case + Nothing -> (Nothing, Nothing) + Just u -> (Just (incCount u), Just u) -- - case mp of - Nothing -> return Nothing - Just ptr -> Just <$> go key ptr + 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 @m mt tp 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 tp' weak_arr) task = do @@ -222,12 +221,10 @@ malloc :: forall e m task. (RemoteMemory m, MonadIO m, Task task) => MemoryTable (RemotePtr m) task -> SingleType e -> ArrayData e - -> Bool -- ^ True if host array is frozen. - -> Int -- ^ Number of elements - -> m Bool -- ^ Was the array allocated successfully? -malloc (MemoryTable mt ref weak_utbl) !tp !ad !frozen !n - | (ScalarDict, _, _) <- singleDict tp -- Required for ArrayData e ~ ScalarData e - = do + -> Bool -- ^ True if host array is frozen. + -> Int -- ^ Number of elements + -> m Bool -- ^ Was the array allocated successfully? +malloc (MemoryTable mt ref weak_utbl) !tp !ad !frozen !n | (ScalarDict, _, _) <- singleDict tp = do -- Required for ArrayData e ~ ScalarData e ts <- liftIO $ getCPUTime key <- Basic.makeStableArray tp ad -- @@ -361,8 +358,7 @@ insertUnmanaged -> ArrayData e -> RemotePtr m (ScalarDataRepr e) -> m () -insertUnmanaged (MemoryTable mt ref weak_utbl) !tp !arr !ptr - | (ScalarDict, _, _) <- singleDict tp = do -- Gives evidence that ArrayData e ~ ScalarData e +insertUnmanaged (MemoryTable mt ref weak_utbl) !tp !arr !ptr | (ScalarDict, _, _) <- singleDict tp = do -- Gives evidence that ArrayData e ~ ScalarData e key <- Basic.makeStableArray tp arr () <- Basic.insertUnmanaged mt tp arr ptr liftIO diff --git a/src/Data/Array/Accelerate/Array/Remote/Table.hs b/src/Data/Array/Accelerate/Array/Remote/Table.hs index 1b4116820..7f9fb0dda 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Table.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Table.hs @@ -264,8 +264,7 @@ insert -> RemotePtr m (ScalarDataRepr a) -> Int -> m () -insert mt@(MemoryTable !ref _ _ _) !tp !arr !ptr !bytes - | (ScalarDict, _, _) <- singleDict tp = do +insert mt@(MemoryTable !ref _ _ _) !tp !arr !ptr !bytes | (ScalarDict, _, _) <- singleDict tp = do key <- makeStableArray tp arr weak <- liftIO $ makeWeakArrayData tp arr () (Just $ freeStable @m mt key) message $ "insert: " ++ show key @@ -286,12 +285,11 @@ insertUnmanaged -> ArrayData a -> RemotePtr m (ScalarDataRepr a) -> m () -insertUnmanaged (MemoryTable !ref !weak_ref _ _) tp !arr !ptr - | (ScalarDict, _, _) <- singleDict tp = do - key <- makeStableArray tp arr - weak <- liftIO $ makeWeakArrayData tp arr () (Just $ remoteFinalizer weak_ref key) - message $ "insertUnmanaged: " ++ show key - liftIO $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray (castRemotePtr @m ptr) 0 weak) +insertUnmanaged (MemoryTable !ref !weak_ref _ _) tp !arr !ptr | (ScalarDict, _, _) <- singleDict tp = do + key <- makeStableArray tp arr + weak <- liftIO $ makeWeakArrayData tp arr () (Just $ remoteFinalizer weak_ref key) + message $ "insertUnmanaged: " ++ show key + liftIO $ withMVar ref $ \tbl -> HT.insert tbl key (RemoteArray (castRemotePtr @m ptr) 0 weak) -- Removing entries @@ -364,7 +362,7 @@ makeStableArray !tp !ad -- Weak arrays --- ---------------------- +-- ----------- -- | Make a weak pointer using an array as a key. Unlike the standard `mkWeak`, -- this guarantees finalisers won't fire early. @@ -376,13 +374,12 @@ makeWeakArrayData -> c -> Maybe (IO ()) -> IO (Weak c) -makeWeakArrayData !tp !ad !c !mf - | (ScalarDict, _, _) <- singleDict tp = do - let !uad = uniqueArrayData ad - case mf of - Nothing -> return () - Just f -> addFinalizer uad f - mkWeak uad c +makeWeakArrayData !tp !ad !c !mf | (ScalarDict, _, _) <- singleDict tp = do + let !uad = uniqueArrayData ad + case mf of + Nothing -> return () + Just f -> addFinalizer uad f + mkWeak uad c -- Debug @@ -420,7 +417,6 @@ management msg nrs next = do (showBytes total) -- return r - else next diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index 7c8fdbed4..0ca44e4a0 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -9,7 +9,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} @@ -24,6 +23,7 @@ -- module Data.Array.Accelerate.Array.Representation ( + -- * Array data type in terms of representation types Array(..), ArrayR(..), arraysRarray, arraysRtuple2, arrayRshape, arrayRtype, rnfArray, rnfShape, ArraysR, TupleType, Scalar, Vector, Matrix, fromList, toList, Segments, shape, reshape, concatVectors, @@ -48,6 +48,7 @@ module Data.Array.Accelerate.Array.Representation ( -- * Show showShape, showElement, showArray, showArray', + ) where -- friends @@ -224,13 +225,13 @@ dim2 = ShapeRsnoc dim1 -- |Index representations (which are nested pairs) -- - + data ShapeR sh where - ShapeRz :: ShapeR () + ShapeRz :: ShapeR () ShapeRsnoc :: ShapeR sh -> ShapeR (sh, Int) rank :: ShapeR sh -> Int -rank ShapeRz = 0 +rank ShapeRz = 0 rank (ShapeRsnoc shr) = rank shr + 1 size :: ShapeR sh -> sh -> Int @@ -240,20 +241,20 @@ size (ShapeRsnoc shr) (sh, sz) | otherwise = size shr sh * sz empty :: ShapeR sh -> sh -empty ShapeRz = () +empty ShapeRz = () empty (ShapeRsnoc shr) = (empty shr, 0) ignore :: ShapeR sh -> sh -ignore ShapeRz = () +ignore ShapeRz = () ignore (ShapeRsnoc shr) = (ignore shr, -1) shapeZip :: (Int -> Int -> Int) -> ShapeR sh -> sh -> sh -> sh -shapeZip _ ShapeRz () () = () +shapeZip _ ShapeRz () () = () shapeZip f (ShapeRsnoc shr) (as, a) (bs, b) = (shapeZip f shr as bs, f a b) intersect, union :: ShapeR sh -> sh -> sh -> sh intersect = shapeZip min -union = shapeZip max +union = shapeZip max toIndex :: ShapeR sh -> sh -> sh -> Int toIndex ShapeRz () () = 0 @@ -282,7 +283,7 @@ shapeEq (ShapeRsnoc shr) (sh, i) (sh', i') = i == i' && shapeEq shr sh sh' -- initial value that is combined with the results; the index space -- is traversed in row-major order iter :: ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a -> a -iter ShapeRz () f _ _ = f () +iter ShapeRz () f _ _ = f () iter (ShapeRsnoc shr) (sh, sz) f c r = iter shr sh (\ix -> iter' (ix,0)) c r where iter' (ix,i) | i >= sz = r @@ -290,7 +291,7 @@ iter (ShapeRsnoc shr) (sh, sz) f c r = iter shr sh (\ix -> iter' (ix,0)) c r -- variant of 'iter' without an initial value iter1 :: ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a -iter1 ShapeRz () f _ = f () +iter1 ShapeRz () f _ = f () iter1 (ShapeRsnoc _ ) (_, 0) _ _ = $boundsError "iter1" "empty iteration space" iter1 (ShapeRsnoc shr) (sh, sz) f c = iter1 shr sh (\ix -> iter1' (ix,0)) c where @@ -301,19 +302,19 @@ iter1 (ShapeRsnoc shr) (sh, sz) f c = iter1 shr sh (\ix -> iter1' (ix,0)) c -- convert a minpoint-maxpoint index into a shape rangeToShape :: ShapeR sh -> (sh, sh) -> sh -rangeToShape ShapeRz ((), ()) = () +rangeToShape ShapeRz ((), ()) = () rangeToShape (ShapeRsnoc shr) ((sh1, sz1), (sh2, sz2)) = (rangeToShape shr (sh1, sh2), sz2 - sz1 + 1) -- the converse shapeToRange :: ShapeR sh -> sh -> (sh, sh) -shapeToRange ShapeRz () = ((), ()) +shapeToRange ShapeRz () = ((), ()) shapeToRange (ShapeRsnoc shr) (sh, sz) = let (low, high) = shapeToRange shr sh in ((low, 0), (high, sz - 1)) -- Other conversions -- Convert a shape into its list of dimensions shapeToList :: ShapeR sh -> sh -> [Int] -shapeToList ShapeRz () = [] +shapeToList ShapeRz () = [] shapeToList (ShapeRsnoc shr) (sh,sz) = sz : shapeToList shr sh -- Convert a list of dimensions into a shape @@ -324,12 +325,12 @@ listToShape shr ds = case listToShape' shr ds of -- Attempt to convert a list of dimensions into a shape listToShape' :: ShapeR sh -> [Int] -> Maybe sh -listToShape' ShapeRz [] = Just () +listToShape' ShapeRz [] = Just () listToShape' (ShapeRsnoc shr) (x:xs) = (, x) <$> listToShape' shr xs listToShape' _ _ = Nothing shapeType :: ShapeR sh -> TupleType sh -shapeType ShapeRz = TupRunit +shapeType ShapeRz = TupRunit shapeType (ShapeRsnoc shr) = shapeType shr `TupRpair` (TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType TypeInt) -- |Slice representation @@ -367,10 +368,8 @@ instance Slice sl => Slice (sl, Int) where -- 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) + 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" @@ -509,7 +508,7 @@ stencilHalo = go' go :: StencilR sh e stencil -> sh go = snd . go' - + cons :: ShapeR sh -> Int -> sh -> (sh, Int) cons ShapeRz ix () = ((), ix) cons (ShapeRsnoc shr) ix (sh, sz) = (cons shr ix sh, sz) @@ -518,7 +517,7 @@ rnfArray :: ArrayR a -> a -> () rnfArray (ArrayR shr tp) (Array sh ad) = rnfShape shr sh `seq` rnfArrayData tp ad rnfShape :: ShapeR sh -> sh -> () -rnfShape ShapeRz () = () +rnfShape ShapeRz () = () rnfShape (ShapeRsnoc shr) (sh, s) = s `seq` rnfShape shr sh -- | SIMD Vectors (Vec n t) @@ -529,7 +528,7 @@ rnfShape (ShapeRsnoc shr) (sh, s) = s `seq` rnfShape shr sh -- type (Vec n single) with its tuple representation (tuple). -- Conversions between those types are exposed through vecPack and -- vecUnpack. --- +-- data VecR (n :: Nat) single tuple where VecRnil :: SingleType s -> VecR 0 s () VecRsucc :: VecR n s t -> VecR (n + 1) s (t, s) @@ -677,6 +676,6 @@ showMatrix f tp arr@(Array sh _) in before ++ cell ++ after - reduceRank :: ArrayR (Array (sh, Int) e) -> ArrayR (Array sh e) reduceRank (ArrayR (ShapeRsnoc shr) tp) = ArrayR shr tp + diff --git a/src/Data/Array/Accelerate/Classes/Bounded.hs b/src/Data/Array/Accelerate/Classes/Bounded.hs index 82c31b96a..187cf0150 100644 --- a/src/Data/Array/Accelerate/Classes/Bounded.hs +++ b/src/Data/Array/Accelerate/Classes/Bounded.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Bounded -- Copyright : [2016..2019] The Accelerate Team @@ -135,12 +135,6 @@ instance P.Bounded (Exp CUChar) where minBound = mkBitcast (mkMinBound @Word8) maxBound = mkBitcast (mkMaxBound @Word8) --- To support 16-tuples, we must set the maximum recursion depth of the type --- checker higher. The default is 51, which appears to be a problem for --- 16-tuples (15-tuples do work). Hence we set a compiler flag at the top --- of this file: -freduction-depth=100 --- - $(runQ $ do let mkInstance :: Int -> Q [Dec] diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index c075aa501..1df177519 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Eq -- Copyright : [2016..2019] The Accelerate Team @@ -127,12 +127,6 @@ cond :: Elt t -> Exp t cond (Exp c) (Exp x) (Exp y) = exp $ Cond c x y --- To support 16-tuples, we must set the maximum recursion depth of the type --- checker higher. The default is 51, which appears to be a problem for --- 16-tuples (15-tuples do work). Hence we set a compiler flag at the top --- of this file: -freduction-depth=100 --- - $(runQ $ do let integralTypes :: [Name] diff --git a/src/Data/Array/Accelerate/Classes/Floating.hs b/src/Data/Array/Accelerate/Classes/Floating.hs index 5b451ffb6..a132a7040 100644 --- a/src/Data/Array/Accelerate/Classes/Floating.hs +++ b/src/Data/Array/Accelerate/Classes/Floating.hs @@ -142,3 +142,4 @@ instance P.Floating (Exp CDouble) where log = mkLog (**) = mkFPow logBase = mkLogBase + diff --git a/src/Data/Array/Accelerate/Classes/Fractional.hs b/src/Data/Array/Accelerate/Classes/Fractional.hs index fa159ccd1..b297aa037 100644 --- a/src/Data/Array/Accelerate/Classes/Fractional.hs +++ b/src/Data/Array/Accelerate/Classes/Fractional.hs @@ -69,3 +69,4 @@ instance P.Fractional (Exp CDouble) where (/) = mkFDiv recip = mkRecip fromRational = constant . P.fromRational + diff --git a/src/Data/Array/Accelerate/Classes/Integral.hs b/src/Data/Array/Accelerate/Classes/Integral.hs index 4d6f9e96c..312c9e0cd 100644 --- a/src/Data/Array/Accelerate/Classes/Integral.hs +++ b/src/Data/Array/Accelerate/Classes/Integral.hs @@ -138,8 +138,8 @@ instance P.Integral (Exp CInt) where rem = mkRem div = mkIDiv mod = mkMod - quotRem = mkQuotRem - divMod = mkDivMod + quotRem = mkQuotRem + divMod = mkDivMod toInteger = error "Prelude.toInteger not supported for Accelerate types" instance P.Integral (Exp CUInt) where @@ -147,8 +147,8 @@ instance P.Integral (Exp CUInt) where rem = mkRem div = mkIDiv mod = mkMod - quotRem = mkQuotRem - divMod = mkDivMod + quotRem = mkQuotRem + divMod = mkDivMod toInteger = error "Prelude.toInteger not supported for Accelerate types" instance P.Integral (Exp CLong) where @@ -156,8 +156,8 @@ instance P.Integral (Exp CLong) where rem = mkRem div = mkIDiv mod = mkMod - quotRem = mkQuotRem - divMod = mkDivMod + quotRem = mkQuotRem + divMod = mkDivMod toInteger = error "Prelude.toInteger not supported for Accelerate types" instance P.Integral (Exp CULong) where @@ -165,8 +165,8 @@ instance P.Integral (Exp CULong) where rem = mkRem div = mkIDiv mod = mkMod - quotRem = mkQuotRem - divMod = mkDivMod + quotRem = mkQuotRem + divMod = mkDivMod toInteger = error "Prelude.toInteger not supported for Accelerate types" instance P.Integral (Exp CLLong) where @@ -174,8 +174,8 @@ instance P.Integral (Exp CLLong) where rem = mkRem div = mkIDiv mod = mkMod - quotRem = mkQuotRem - divMod = mkDivMod + quotRem = mkQuotRem + divMod = mkDivMod toInteger = error "Prelude.toInteger not supported for Accelerate types" instance P.Integral (Exp CULLong) where @@ -183,8 +183,8 @@ instance P.Integral (Exp CULLong) where rem = mkRem div = mkIDiv mod = mkMod - quotRem = mkQuotRem - divMod = mkDivMod + quotRem = mkQuotRem + divMod = mkDivMod toInteger = error "Prelude.toInteger not supported for Accelerate types" instance P.Integral (Exp CShort) where @@ -192,8 +192,8 @@ instance P.Integral (Exp CShort) where rem = mkRem div = mkIDiv mod = mkMod - quotRem = mkQuotRem - divMod = mkDivMod + quotRem = mkQuotRem + divMod = mkDivMod toInteger = error "Prelude.toInteger not supported for Accelerate types" instance P.Integral (Exp CUShort) where @@ -201,6 +201,7 @@ instance P.Integral (Exp CUShort) where rem = mkRem div = mkIDiv mod = mkMod - quotRem = mkQuotRem - divMod = mkDivMod + quotRem = mkQuotRem + divMod = mkDivMod toInteger = error "Prelude.toInteger not supported for Accelerate types" + diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index a2b52b1c0..cf97f496e 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Ord -- Copyright : [2016..2019] The Accelerate Team @@ -162,12 +162,6 @@ preludeError x y , "hierarchy." ] --- To support 16-tuples, we must set the maximum recursion depth of the type --- checker higher. The default is 51, which appears to be a problem for --- 16-tuples (15-tuples do work). Hence we set a compiler flag at the top --- of this file: -freduction-depth=100 --- - $(runQ $ do let integralTypes :: [Name] diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index c10b923d9..ce2911bfd 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -54,8 +54,8 @@ import Data.Array.Accelerate.Smart hiding (exp) import Data.Array.Accelerate.Type import Data.Complex ( Complex(..) ) -import qualified Data.Complex as C import Prelude (($)) +import qualified Data.Complex as C import qualified Prelude as P infix 6 ::+ @@ -131,24 +131,24 @@ complexR TupRpair{} constructComplex :: forall a. Elt a => Exp a -> Exp a -> Exp (Complex a) constructComplex r i = case complexR $ eltType @a of - ComplexRvec _ -> + ComplexRvec _ -> let r', i' :: Exp (EltRepr a) - r' = reExp @a @(EltRepr a) r - i' = reExp i + r' = coerce @a @(EltRepr a) r + i' = coerce i v :: Exp (V2 (EltRepr a)) v = V2_ r' i' in - reExp @(V2 (EltRepr a)) @(Complex a) $ v - ComplexRtup -> reExp $ T2 r i + coerce @(V2 (EltRepr a)) @(Complex a) $ v + ComplexRtup -> coerce $ T2 r i deconstructComplex :: forall a. Elt a => Exp (Complex a) -> (Exp a, Exp a) deconstructComplex c = case complexR $ eltType @a of - ComplexRvec _ -> let V2_ r i = reExp @(Complex a) @(V2 (EltRepr a)) c in (reExp r, reExp i) - ComplexRtup -> let T2 r i = reExp c in (r, i) + ComplexRvec _ -> let V2_ r i = coerce @(Complex a) @(V2 (EltRepr a)) c in (coerce r, coerce i) + ComplexRtup -> let T2 r i = coerce c in (r, i) -reExp :: EltRepr a ~ EltRepr b => Exp a -> Exp b -reExp (Exp e) = Exp e +coerce :: EltRepr a ~ EltRepr b => Exp a -> Exp b +coerce (Exp e) = Exp e instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Complex a) where type Plain (Complex a) = Complex (Plain a) @@ -258,6 +258,7 @@ instance (FromIntegral a b, Num b, Elt (Complex b)) => FromIntegral a (Complex b fromIntegral x = fromIntegral x ::+ 0 -- | @since 1.2.0.0 +-- instance Functor Complex where fmap f (r ::+ i) = f r ::+ f i diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index a5bb15e18..1a4344e90 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -72,14 +72,13 @@ import Data.Array.Accelerate.AST hiding ( Bou import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Array.Representation -import qualified Data.Array.Accelerate.Array.Sugar as Sugar import Data.Array.Accelerate.Error 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.Sugar as Sugar import qualified Data.Array.Accelerate.Smart as Smart import qualified Data.Array.Accelerate.Trafo as AST - import qualified Data.Array.Accelerate.Debug as D @@ -359,21 +358,6 @@ zipWithOp zipWithOp tp f (Delayed (ArrayR shr _) shx xs _) (Delayed _ shy ys _) = fromFunction' (ArrayR shr tp) (intersect shr shx 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 :: (e -> e -> e) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index c6bef7c64..f2fd3510c 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1297,7 +1297,7 @@ intersect' :: Repr.ShapeR sh -> SmartExp sh -> SmartExp sh -> SmartExp sh intersect' Repr.ShapeRz _ _ = SmartExp Nil intersect' (Repr.ShapeRsnoc shr) (unPair -> (xs, x)) (unPair -> (ys, y)) = SmartExp - $ intersect' shr xs ys `Pair` + $ intersect' shr xs ys `Pair` SmartExp (PrimApp (PrimMin singleType) $ SmartExp $ Pair x y) @@ -1310,7 +1310,7 @@ union' :: Repr.ShapeR sh -> SmartExp sh -> SmartExp sh -> SmartExp sh union' Repr.ShapeRz _ _ = SmartExp Nil union' (Repr.ShapeRsnoc shr) (unPair -> (xs, x)) (unPair -> (ys, y)) = SmartExp - $ union' shr xs ys `Pair` + $ union' shr xs ys `Pair` SmartExp (PrimApp (PrimMax singleType) $ SmartExp $ Pair x y) @@ -1340,17 +1340,9 @@ while :: forall e. Elt e #if __GLASGOW_HASKELL__ < 804 while c f (Exp e) = exp $ While @SmartAcc @SmartExp @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e #else -while c f (Exp e) = exp $ While @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e +while c f (Exp e) = exp $ While @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e #endif -{- - - While :: TupleType t - -> (SmartExp t -> exp Bool) - -> (SmartExp t -> exp t) - -> exp t - -> PreSmartExp acc exp t - -} -- Array operations with a scalar result -- ------------------------------------- diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 0485bcb3b..663dba18e 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -5,8 +5,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ <= 708 diff --git a/src/Data/Array/Accelerate/Orphans.hs b/src/Data/Array/Accelerate/Orphans.hs index b8905fbec..7d0b8e29f 100644 --- a/src/Data/Array/Accelerate/Orphans.hs +++ b/src/Data/Array/Accelerate/Orphans.hs @@ -17,6 +17,7 @@ module Data.Array.Accelerate.Orphans () where +import Data.Orphans () -- orphan instances for 8-tuples and beyond import Data.Primitive.Types import Data.Ratio import Foreign.C.Types diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index b2aec3891..db9cc145c 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -267,8 +267,9 @@ pattern V8_ a b c d e f g h = Pattern (VecPattern (a, b, c, d, e, f, g, h)) {-# COMPLETE V8_ #-} pattern V16_ :: VecElt a - => Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> + => Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp (Vec 16 a) pattern V16_ a b c d e f g h i j k l m n o p = Pattern (VecPattern (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) {-# COMPLETE V16_ #-} + diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index efbf704ee..2bee6dbf8 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -1829,37 +1829,30 @@ mkPairToTuple e = SmartAcc Anil `pair` a `pair` b class ApplyAcc a where type FromApplyAcc a - applyAcc :: FromApplyAcc a -> a instance ApplyAcc (SmartAcc a) where type FromApplyAcc (SmartAcc a) = PreSmartAcc SmartAcc SmartExp a - applyAcc = SmartAcc instance (Arrays a, ApplyAcc t) => ApplyAcc (Acc a -> t) where type FromApplyAcc (Acc a -> t) = SmartAcc (ArrRepr a) -> FromApplyAcc t - applyAcc f a = applyAcc $ f (unAcc a) instance (Elt a, ApplyAcc t) => ApplyAcc (Exp a -> t) where type FromApplyAcc (Exp a -> t) = SmartExp (EltRepr a) -> FromApplyAcc t - applyAcc f a = applyAcc $ f (unExp a) instance (Elt a, Elt b, ApplyAcc t) => ApplyAcc ((Exp a -> Exp b) -> t) where type FromApplyAcc ((Exp a -> Exp b) -> t) = (SmartExp (EltRepr a) -> SmartExp (EltRepr b)) -> FromApplyAcc t - applyAcc f a = applyAcc $ f (unExpFunction a) instance (Elt a, Elt b, Elt c, ApplyAcc t) => ApplyAcc ((Exp a -> Exp b -> Exp c) -> t) where type FromApplyAcc ((Exp a -> Exp b -> Exp c) -> t) = (SmartExp (EltRepr a) -> SmartExp (EltRepr b) -> SmartExp (EltRepr c)) -> FromApplyAcc t - applyAcc f a = applyAcc $ f (unExpBinaryFunction a) instance (Arrays a, Arrays b, ApplyAcc t) => ApplyAcc ((Acc a -> Acc b) -> t) where type FromApplyAcc ((Acc a -> Acc b) -> t) = (SmartAcc (ArrRepr a) -> SmartAcc (ArrRepr b)) -> FromApplyAcc t - applyAcc f a = applyAcc $ f (unAccFunction a) -- Debugging diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index 429a861fa..bc0edf04e 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -625,95 +625,41 @@ evalLt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = evalLt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (<) evalLt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (<) --- 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 (NonNumSingleType TypeBool) (>) evalGt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (>) evalGt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (>) --- 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 (NonNumSingleType TypeBool) (<=) evalLtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (<=) evalLtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (<=) --- 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 (NonNumSingleType TypeBool) (>=) evalGtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (>=) evalGtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (>=) --- 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 (NonNumSingleType TypeBool) (==) evalEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (==) evalEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (==) --- 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 (NonNumSingleType TypeBool) (/=) evalNEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (/=) evalNEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (/=) --- 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 :: SingleType a -> (a,a) :-> a evalMax ty@(NumSingleType (IntegralNumType ty')) | IntegralDict <- integralDict ty' = eval2 ty max evalMax ty@(NumSingleType (FloatingNumType ty')) | FloatingDict <- floatingDict ty' = eval2 ty max evalMax ty@(NonNumSingleType ty') | NonNumDict <- nonNumDict ty' = eval2 ty 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 :: SingleType a -> (a,a) :-> a evalMin ty@(NumSingleType (IntegralNumType ty')) | IntegralDict <- integralDict ty' = eval2 ty min evalMin ty@(NumSingleType (FloatingNumType ty')) | FloatingDict <- floatingDict ty' = eval2 ty min evalMin ty@(NonNumSingleType ty') | NonNumDict <- nonNumDict ty' = eval2 ty 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 -- ----------------- diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/src/Data/Array/Accelerate/Trafo/Base.hs index a21e7e433..060d77527 100644 --- a/src/Data/Array/Accelerate/Trafo/Base.hs +++ b/src/Data/Array/Accelerate/Trafo/Base.hs @@ -144,7 +144,7 @@ declareVars TupRunit declareVars (TupRpair r1 r2) | DeclareVars lhs1 subst1 a1 <- declareVars r1 , DeclareVars lhs2 subst2 a2 <- declareVars r2 - = DeclareVars (LeftHandSidePair lhs1 lhs2) (subst2 .> subst1) $ \k -> a1 (k .> subst2) `VarsPair` a2 k + = DeclareVars (LeftHandSidePair lhs1 lhs2) (subst2 .> subst1) $ \k -> a1 (k .> subst2) `VarsPair` a2 k -- fromOpenAfun :: Kit acc => OpenAfun aenv f -> PreOpenAfun acc aenv f @@ -464,10 +464,10 @@ mkShapeBinary f shr (Let lhs bnd a) b = Let lhs bnd $ mkShapeBinary f shr a (wea mkShapeBinary f shr a (Let lhs bnd b) = Let lhs bnd $ mkShapeBinary f shr (weakenE (weakenWithLHS lhs) a) b mkShapeBinary f shr a b@Pair{} -- `a` is not Pair | DeclareVars lhs k value <- declareVars $ shapeType shr - = Let lhs a $ mkShapeBinary f shr (evars $ value weakenId) (weakenE k b) + = Let lhs a $ mkShapeBinary f shr (evars $ value weakenId) (weakenE k b) mkShapeBinary f shr a b -- `b` is not a Pair | DeclareVars lhs k value <- declareVars $ shapeType shr - = Let lhs b $ mkShapeBinary f shr (weakenE k a) (evars $ value weakenId) + = Let lhs b $ mkShapeBinary f shr (weakenE k a) (evars $ value weakenId) mkIntersect :: (HasArraysRepr acc, RebuildableAcc acc) => ShapeR sh diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index fb195c40d..c6f513117 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -13,7 +13,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- TODO: remove this & fix warnings {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | -- Module : Data.Array.Accelerate.Trafo.Fusion @@ -835,9 +835,10 @@ instance HasArraysRepr (Cunctation acc) where -- done :: Kit acc => PreOpenAcc acc aenv a -> Embed acc aenv a done pacc - | Just vars <- extractArrayVars $ inject pacc = Embed BaseEnv (Done vars) - | otherwise = case declareVars (arraysRepr pacc) of - DeclareVars lhs _ value -> Embed (PushEnv BaseEnv lhs $ inject pacc) $ Done $ value weakenId + | Just vars <- extractArrayVars $ inject pacc + = Embed BaseEnv (Done vars) + | DeclareVars lhs _ value <- declareVars (arraysRepr pacc) + = Embed (PushEnv BaseEnv lhs $ inject pacc) $ Done $ value weakenId doneZeroIdx :: ArrayR (Array sh e) -> Cunctation acc (aenv, Array sh e) (Array sh e) doneZeroIdx repr = Done $ VarsSingle $ Var repr ZeroIdx @@ -1218,7 +1219,7 @@ combineLhs = go weakenId weakenId go k1 k2 (LeftHandSidePair l1 h1) (LeftHandSidePair l2 h2) | CombinedLHS l k1' k2' <- go k1 k2 l1 l2 , CombinedLHS h k1'' k2'' <- go k1' k2' h1 h2 = CombinedLHS (LeftHandSidePair l h) k1'' k2'' - go k1 k2 (LeftHandSideWildcard _) lhs + go k1 k2 (LeftHandSideWildcard _) lhs | Exists lhs' <- rebuildLHS lhs = CombinedLHS lhs' (weakenWithLHS lhs' .> k1) (sinkWithLHS lhs lhs' k2) go k1 k2 lhs (LeftHandSideWildcard _) | Exists lhs' <- rebuildLHS lhs = CombinedLHS lhs' (sinkWithLHS lhs lhs' k1) (weakenWithLHS lhs' .> k2) @@ -1659,7 +1660,7 @@ arrayShape :: Kit acc => ArrayVar aenv (Array sh e) -> PreExp acc aenv sh arrayShape = simplify . Shape . avarIn indexArray :: Kit acc => ArrayVar aenv (Array sh e) -> PreFun acc aenv (sh -> e) -indexArray v@(Var (ArrayR shr _) _) +indexArray v@(Var (ArrayR shr _) _) | DeclareVars lhs _ value <- declareVars $ shapeType shr = Lam lhs $ Body $ Index (avarIn v) $ evars $ value weakenId diff --git a/src/Data/Array/Accelerate/Trafo/LetSplit.hs b/src/Data/Array/Accelerate/Trafo/LetSplit.hs index 3376090fc..e0adebe7f 100644 --- a/src/Data/Array/Accelerate/Trafo/LetSplit.hs +++ b/src/Data/Array/Accelerate/Trafo/LetSplit.hs @@ -80,3 +80,4 @@ travB = id convertAfun :: Kit acc => PreOpenAfun acc aenv f -> PreOpenAfun acc aenv f convertAfun (Alam lhs f) = Alam lhs $ convertAfun f convertAfun (Abody a) = Abody $ convertAcc a + diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index c8fd98b68..f1d60b410 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -188,8 +188,8 @@ instance (Arrays a, Afunction r) => Afunction (Acc a -> r) where afunctionRepr = AfunctionReprLam $ afunctionRepr @r convertOpenAfun config alyt f | repr <- Sugar.arrays @a - , DeclareVars lhs k value <- declareVars repr = - let + , DeclareVars lhs k value <- declareVars repr + = let a = Acc $ SmartAcc $ Atag repr $ sizeLayout alyt alyt' = PushLayout (incLayout k alyt) lhs (value weakenId) in @@ -203,8 +203,8 @@ instance Arrays b => Afunction (Acc b) where convertSmartAfun1 :: Config -> ArraysR a -> (SmartAcc a -> SmartAcc b) -> AST.Afun (a -> b) convertSmartAfun1 config repr f - | DeclareVars lhs _ value <- declareVars repr = - let + | DeclareVars lhs _ value <- declareVars repr + = let a = SmartAcc $ Atag repr 0 alyt' = PushLayout EmptyLayout lhs (value weakenId) in @@ -521,8 +521,8 @@ convertSharingAfun1 -> (SmartAcc a -> ScopedAcc b) -> OpenAfun aenv (a -> b) convertSharingAfun1 config alyt aenv reprA f - | DeclareVars lhs k value <- declareVars reprA = - let + | DeclareVars lhs k value <- declareVars reprA + = let alyt' = PushLayout (incLayout k alyt) lhs (value weakenId) body = f undefined in @@ -601,8 +601,8 @@ instance (Elt a, Function r) => Function (Exp a -> r) where functionRepr = FunctionReprLam $ functionRepr @r convertOpenFun config lyt f | tp <- eltType @a - , DeclareVars lhs k value <- declareVars tp = - let + , DeclareVars lhs k value <- declareVars tp + = let e = Exp $ SmartExp $ Tag tp $ sizeLayout lyt lyt' = PushLayout (incLayout k lyt) lhs (value weakenId) in @@ -617,8 +617,8 @@ instance Elt b => Function (Exp b) where convertSmartFun :: Config -> TupleType a -> (SmartExp a -> SmartExp b) -> AST.Fun () (a -> b) convertSmartFun config tp f - | DeclareVars lhs _ value <- declareVars tp = - let + | DeclareVars lhs _ value <- declareVars tp + = let e = SmartExp $ Tag tp 0 lyt' = PushLayout EmptyLayout lhs (value weakenId) in @@ -723,10 +723,10 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp cvt (ScopedExp _ (LetSharing se@(StableSharingExp _ boundExp) bodyExp)) | DeclareVars lhs k value <- declareVars $ expType boundExp - = let - lyt' = PushLayout (incLayout k lyt) lhs (value weakenId) - in - AST.Let lhs (cvt (ScopedExp [] boundExp)) (convertSharingExp config lyt' alyt (se:env') aenv bodyExp) + = let + lyt' = PushLayout (incLayout k lyt) lhs (value weakenId) + in + AST.Let lhs (cvt (ScopedExp [] boundExp)) (convertSharingExp config lyt' alyt (se:env') aenv bodyExp) cvt (ScopedExp _ (ExpSharing _ pexp)) = case pexp of Tag tp i -> evars $ prjIdx ("de Bruijn conversion tag " ++ show i) showType tp i lyt @@ -762,8 +762,8 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp cvtFun1 :: TupleType a -> (SmartExp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b) cvtFun1 tp f - | DeclareVars lhs k value <- declareVars tp = - let + | DeclareVars lhs k value <- declareVars tp + = let lyt' = PushLayout (incLayout k lyt) lhs (value weakenId) body = f undefined in @@ -787,8 +787,8 @@ convertSharingFun1 -> (SmartExp a -> ScopedExp b) -> AST.Fun aenv (a -> b) convertSharingFun1 config alyt aenv tp f - | DeclareVars lhs _ value <- declareVars tp = - let + | DeclareVars lhs _ value <- declareVars tp + = let a = SmartExp undefined -- the 'tag' was already embedded in Phase 1 lyt = PushLayout EmptyLayout lhs (value weakenId) openF = convertSharingExp config lyt alyt [] aenv (f a) @@ -807,8 +807,8 @@ convertSharingFun2 -> AST.Fun aenv (a -> b -> c) convertSharingFun2 config alyt aenv ta tb f | DeclareVars lhs1 _ value1 <- declareVars ta - , DeclareVars lhs2 k2 value2 <- declareVars tb = - let + , DeclareVars lhs2 k2 value2 <- declareVars tb + = let a = SmartExp undefined b = SmartExp undefined lyt1 = PushLayout EmptyLayout lhs1 (value1 k2) @@ -1921,6 +1921,7 @@ noNodeCounts = ([], Map.empty) -- nodes. -- -- TODO: Perform cycle detection here. +-- insertAccNode :: StableSharingAcc -> NodeCounts -> NodeCounts insertAccNode ssa@(StableSharingAcc (StableNameHeight sn _) _) (subterms,g) = ([AccNodeCount ssa 1], g') +++ (subterms,g) @@ -1933,6 +1934,7 @@ insertAccNode ssa@(StableSharingAcc (StableNameHeight sn _) _) (subterms,g) -- nodes. -- -- TODO: Perform cycle detection here. +-- insertExpNode :: StableSharingExp -> NodeCounts -> NodeCounts insertExpNode ssa@(StableSharingExp (StableNameHeight sn _) _) (subterms,g) = ([ExpNodeCount ssa 1], g') +++ (subterms,g) @@ -1946,6 +1948,7 @@ insertExpNode ssa@(StableSharingExp (StableNameHeight sn _) _) (subterms,g) -- nodes. -- -- TODO: Perform cycle detection here. +-- insertSeqNode :: StableSharingSeq -> NodeCounts -> NodeCounts insertSeqNode ssa@(StableSharingSeq (StableNameHeight sn _) _) (subterms,g) = ([SeqNodeCount ssa 1], g') +++ (subterms,g) @@ -1958,6 +1961,7 @@ insertSeqNode ssa@(StableSharingSeq (StableNameHeight sn _) _) (subterms,g) -- 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 @@ -2188,7 +2192,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc (acc', accCount2) = scopesAcc acc in reconstruct (Map t1 t2 f' acc') (accCount1 +++ accCount2) - ZipWith t1 t2 t3 f acc1 acc2 + ZipWith t1 t2 t3 f acc1 acc2 -> travF2A2 (ZipWith t1 t2 t3) f acc1 acc2 Fold tp f z acc -> travF2EA (Fold tp) f z acc Fold1 tp f acc -> travF2A (Fold1 tp) f acc diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index c1cd4a2d1..c43183b7b 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -147,11 +147,16 @@ varInRange (VarsRange (Exists rangeIx) n _) (Var _ varIx) = case go rangeIx varI -- Describes how often the variables defined in a LHS are used together. data Count - = Impossible !Usages -- Cannot inline this definition. This happens when the definition declares multiple variables (the right hand side returns a tuple) and the variables are used seperately. - | Infinity -- The variable is used in a loop. Inlining should only proceed if the computation is cheap. + = Impossible !Usages + -- Cannot inline this definition. This happens when the definition + -- declares multiple variables (the right hand side returns a tuple) + -- and the variables are used seperately. + | Infinity + -- The variable is used in a loop. Inlining should only proceed if + -- the computation is cheap. | Finite {-# UNPACK #-} !Int -type Usages = [Bool] -- Per variable a Bool denoting whether that variable is used. +type Usages = [Bool] -- Per variable a Boolean denoting whether that variable is used. instance Semigroup Count where Impossible u1 <> Impossible u2 = Impossible $ zipWith (||) u1 u2 @@ -183,18 +188,20 @@ shrinkLhs (Impossible usages) lhs = case go usages lhs of | (c2, us' , Exists l2') <- go us l2 , (c1, us'', Exists l1') <- go us' l1 , Exists l2'' <- rebuildLHS l2' - = let - lhs' - | LeftHandSideWildcard t1 <- l1' - , LeftHandSideWildcard t2 <- l2'' = LeftHandSideWildcard $ TupRpair t1 t2 - | otherwise = LeftHandSidePair l1' l2'' - in - (c1 || c2, us'', Exists lhs') + = let + lhs' + | LeftHandSideWildcard t1 <- l1' + , LeftHandSideWildcard t2 <- l2'' = LeftHandSideWildcard $ TupRpair t1 t2 + | otherwise = LeftHandSidePair l1' l2'' + in + (c1 || c2, us'', Exists lhs') go _ _ = $internalError "shrinkLhs" "Empty array, mismatch in length of usages array and LHS" shrinkLhs _ _ = Nothing --- The first LHS should be 'larger' than the second, eg the second may have a wildcard if the first LHS does bind variables there, --- but not the other way around. +-- The first LHS should be 'larger' than the second, eg the second may have +-- a wildcard if the first LHS does bind variables there, but not the other +-- way around. +-- strengthenShrunkLHS :: LeftHandSide s t env1 env2 -> LeftHandSide s t env1' env2' -> env1 :?> env1' -> env2 :?> env2' strengthenShrunkLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k strengthenShrunkLHS (LeftHandSideSingle _) (LeftHandSideSingle _) k = \ix -> case ix of @@ -243,10 +250,10 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE Let lhs bnd body | shouldInline -> case inlineVars lhs (snd body') (snd bnd') of Just inlined -> Stats.betaReduce msg . yes $ shrinkE inlined - _ -> error "shrinkExp: Unexpected failure while trying to inline some expression." + _ -> $internalError "shrinkExp" "Unexpected failure while trying to inline some expression." | Just (Exists lhs') <- shrinkLhs count lhs -> case strengthenE (strengthenShrunkLHS lhs lhs' Just) (snd body') of Just body'' -> (Any True, Let lhs' (snd bnd') body'') - Nothing -> error "shrinkExp: Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." + Nothing -> $internalError "shrinkExp" "Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." | otherwise -> Let lhs <$> bnd' <*> body' where shouldInline = case count of @@ -261,11 +268,13 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE -- If the lhs includes non-trivial wildcards (the last field of range is Nothing), -- then we cannot inline the binding. We can only check which variables are not used, -- to detect unused variables. + -- -- If the lhs does not include non-trivial wildcards (the last field of range is a Just), -- we can both analyse whether we can inline the binding, and check which variables are -- not used, to detect unused variables. + -- count = case lhsVarsRange lhs of - Left _ -> Finite 0 + Left _ -> Finite 0 Right range -> usesOfExp range (snd body') msg = case count of @@ -316,7 +325,7 @@ shrinkFun (Lam lhs f) = case lhsVarsRange lhs of in case shrinkLhs count lhs of Just (Exists lhs') -> case strengthenE (strengthenShrunkLHS lhs lhs' Just) f' of Just f'' -> (True, Lam lhs' f'') - Nothing -> error "shrinkFun: Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." + Nothing -> $internalError "shrinkFun" "Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." Nothing -> (b, Lam lhs f') where (b, f') = shrinkFun f @@ -327,9 +336,9 @@ shrinkFun (Body b) = Body <$> shrinkExp b -- 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 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 @@ -450,7 +459,8 @@ shrinkPreAcc shrinkAcc reduceAcc = Stats.substitution "shrinkA" shrinkA shrinkAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f shrinkAF (Alam lhs f) = Alam lhs (shrinkAF f) shrinkAF (Abody a) = Abody (shrinkAcc a) --} +--} + -- Occurrence Counting -- =================== @@ -622,3 +632,4 @@ usesOfPreAcc withShape countAcc idx = count countCT NilAtup = 0 countCT (SnocAtup t c) = countCT t + countC c --} + diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index df797bebd..50c5747f6 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -202,6 +202,7 @@ recoverLoops _ bnd e3 -- It might be helpful to do some inlining if this enables other optimizations. -- Eg, for `let x = -y in -x`, the inlining would allow us to shorten it to `y`. -- If we do not want to do inlining, we should remove the environment here. +-- simplifyOpenExp :: forall acc env aenv e. (Kit acc) => Gamma acc env env aenv @@ -246,49 +247,62 @@ simplifyOpenExp env = first getAny . cvtE cvtF :: Gamma acc env' env' aenv -> PreOpenFun acc env' aenv f -> (Any, PreOpenFun acc env' aenv f) cvtF env' = first Any . simplifyOpenFun env' - cvtLet :: Gamma acc env' env' aenv -> ELeftHandSide bnd env' env'' -> PreOpenExp acc env' aenv bnd -> (Gamma acc env'' env'' aenv -> (Any, PreOpenExp acc env'' aenv t)) -> (Any, PreOpenExp acc env' aenv t) + cvtLet :: Gamma acc env' env' aenv + -> ELeftHandSide bnd env' env'' + -> PreOpenExp acc env' aenv bnd + -> (Gamma acc env'' env'' aenv -> (Any, PreOpenExp acc env'' aenv t)) + -> (Any, PreOpenExp acc env' aenv t) cvtLet env' lhs@(LeftHandSideSingle _) bnd body = Let lhs bnd <$> body (incExp $ env' `pushExp` bnd) -- Single variable on the LHS, add binding to the environment cvtLet env' (LeftHandSideWildcard _) _ body = body env' -- Binding not used, remove let binding - cvtLet env' (LeftHandSidePair l1 l2) (Pair e1 e2) body = -- Split binding to multiple bindings - first (const $ Any True) $ - cvtLet env' l1 e1 $ - \env'' -> cvtLet env'' l2 (weakenE (weakenWithLHS l1) e2) body + cvtLet env' (LeftHandSidePair l1 l2) (Pair e1 e2) body -- Split binding to multiple bindings + = first (const $ Any True) + $ cvtLet env' l1 e1 + $ \env'' -> cvtLet env'' l2 (weakenE (weakenWithLHS l1) e2) body cvtLet env' lhs bnd body = Let lhs bnd <$> body (lhsExpr lhs env') -- Cannot split this binding. -- Simplify conditional expressions, in particular by eliminating branches -- when the predicate is a known constant. -- - cond :: forall t. - (Any, PreOpenExp acc env aenv Bool) + cond :: (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') + | 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 - -- Shape manipulations -- - shape :: forall sh t. acc aenv (Array sh t) -> (Any, PreOpenExp acc env aenv sh) + shape :: acc aenv (Array sh t) -> (Any, PreOpenExp acc env aenv sh) shape a | ArrayR ShapeRz _ <- arrayRepr a - = Stats.ruleFired "shape/Z" $ yes Nil + = Stats.ruleFired "shape/Z" $ yes Nil shape a - = pure $ Shape a - - shapeSize :: forall sh. ShapeR sh -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) - shapeSize shr (_, extractConstTuple -> Just c) = Stats.ruleFired "shapeSize/const" $ yes (Const scalarTypeInt (product (shapeToList shr c))) - shapeSize shr sh = ShapeSize shr <$> sh - - toIndex :: forall sh. ShapeR sh -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) + = pure $ Shape a + + shapeSize :: ShapeR sh + -> (Any, PreOpenExp acc env aenv sh) + -> (Any, PreOpenExp acc env aenv Int) + shapeSize shr (_, sh) + | Just c <- extractConstTuple sh + = Stats.ruleFired "shapeSize/const" $ yes (Const scalarTypeInt (product (shapeToList shr c))) + shapeSize shr sh + = ShapeSize shr <$> sh + + toIndex :: ShapeR 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 shr sh ix = ToIndex shr <$> sh <*> ix - fromIndex :: forall sh. ShapeR sh -> (Any, PreOpenExp acc env aenv sh) -> (Any, PreOpenExp acc env aenv Int) -> (Any, PreOpenExp acc env aenv sh) + fromIndex :: ShapeR 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 shr sh ix = FromIndex shr <$> sh <*> ix diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 747919789..8b179049d 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -6,9 +6,10 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -49,8 +50,9 @@ import Control.Monad import Prelude hiding ( exp, seq ) import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Array.Representation import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Array.Representation +import Data.Array.Accelerate.Error import qualified Data.Array.Accelerate.Debug.Stats as Stats @@ -95,7 +97,8 @@ lhsFullVars = fmap snd . go weakenId bindingIsTrivial :: LeftHandSide s a env1 env2 -> Vars s env2 b -> Maybe (a :~: b) bindingIsTrivial lhs vars | Just lhsVars <- lhsFullVars lhs - , Just Refl <- matchVars vars lhsVars = Just Refl + , Just Refl <- matchVars vars lhsVars + = Just Refl bindingIsTrivial _ _ = Nothing isIdentity :: PreOpenFun acc env aenv (a -> b) -> Maybe (a :~: b) @@ -107,7 +110,8 @@ isIdentityIndexing :: PreOpenFun acc env aenv (a -> b) -> Maybe (acc aenv (Array isIdentityIndexing (Lam lhs (Body body)) | Index a ix <- body , Just vars <- extractExpVars ix - , Just Refl <- bindingIsTrivial lhs vars = Just a + , Just Refl <- bindingIsTrivial lhs vars + = Just a isIdentityIndexing _ = Nothing -- | Replace the first variable with the given expression. The environment @@ -176,7 +180,7 @@ inlineVars lhsBound expr bound -> PreOpenFun acc env1 aenv t -> Maybe (PreOpenFun acc env2 aenv t) substituteF k1 k2 vars (Body e) = Body <$> substitute k1 k2 vars e - substituteF k1 k2 vars (Lam lhs f) + substituteF k1 k2 vars (Lam lhs f) | Exists lhs' <- rebuildLHS lhs = Lam lhs' <$> substituteF (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weaken` vars) f inlineVars _ _ _ = Nothing @@ -218,7 +222,7 @@ compose f@(Lam lhsB (Body c)) g@(Lam lhsA (Body b)) | Just Refl <- isIdentity g = f | Exists lhsB' <- rebuildLHS lhsB - = Lam lhsA $ Body $ Let lhsB' b (weakenE (sinkWithLHS lhsB lhsB' $ weakenWithLHS lhsA) c) + = Lam lhsA $ Body $ Let lhsB' b (weakenE (sinkWithLHS lhsB lhsB' $ weakenWithLHS lhsA) c) -- = Stats.substitution "compose" . Lam lhs2 . Body $ substitute' f g compose _ _ = error "compose: impossible evaluation" @@ -450,7 +454,7 @@ strengthenWithLHS (LeftHandSidePair l1 l2) = strengthenWithLHS l2 >=> strengthen strengthenAfter :: LeftHandSide s t env1 env2 -> LeftHandSide s t env1' env2' -> env1 :?> env1' -> env2 :?> env2' strengthenAfter (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k -strengthenAfter (LeftHandSideSingle _) (LeftHandSideSingle _) k = \ix -> case ix of +strengthenAfter (LeftHandSideSingle _) (LeftHandSideSingle _) k = \ix -> case ix of ZeroIdx -> Just ZeroIdx SuccIdx i -> SuccIdx <$> k i strengthenAfter (LeftHandSidePair l1 l2) (LeftHandSidePair l1' l2') k @@ -522,27 +526,27 @@ rebuildPreOpenExp k v av exp = Const t c -> pure $ Const t c PrimConst c -> pure $ PrimConst c Undef t -> pure $ Undef t - Evar var -> expOut <$> v var + Evar var -> expOut <$> v var Let lhs a b | Exists lhs' <- rebuildLHS lhs - -> Let lhs' <$> rebuildPreOpenExp k v av a <*> rebuildPreOpenExp k (shiftE' lhs lhs' k v) av b - Pair e1 e2 -> Pair <$> rebuildPreOpenExp k v av e1 <*> rebuildPreOpenExp k v av e2 - Nil -> pure $ Nil - VecPack vec e -> VecPack vec <$> rebuildPreOpenExp k v av e - VecUnpack vec e -> VecUnpack vec <$> rebuildPreOpenExp k v av e - 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 shr sh ix -> ToIndex shr <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av ix - FromIndex shr sh ix -> FromIndex shr <$> 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 shr sh -> ShapeSize shr <$> rebuildPreOpenExp k v av sh + -> Let lhs' <$> rebuildPreOpenExp k v av a <*> rebuildPreOpenExp k (shiftE' lhs lhs' k v) av b + Pair e1 e2 -> Pair <$> rebuildPreOpenExp k v av e1 <*> rebuildPreOpenExp k v av e2 + Nil -> pure Nil + VecPack vec e -> VecPack vec <$> rebuildPreOpenExp k v av e + VecUnpack vec e -> VecUnpack vec <$> rebuildPreOpenExp k v av e + 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 shr sh ix -> ToIndex shr <$> rebuildPreOpenExp k v av sh <*> rebuildPreOpenExp k v av ix + FromIndex shr sh ix -> FromIndex shr <$> 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 shr sh -> ShapeSize shr <$> rebuildPreOpenExp k v av sh Foreign tp ff f e -> Foreign tp ff f <$> rebuildPreOpenExp k v av e - Coerce t1 t2 e -> Coerce t1 t2 <$> rebuildPreOpenExp k v av e + Coerce t1 t2 e -> Coerce t1 t2 <$> rebuildPreOpenExp k v av e {-# INLINEABLE rebuildFun #-} rebuildFun @@ -555,7 +559,7 @@ rebuildFun rebuildFun k v av fun = case fun of Body e -> Body <$> rebuildPreOpenExp k v av e - Lam lhs f + Lam lhs f | Exists lhs' <- rebuildLHS lhs -> Lam lhs' <$> rebuildFun k (shiftE' lhs lhs' k v) av f @@ -611,7 +615,7 @@ shiftA' shiftA' (LeftHandSideWildcard _) (LeftHandSideWildcard _) _ v = v shiftA' (LeftHandSideSingle _) (LeftHandSideSingle _) k v = shiftA k v shiftA' (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k v = shiftA' b1 b2 k $ shiftA' a1 a2 k v -shiftA' _ _ _ _ = error "Substitution: left hand sides do not match" +shiftA' _ _ _ _ = $internalError "Substitution/shiftA'" "left hand sides do not match" {-# INLINEABLE rebuildOpenAcc #-} rebuildOpenAcc @@ -630,38 +634,39 @@ rebuildPreOpenAcc -> f (PreOpenAcc acc aenv' t) rebuildPreOpenAcc k av acc = case acc of - Use repr a -> pure $ Use repr a - Alet lhs a b -> rebuildAlet k av lhs a b - Avar ix -> accOut <$> av ix - Apair as bs -> Apair <$> k av as <*> k av bs - Anil -> pure Anil - Apply repr f a -> Apply repr <$> 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 tp e -> Unit tp <$> rebuildPreOpenExp k (pure . IE) av e - Reshape shr e a -> Reshape shr <$> rebuildPreOpenExp k (pure . IE) av e <*> k av a - Generate repr e f -> Generate repr <$> rebuildPreOpenExp k (pure . IE) av e <*> rebuildFun k (pure . IE) av f - Transform repr sh ix f a -> Transform repr <$> 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 tp f a -> Map tp <$> rebuildFun k (pure . IE) av f <*> k av a - ZipWith tp f a1 a2 -> ZipWith tp <$> 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 itp f z a s -> FoldSeg itp <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a <*> k av s - Fold1Seg itp f a s -> Fold1Seg itp <$> 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 shr sh f a -> Backpermute shr <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av f <*> k av a - Stencil sr tp f b a -> Stencil sr tp <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b <*> k av a - Stencil2 s1 s2 tp f b1 a1 b2 a2 -> Stencil2 s1 s2 tp <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b1 <*> k av a1 <*> rebuildBoundary k av b2 <*> k av a2 + Use repr a -> pure $ Use repr a + Alet lhs a b -> rebuildAlet k av lhs a b + Avar ix -> accOut <$> av ix + Apair as bs -> Apair <$> k av as <*> k av bs + Anil -> pure Anil + Apply repr f a -> Apply repr <$> 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 tp e -> Unit tp <$> rebuildPreOpenExp k (pure . IE) av e + Reshape shr e a -> Reshape shr <$> rebuildPreOpenExp k (pure . IE) av e <*> k av a + Generate repr e f -> Generate repr <$> rebuildPreOpenExp k (pure . IE) av e <*> rebuildFun k (pure . IE) av f + Transform repr sh ix f a -> Transform repr <$> 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 tp f a -> Map tp <$> rebuildFun k (pure . IE) av f <*> k av a + ZipWith tp f a1 a2 -> ZipWith tp <$> 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 itp f z a s -> FoldSeg itp <$> rebuildFun k (pure . IE) av f <*> rebuildPreOpenExp k (pure . IE) av z <*> k av a <*> k av s + Fold1Seg itp f a s -> Fold1Seg itp <$> 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 shr sh f a -> Backpermute shr <$> rebuildPreOpenExp k (pure . IE) av sh <*> rebuildFun k (pure . IE) av f <*> k av a + Stencil sr tp f b a -> Stencil sr tp <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b <*> k av a + Stencil2 s1 s2 tp f b1 a1 b2 a2 + -> Stencil2 s1 s2 tp <$> rebuildFun k (pure . IE) av f <*> rebuildBoundary k av b1 <*> k av a1 <*> rebuildBoundary k av b2 <*> k av a2 + Aforeign repr ff afun as -> Aforeign repr ff afun <$> k av as -- Collect seq -> Collect <$> rebuildSeq k av seq - Aforeign repr ff afun as -> Aforeign repr ff afun <$> k av as {-# INLINEABLE rebuildAfun #-} rebuildAfun @@ -670,11 +675,10 @@ rebuildAfun -> RebuildAvar f fa acc aenv aenv' -> PreOpenAfun acc aenv t -> f (PreOpenAfun acc aenv' t) -rebuildAfun k av afun = - case afun of - Abody b -> Abody <$> k av b - Alam lhs1 f -> case rebuildLHS lhs1 of - Exists lhs2 -> Alam lhs2 <$> rebuildAfun k (shiftA' lhs1 lhs2 k av) f +rebuildAfun k av (Abody b) = Abody <$> k av b +rebuildAfun k av (Alam lhs1 f) + | Exists lhs2 <- rebuildLHS lhs1 + = Alam lhs2 <$> rebuildAfun k (shiftA' lhs1 lhs2 k av) f rebuildAlet :: forall f fa acc aenv1 aenv1' aenv2 bndArrs arrs. (Applicative f, SyntacticAcc fa) @@ -684,16 +688,18 @@ rebuildAlet -> acc aenv1 bndArrs -> acc aenv1' arrs -> f (PreOpenAcc acc aenv2 arrs) -rebuildAlet k av lhs1 bind1 body1 = case rebuildLHS lhs1 of - Exists lhs2 -> Alet lhs2 <$> k av bind1 <*> k (shiftA' lhs1 lhs2 k av) body1 +rebuildAlet k av lhs1 bind1 body1 + | Exists lhs2 <- rebuildLHS lhs1 + = Alet lhs2 <$> k av bind1 <*> k (shiftA' lhs1 lhs2 k av) body1 {-# INLINEABLE rebuildLHS #-} rebuildLHS :: LeftHandSide s t aenv1 aenv1' -> Exists (LeftHandSide s t aenv2) rebuildLHS (LeftHandSideWildcard r) = Exists $ LeftHandSideWildcard r rebuildLHS (LeftHandSideSingle s) = Exists $ LeftHandSideSingle s -rebuildLHS (LeftHandSidePair as bs) = case rebuildLHS as of - Exists as' -> case rebuildLHS bs of - Exists bs' -> Exists $ LeftHandSidePair as' bs' +rebuildLHS (LeftHandSidePair as bs) + | Exists as' <- rebuildLHS as + , Exists bs' <- rebuildLHS bs + = Exists $ LeftHandSidePair as' bs' {-# INLINEABLE rebuildBoundary #-} rebuildBoundary @@ -761,3 +767,4 @@ extractExpVars Nil = Just VarsNil extractExpVars (Pair e1 e2) = VarsPair <$> extractExpVars e1 <*> extractExpVars e2 extractExpVars (Evar v) = Just $ VarsSingle v extractExpVars _ = Nothing + diff --git a/src/Data/Array/Accelerate/Trafo/Vectorise.hs b/src/Data/Array/Accelerate/Trafo/Vectorise.hs index b61d5b7d2..5d7684e8e 100644 --- a/src/Data/Array/Accelerate/Trafo/Vectorise.hs +++ b/src/Data/Array/Accelerate/Trafo/Vectorise.hs @@ -72,7 +72,7 @@ import Data.Array.Accelerate.Error -- data Context env aenv env' aenv' where -- All environments are empty - EmptyC :: Context () () () () + EmptyC :: Context () () () () -- An expression that has already been lifted PushLExpC :: Elt e diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index f7a1c0c49..40ae09a9c 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -72,7 +72,6 @@ module Data.Array.Accelerate.Type ( ) where -import Data.Orphans () -- orphan instances for 8-tuples and beyond import Data.Array.Accelerate.Orphans () -- Prim Half import Control.Monad.ST @@ -343,7 +342,7 @@ data TupR s a where TupRsingle :: s a -> TupR s a TupRpair :: TupR s a -> TupR s b -> TupR s (a, b) -type TupleType = TupR ScalarType -- Rename to EltR? +type TupleType = TupR ScalarType -- TODO: Rename to EltR instance Show (TupR ScalarType a) where show TupRunit = "()" diff --git a/src/Data/Array/Accelerate/Unsafe.hs b/src/Data/Array/Accelerate/Unsafe.hs index 4701618e9..ac4262de5 100644 --- a/src/Data/Array/Accelerate/Unsafe.hs +++ b/src/Data/Array/Accelerate/Unsafe.hs @@ -17,7 +17,8 @@ module Data.Array.Accelerate.Unsafe ( -- ** Unsafe operations - undef, coerce, Coerce + Coerce, coerce, + undef, ) where @@ -48,3 +49,4 @@ import Data.Array.Accelerate.Smart -- coerce :: Coerce (EltRepr a) (EltRepr b) => Exp a -> Exp b coerce = mkCoerce + From b95278ff6dd228be7dd40c24e7d3ed6ed061b1ee Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 5 Jun 2020 10:55:00 +0200 Subject: [PATCH 231/316] minor --- src/Data/Array/Accelerate/Trafo/Sharing.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 24f49e2d3..d15737b55 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -1982,11 +1982,10 @@ nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeNam -- -- * 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 'SmartAcc' node counts and -- guarantee that this also hold for the result. -- --- With the latest revision, the commented Seq code hasn't been updated for this function. - (+++) :: NodeCounts -> NodeCounts -> NodeCounts (ns1, g1) +++ (ns2, g2) = (cleanup $ merge ns1 ns2, Map.unionWith Set.union g1 g2) where @@ -2009,10 +2008,15 @@ nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeNam (StableSharingExp _ (VarSharing _ _)) `pickNoneVar` sa2 = sa2 sa1 `pickNoneVar` _sa2 = sa1 - -- As the StableSharingAccs do not pose a strict ordering, this cleanup step is needed. - -- In this step, all pairs of AccNodes and ExpNodes that are of the same height are compared against eachother. - -- Without this step, duplicates may arise. - -- Note that while (+++) is morally symmetric, replacing `merge [x] y' with `merge y [x]' inside of `cleanup' won't check all required possibilities. + -- As the StableSharingAccs do not pose a strict ordering, this cleanup + -- step is needed. In this step, all pairs of AccNodes and ExpNodes + -- that are of the same height are compared against each other. Without + -- this step, duplicates may arise. + -- + -- Note that while (+++) is morally symmetric, replacing `merge [x] y' + -- with `merge y [x]' inside of `cleanup' won't check all required + -- possibilities. + -- cleanup = concatMap (foldr (\x y -> merge [x] y) []) . groupBy sameHeight sameHeight (AccNodeCount sa1 _) (AccNodeCount sa2 _) = not (sa1 `higherSSA` sa2) && not (sa2 `higherSSA` sa1) sameHeight (ExpNodeCount se1 _) (ExpNodeCount se2 _) = not (se1 `higherSSE` se2) && not (se2 `higherSSE` se1) From a0aa276638b1852201d2ec752bd4f88eb501492b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 5 Jun 2020 11:50:42 +0200 Subject: [PATCH 232/316] remove travis/appveyor CI --- .gitmodules | 3 --- .travis | 1 - README.md | 2 -- .appveyor.yml => icebox/appveyor.yml | 0 .travis.yml => icebox/travis.yml | 0 5 files changed, 6 deletions(-) delete mode 160000 .travis rename .appveyor.yml => icebox/appveyor.yml (100%) rename .travis.yml => icebox/travis.yml (100%) diff --git a/.gitmodules b/.gitmodules index 7c8a89980..e69de29bb 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +0,0 @@ -[submodule ".travis"] - path = .travis - url = https://github.com/tmcdonell/travis-scripts.git diff --git a/.travis b/.travis deleted file mode 160000 index 7bc07ba1d..000000000 --- a/.travis +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 7bc07ba1d0051abb499a957e663ebef817aa47df diff --git a/README.md b/README.md index 0de984d7d..f8edc0f98 100644 --- a/README.md +++ b/README.md @@ -3,8 +3,6 @@ # High-performance parallel arrays for Haskell -[![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) [![GitHub CI](https://github.com/tmcdonell/accelerate/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate/actions) [![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby)
diff --git a/.appveyor.yml b/icebox/appveyor.yml similarity index 100% rename from .appveyor.yml rename to icebox/appveyor.yml diff --git a/.travis.yml b/icebox/travis.yml similarity index 100% rename from .travis.yml rename to icebox/travis.yml From c999c1842c721c365f365f331259659346d1fd67 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 5 Jun 2020 14:20:53 +0200 Subject: [PATCH 233/316] prettier printer for T0 and T1 --- src/Data/Array/Accelerate/Pretty/Print.hs | 24 ++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index f64bb347b..fee90733b 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -255,8 +255,12 @@ prettyAtuple -> PreOpenAcc acc aenv arrs -> Adoc prettyAtuple prettyAcc extractAcc aenv0 acc = case collect acc of - Just tup -> align $ "T" <> pretty (length tup) <+> sep tup Nothing -> align $ ppPair acc + Just tup -> + case tup of + [] -> "()" + [t] -> t + _ -> align $ "T" <> pretty (length tup) <+> sep tup where ppPair :: PreOpenAcc acc aenv arrs' -> Adoc ppPair (Apair a1 a2) = "(" <> ppPair (extractAcc a1) <> "," <+> prettyAcc context0 aenv0 a2 <> ")" @@ -278,8 +282,11 @@ prettyELhs requiresParens = prettyLhs requiresParens 'x' prettyLhs :: forall s env env' arrs. Bool -> Char -> Val env -> LeftHandSide s arrs env env' -> (Val env', Adoc) prettyLhs requiresParens x env0 lhs = case collect lhs of - Just (env1, tup) -> (env1, parensIf requiresParens (pretty 'T' <> pretty (length tup) <+> sep tup)) Nothing -> ppPair lhs + Just (env1, tup) -> + case tup of + [] -> (env1, "()") + _ -> (env1, parensIf requiresParens (pretty 'T' <> pretty (length tup) <+> sep tup)) where ppPair :: LeftHandSide s arrs' env env'' -> (Val env'', Adoc) ppPair (LeftHandSideWildcard TupRunit) = (env0, "()") @@ -476,19 +483,22 @@ prettyTuple -> OpenExp env aenv t -> Adoc prettyTuple ctx env aenv exp = case collect exp of - Just tup -> align $ parensIf (ctxPrecedence ctx > 0) ("T" <> pretty (length tup) <+> sep tup) Nothing -> align $ ppPair exp + Just tup -> + case tup of + [] -> "()" + [t] -> t + _ -> align $ parensIf (ctxPrecedence ctx > 0) ("T" <> pretty (length tup) <+> sep tup) where ppPair :: OpenExp env aenv t' -> Adoc ppPair (Pair e1 e2) = "(" <> ppPair e1 <> "," <+> prettyOpenExp context0 env aenv e2 <> ")" ppPair e = prettyOpenExp context0 env aenv e collect :: OpenExp env aenv t' -> Maybe [Adoc] - collect Nil = Just [] + collect Nil = Just [] collect (Pair e1 e2) - | Just tup <- collect e1 - = Just $ tup ++ [prettyOpenExp app env aenv e2] - collect _ = Nothing + | Just tup <- collect e1 = Just $ tup ++ [prettyOpenExp app env aenv e2] + collect _ = Nothing {- From de95f21285a0a39df8b391e27bdf4a47890debb9 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 5 Jun 2020 17:28:58 +0200 Subject: [PATCH 234/316] update CHANGELOG.md --- CHANGELOG.md | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 75466f451..45948d0c3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,18 +14,20 @@ Policy (PVP)](https://pvp.haskell.org) if the delayed function is expensive, you may wish to explicitly `compute` the source array first, matching the old behaviour. * Removed `Slice` constraint from some indexing operations + * Improve fusion for `zipWith*` ([#453]) * (internal) Visible type applications are used instead of `Proxy` types * (internal) `EltRepr` is now a class-associated type of `Elt` * (internal) `GArrayData` has been simplified * (internal) SIMD representation has been improved and generalised + * (internal) Massive internal refactoring of the internal AST ([#449], [#455], [#457]) ### Added * Pattern synonyms for manipulating custom product types can now be created; see `Pattern` ### Removed - * Drop support for GHC-7.10 + * Drop support for GHC-7.10, 8.0 ### Contributors @@ -33,6 +35,10 @@ Special thanks to those who contributed patches as part of this release: * Trevor L. McDonell (@tmcdonell) * Joshua Meredith (@JoshMeredith) + * Ivo Gabe de Wolff (@ivogabe) + * David van Balen (@dpvanbalen) + * Jaro Reinders (@noughtmare) + * Alex Lang (@alang9) ## [1.2.0.1] - 2018-10-06 @@ -180,4 +186,8 @@ Special thanks to those who contributed patches as part of this release: [#340]: https://github.com/AccelerateHS/accelerate/issues/340 [#390]: https://github.com/AccelerateHS/accelerate/issues/390 +[#453]: https://github.com/AccelerateHS/accelerate/pull/453 +[#449]: https://github.com/AccelerateHS/accelerate/pull/449 +[#455]: https://github.com/AccelerateHS/accelerate/pull/455 +[#457]: https://github.com/AccelerateHS/accelerate/pull/457 From e0733e3e351db0fb985642c239ce179d2ba3763e Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 8 Jun 2020 12:46:25 +0200 Subject: [PATCH 235/316] rename VX to VecX --- src/Data/Array/Accelerate.hs | 8 +- src/Data/Array/Accelerate/Array/Data.hs | 3 +- .../Array/Accelerate/Array/Representation.hs | 6 +- src/Data/Array/Accelerate/Data/Complex.hs | 38 ++--- src/Data/Array/Accelerate/Test/NoFib/Base.hs | 22 +-- .../Accelerate/Test/NoFib/Prelude/SIMD.hs | 24 ++-- src/Data/Array/Accelerate/Type.hs | 136 +++++++++--------- 7 files changed, 121 insertions(+), 116 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 1bf0f522a..760af531e 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -345,9 +345,11 @@ module Data.Array.Accelerate ( pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, - pattern V2, pattern V2_, pattern V3, pattern V3_, - pattern V4, pattern V4_, pattern V8, pattern V8_, - pattern V16, pattern V16_, + pattern Vec2, pattern V2_, + pattern Vec3, pattern V3_, + pattern Vec4, pattern V4_, + pattern Vec8, pattern V8_, + pattern Vec16, pattern V16_, pattern True_, pattern False_, diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 6f06bbe57..398ab2c67 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -9,7 +9,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} @@ -237,7 +236,7 @@ unsafeWriteArrayData (TupRpair t1 t2) (a1, a2) !ix (v1, v2) >> unsafeWriteArrayData t2 a2 ix v2 unsafeWriteArrayData (TupRsingle (SingleScalarType tp)) arr !ix !val | (ScalarDict, from, _) <- singleDict tp = unsafeWriteArray arr ix (from val) -unsafeWriteArrayData (TupRsingle (VectorScalarType (VectorType (I# w#) tp))) arr !(I# ix#) (Vec ba# :: Vec n t) +unsafeWriteArrayData (TupRsingle (VectorScalarType (VectorType (I# w#) tp))) arr (I# ix#) (Vec ba# :: Vec n t) | (ScalarDict, _, _) <- singleDict tp = let !bytes# = w# *# sizeOf# (undefined :: ScalarDataRepr e) diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/src/Data/Array/Accelerate/Array/Representation.hs index 0ca44e4a0..274c85e45 100644 --- a/src/Data/Array/Accelerate/Array/Representation.hs +++ b/src/Data/Array/Accelerate/Array/Representation.hs @@ -567,8 +567,8 @@ vecPack vecR tuple vecUnpack :: forall n single tuple. KnownNat n => VecR n single tuple -> Vec n single -> tuple vecUnpack vecR (Vec ba#) | VectorType n single <- vecRvector vecR - , !(I# n#) <- n - , PrimDict <- getPrim single + , (I# n#) <- n + , PrimDict <- getPrim single = go (n# -# 1#) vecR where go :: Prim single => Int# -> VecR n' single tuple' -> tuple' @@ -626,7 +626,7 @@ showElement tuple value = showElement' tuple value "" showVector :: VectorType (Vec n a) -> Vec n a -> String showVector (VectorType _ single) vec - | PrimDict <- getPrim single = "<" ++ (intercalate ", " $ showSingle single <$> vecToArray vec) ++ ">" + | PrimDict <- getPrim single = "<" ++ intercalate ", " (showSingle single <$> vecToArray vec) ++ ">" showArray :: ArrayR (Array sh e) -> Array sh e -> String showArray repr@(ArrayR _ tp) = showArray' (showString . showElement tp) repr diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index ce2911bfd..3875cef50 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -83,30 +83,30 @@ instance Elt a => Elt (Complex a) where where tp = eltType @a toElt = case complexR $ eltType @a of - ComplexRvec _ -> \(V2 r i) -> toElt r :+ toElt i + ComplexRvec _ -> \(Vec2 r i) -> toElt r :+ toElt i ComplexRtup -> \(((), r), i) -> toElt r :+ toElt i fromElt (r :+ i) = case complexR $ eltType @a of - ComplexRvec _ -> V2 (fromElt r) (fromElt i) + ComplexRvec _ -> Vec2 (fromElt r) (fromElt i) ComplexRtup -> (((), fromElt r), fromElt i) type family ComplexRepr a where - ComplexRepr Half = V2 Half - ComplexRepr Float = V2 Float - ComplexRepr Double = V2 Double - ComplexRepr Int = V2 Int - ComplexRepr Int8 = V2 Int8 - ComplexRepr Int16 = V2 Int16 - ComplexRepr Int32 = V2 Int32 - ComplexRepr Int64 = V2 Int64 - ComplexRepr Word = V2 Word - ComplexRepr Word8 = V2 Word8 - ComplexRepr Word16 = V2 Word16 - ComplexRepr Word32 = V2 Word32 - ComplexRepr Word64 = V2 Word64 + ComplexRepr Half = Vec2 Half + ComplexRepr Float = Vec2 Float + ComplexRepr Double = Vec2 Double + ComplexRepr Int = Vec2 Int + ComplexRepr Int8 = Vec2 Int8 + ComplexRepr Int16 = Vec2 Int16 + ComplexRepr Int32 = Vec2 Int32 + ComplexRepr Int64 = Vec2 Int64 + ComplexRepr Word = Vec2 Word + ComplexRepr Word8 = Vec2 Word8 + ComplexRepr Word16 = Vec2 Word16 + ComplexRepr Word32 = Vec2 Word32 + ComplexRepr Word64 = Vec2 Word64 ComplexRepr a = Tup2 a a data ComplexR a c where - ComplexRvec :: VecElt a => SingleType a -> ComplexR a (V2 a) + ComplexRvec :: VecElt a => SingleType a -> ComplexR a (Vec2 a) ComplexRtup :: ComplexR a (Tup2 a a) complexR :: TupleType a -> ComplexR a (ComplexRepr a) @@ -136,15 +136,15 @@ constructComplex r i = case complexR $ eltType @a of r', i' :: Exp (EltRepr a) r' = coerce @a @(EltRepr a) r i' = coerce i - v :: Exp (V2 (EltRepr a)) + v :: Exp (Vec2 (EltRepr a)) v = V2_ r' i' in - coerce @(V2 (EltRepr a)) @(Complex a) $ v + coerce @(Vec2 (EltRepr a)) @(Complex a) $ v ComplexRtup -> coerce $ T2 r i deconstructComplex :: forall a. Elt a => Exp (Complex a) -> (Exp a, Exp a) deconstructComplex c = case complexR $ eltType @a of - ComplexRvec _ -> let V2_ r i = coerce @(Complex a) @(V2 (EltRepr a)) c in (coerce r, coerce i) + ComplexRvec _ -> let V2_ r i = coerce @(Complex a) @(Vec2 (EltRepr a)) c in (coerce r, coerce i) ComplexRtup -> let T2 r i = coerce c in (r, i) coerce :: EltRepr a ~ EltRepr b => Exp a -> Exp b diff --git a/src/Data/Array/Accelerate/Test/NoFib/Base.hs b/src/Data/Array/Accelerate/Test/NoFib/Base.hs index f79c69949..f9e76c892 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Base.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Base.hs @@ -91,21 +91,21 @@ 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) -v2 :: Prim a => Gen a -> Gen (V2 a) -v2 a = V2 <$> a <*> a +v2 :: Prim a => Gen a -> Gen (Vec2 a) +v2 a = Vec2 <$> a <*> a -v3 :: Prim a => Gen a -> Gen (V3 a) -v3 a = V3 <$> a <*> a <*> a +v3 :: Prim a => Gen a -> Gen (Vec3 a) +v3 a = Vec3 <$> a <*> a <*> a -v4 :: Prim a => Gen a -> Gen (V4 a) -v4 a = V4 <$> a <*> a <*> a <*> a +v4 :: Prim a => Gen a -> Gen (Vec4 a) +v4 a = Vec4 <$> a <*> a <*> a <*> a -v8 :: Prim a => Gen a -> Gen (V8 a) -v8 a = V8 <$> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a +v8 :: Prim a => Gen a -> Gen (Vec8 a) +v8 a = Vec8 <$> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a -v16 :: Prim a => Gen a -> Gen (V16 a) -v16 a = V16 <$> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a - <*> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a +v16 :: Prim a => Gen a -> Gen (Vec16 a) +v16 a = Vec16 <$> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a + <*> a <*> a <*> a <*> a <*> a <*> a <*> a <*> a log_flt_max :: RealFloat a => a log_flt_max = log flt_max diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs index ba1c3a41e..49140e88d 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs @@ -92,7 +92,7 @@ test_extract_v2 runN dim e = sh <- forAll dim xs <- forAll (array sh (v2 e)) (_l,_m) <- P.snd <$> forAllWith P.fst (Gen.element [("_1",(_1,_1)), ("_2",(_2,_2))]) - let !go = runN (A.map (view _m . unpackV2')) in go xs === mapRef (view _l . unpackV2) xs + let !go = runN (A.map (view _m . unpackVec2')) in go xs === mapRef (view _l . unpackVec2) xs test_extract_v3 :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) @@ -105,7 +105,7 @@ test_extract_v3 runN dim e = sh <- forAll dim xs <- forAll (array sh (v3 e)) (_l,_m) <- P.snd <$> forAllWith P.fst (Gen.element [("_1",(_1,_1)), ("_2",(_2,_2)), ("_3",(_3,_3))]) - let !go = runN (A.map (view _m . unpackV3')) in go xs === mapRef (view _l . unpackV3) xs + let !go = runN (A.map (view _m . unpackVec3')) in go xs === mapRef (view _l . unpackVec3) xs test_extract_v4 :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) @@ -118,7 +118,7 @@ test_extract_v4 runN dim e = sh <- forAll dim xs <- forAll (array sh (v4 e)) (_l,_m) <- P.snd <$> forAllWith P.fst (Gen.element [("_1",(_1,_1)), ("_2",(_2,_2)), ("_3",(_3,_3)), ("_4",(_4,_4))]) - let !go = runN (A.map (view _m . unpackV4')) in go xs === mapRef (view _l . unpackV4) xs + let !go = runN (A.map (view _m . unpackVec4')) in go xs === mapRef (view _l . unpackVec4) xs test_inject_v2 :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) @@ -132,7 +132,7 @@ test_inject_v2 runN dim e = sh2 <- forAll dim xs <- forAll (array sh1 e) ys <- forAll (array sh2 e) - let !go = runN (A.zipWith A.V2_) in go xs ys === zipWithRef V2 xs ys + let !go = runN (A.zipWith A.V2_) in go xs ys === zipWithRef Vec2 xs ys test_inject_v3 :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) @@ -148,7 +148,7 @@ test_inject_v3 runN dim e = xs <- forAll (array sh1 e) ys <- forAll (array sh2 e) zs <- forAll (array sh3 e) - let !go = runN (A.zipWith3 A.V3_) in go xs ys zs === zipWith3Ref V3 xs ys zs + let !go = runN (A.zipWith3 A.V3_) in go xs ys zs === zipWith3Ref Vec3 xs ys zs test_inject_v4 :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) @@ -166,17 +166,17 @@ test_inject_v4 runN dim e = ys <- forAll (array sh2 e) zs <- forAll (array sh3 e) ws <- forAll (array sh4 e) - let !go = runN (A.zipWith4 A.V4_) in go xs ys zs ws === zipWith4Ref V4 xs ys zs ws + let !go = runN (A.zipWith4 A.V4_) in go xs ys zs ws === zipWith4Ref Vec4 xs ys zs ws -unpackV2' :: VecElt e => Exp (V2 e) -> (Exp e, Exp e) -unpackV2' (A.V2_ a b) = (a, b) +unpackVec2' :: VecElt e => Exp (Vec2 e) -> (Exp e, Exp e) +unpackVec2' (A.V2_ a b) = (a, b) -unpackV3' :: VecElt e => Exp (V3 e) -> (Exp e, Exp e, Exp e) -unpackV3' (A.V3_ a b c) = (a, b, c) +unpackVec3' :: VecElt e => Exp (Vec3 e) -> (Exp e, Exp e, Exp e) +unpackVec3' (A.V3_ a b c) = (a, b, c) -unpackV4' :: VecElt e => Exp (V4 e) -> (Exp e, Exp e, Exp e, Exp e) -unpackV4' (A.V4_ a b c d) = (a, b, c, d) +unpackVec4' :: VecElt e => Exp (Vec4 e) -> (Exp e, Exp e, Exp e, Exp e) +unpackVec4' (A.V4_ a b c d) = (a, b, c, d) -- Reference Implementation diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index 40ae09a9c..c1ab078d0 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -51,11 +51,11 @@ -- * Char -- -- SIMD vector types: --- * V2 --- * V3 --- * V4 --- * V8 --- * V16 +-- * Vec2 +-- * Vec3 +-- * Vec4 +-- * Vec8 +-- * Vec16 -- -- Note that 'Int' has the same bit width as in plain Haskell computations. -- 'Float' and 'Double' represent IEEE single and double precision floating @@ -392,25 +392,25 @@ type family BitSize a :: Nat -- -- A simple polymorphic representation of SIMD types such as the following: -- --- > data V2 a = V2 !a !a +-- > data Vec2 a = Vec2 !a !a -- --- is not able to unpack the values into the constructor, meaning that 'V2' is --- storing pointers to (strict) values on the heap, which is a very inefficient --- representation. +-- is not able to unpack the values into the constructor, meaning that +-- 'Vec2' is storing pointers to (strict) values on the heap, which is +-- a very inefficient representation. -- -- We might try defining a data family instead so that we can get efficient -- unboxed representations, and even make use of the unlifted SIMD types GHC -- knows about: -- --- > data family V2 a :: * --- > data instance V2 Float = V2_Float Float# Float# -- reasonable --- > data instance V2 Double = V2_Double DoubleX2# -- built in! +-- > data family Vec2 a :: * +-- > data instance Vec2 Float = Vec2_Float Float# Float# -- reasonable +-- > data instance Vec2 Double = Vec2_Double DoubleX2# -- built in! -- -- However, this runs into the problem that GHC stores all values as word sized -- entities: -- --- > data instance V2 Int = V2_Int Int# Int# --- > data instance V2 Int8 = V2_Int8 Int8# Int8# -- Int8# does not exist; requires a full Int# +-- > data instance Vec2 Int = Vec2_Int Int# Int# +-- > data instance Vec2 Int8 = Vec2_Int8 Int8# Int8# -- Int8# does not exist; requires a full Int# -- -- which, again, is very memory inefficient. -- @@ -467,63 +467,67 @@ getPrim (NonNumSingleType TypeChar) = PrimDict getPrim (NonNumSingleType TypeBool) = error "prim: We don't support vector of bools yet" - -- Type synonyms for common SIMD vector types -- -type V2 a = Vec 2 a -type V3 a = Vec 3 a -- XXX: dubious? -type V4 a = Vec 4 a -type V8 a = Vec 8 a -type V16 a = Vec 16 a - -pattern V2 :: Prim a => a -> a -> V2 a -pattern V2 a b <- (unpackV2 -> (a,b)) - where V2 = packV2 -{-# COMPLETE V2 #-} - -pattern V3 :: Prim a => a -> a -> a -> V3 a -pattern V3 a b c <- (unpackV3 -> (a,b,c)) - where V3 = packV3 -{-# COMPLETE V3 #-} - -pattern V4 :: Prim a => a -> a -> a -> a -> V4 a -pattern V4 a b c d <- (unpackV4 -> (a,b,c,d)) - where V4 = packV4 -{-# COMPLETE V4 #-} - -pattern V8 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> V8 a -pattern V8 a b c d e f g h <- (unpackV8 -> (a,b,c,d,e,f,g,h)) - where V8 = packV8 -{-# COMPLETE V8 #-} - -pattern V16 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> V16 a -pattern V16 a b c d e f g h i j k l m n o p <- (unpackV16 -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) - where V16 = packV16 -{-# COMPLETE V16 #-} - -unpackV2 :: Prim a => V2 a -> (a,a) -unpackV2 (Vec ba#) = +-- Note that non-power-of-two sized SIMD vectors are a bit dubious, and +-- special care must be taken in the code generator. For example, LLVM will +-- treat a Vec3 with alignment of _4_, meaning that reads and writes will +-- be (without further action) incorrect. +-- +type Vec2 a = Vec 2 a +type Vec3 a = Vec 3 a +type Vec4 a = Vec 4 a +type Vec8 a = Vec 8 a +type Vec16 a = Vec 16 a + +pattern Vec2 :: Prim a => a -> a -> Vec2 a +pattern Vec2 a b <- (unpackVec2 -> (a,b)) + where Vec2 = packVec2 +{-# COMPLETE Vec2 #-} + +pattern Vec3 :: Prim a => a -> a -> a -> Vec3 a +pattern Vec3 a b c <- (unpackVec3 -> (a,b,c)) + where Vec3 = packVec3 +{-# COMPLETE Vec3 #-} + +pattern Vec4 :: Prim a => a -> a -> a -> a -> Vec4 a +pattern Vec4 a b c d <- (unpackVec4 -> (a,b,c,d)) + where Vec4 = packVec4 +{-# COMPLETE Vec4 #-} + +pattern Vec8 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> Vec8 a +pattern Vec8 a b c d e f g h <- (unpackVec8 -> (a,b,c,d,e,f,g,h)) + where Vec8 = packVec8 +{-# COMPLETE Vec8 #-} + +pattern Vec16 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> Vec16 a +pattern Vec16 a b c d e f g h i j k l m n o p <- (unpackVec16 -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) + where Vec16 = packVec16 +{-# COMPLETE Vec16 #-} + +unpackVec2 :: Prim a => Vec2 a -> (a,a) +unpackVec2 (Vec ba#) = ( indexByteArray# ba# 0# , indexByteArray# ba# 1# ) -unpackV3 :: Prim a => V3 a -> (a,a,a) -unpackV3 (Vec ba#) = +unpackVec3 :: Prim a => Vec3 a -> (a,a,a) +unpackVec3 (Vec ba#) = ( indexByteArray# ba# 0# , indexByteArray# ba# 1# , indexByteArray# ba# 2# ) -unpackV4 :: Prim a => V4 a -> (a,a,a,a) -unpackV4 (Vec ba#) = +unpackVec4 :: Prim a => Vec4 a -> (a,a,a,a) +unpackVec4 (Vec ba#) = ( indexByteArray# ba# 0# , indexByteArray# ba# 1# , indexByteArray# ba# 2# , indexByteArray# ba# 3# ) -unpackV8 :: Prim a => V8 a -> (a,a,a,a,a,a,a,a) -unpackV8 (Vec ba#) = +unpackVec8 :: Prim a => Vec8 a -> (a,a,a,a,a,a,a,a) +unpackVec8 (Vec ba#) = ( indexByteArray# ba# 0# , indexByteArray# ba# 1# , indexByteArray# ba# 2# @@ -534,8 +538,8 @@ unpackV8 (Vec ba#) = , indexByteArray# ba# 7# ) -unpackV16 :: Prim a => V16 a -> (a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a) -unpackV16 (Vec ba#) = +unpackVec16 :: Prim a => Vec16 a -> (a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a) +unpackVec16 (Vec ba#) = ( indexByteArray# ba# 0# , indexByteArray# ba# 1# , indexByteArray# ba# 2# @@ -554,16 +558,16 @@ unpackV16 (Vec ba#) = , indexByteArray# ba# 15# ) -packV2 :: Prim a => a -> a -> V2 a -packV2 a b = runST $ do +packVec2 :: Prim a => a -> a -> Vec2 a +packVec2 a b = runST $ do mba <- newByteArray (2 * sizeOf a) writeByteArray mba 0 a writeByteArray mba 1 b ByteArray ba# <- unsafeFreezeByteArray mba return $! Vec ba# -packV3 :: Prim a => a -> a -> a -> V3 a -packV3 a b c = runST $ do +packVec3 :: Prim a => a -> a -> a -> Vec3 a +packVec3 a b c = runST $ do mba <- newByteArray (3 * sizeOf a) writeByteArray mba 0 a writeByteArray mba 1 b @@ -571,8 +575,8 @@ packV3 a b c = runST $ do ByteArray ba# <- unsafeFreezeByteArray mba return $! Vec ba# -packV4 :: Prim a => a -> a -> a -> a -> V4 a -packV4 a b c d = runST $ do +packVec4 :: Prim a => a -> a -> a -> a -> Vec4 a +packVec4 a b c d = runST $ do mba <- newByteArray (4 * sizeOf a) writeByteArray mba 0 a writeByteArray mba 1 b @@ -581,8 +585,8 @@ packV4 a b c d = runST $ do ByteArray ba# <- unsafeFreezeByteArray mba return $! Vec ba# -packV8 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> V8 a -packV8 a b c d e f g h = runST $ do +packVec8 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> Vec8 a +packVec8 a b c d e f g h = runST $ do mba <- newByteArray (8 * sizeOf a) writeByteArray mba 0 a writeByteArray mba 1 b @@ -595,8 +599,8 @@ packV8 a b c d e f g h = runST $ do ByteArray ba# <- unsafeFreezeByteArray mba return $! Vec ba# -packV16 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> V16 a -packV16 a b c d e f g h i j k l m n o p = runST $ do +packVec16 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> Vec16 a +packVec16 a b c d e f g h i j k l m n o p = runST $ do mba <- newByteArray (16 * sizeOf a) writeByteArray mba 0 a writeByteArray mba 1 b From 1aecc7c3fb1bcdcc9e7466edbb14732052537b08 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 8 Jun 2020 16:33:04 +0200 Subject: [PATCH 236/316] rename embedded patterns V2_ to V2 etc. --- src/Data/Array/Accelerate.hs | 10 +- src/Data/Array/Accelerate/Data/Complex.hs | 6 +- src/Data/Array/Accelerate/Pattern.hs | 505 ++++++++---------- .../Accelerate/Test/NoFib/Prelude/SIMD.hs | 12 +- 4 files changed, 244 insertions(+), 289 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 760af531e..71d3a2838 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -345,11 +345,11 @@ module Data.Array.Accelerate ( pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, - pattern Vec2, pattern V2_, - pattern Vec3, pattern V3_, - pattern Vec4, pattern V4_, - pattern Vec8, pattern V8_, - pattern Vec16, pattern V16_, + pattern Vec2, pattern V2, + pattern Vec3, pattern V3, + pattern Vec4, pattern V4, + pattern Vec8, pattern V8, + pattern Vec16, pattern V16, pattern True_, pattern False_, diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index 3875cef50..ddf4d111a 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -137,15 +137,15 @@ constructComplex r i = case complexR $ eltType @a of r' = coerce @a @(EltRepr a) r i' = coerce i v :: Exp (Vec2 (EltRepr a)) - v = V2_ r' i' + v = V2 r' i' in coerce @(Vec2 (EltRepr a)) @(Complex a) $ v ComplexRtup -> coerce $ T2 r i deconstructComplex :: forall a. Elt a => Exp (Complex a) -> (Exp a, Exp a) deconstructComplex c = case complexR $ eltType @a of - ComplexRvec _ -> let V2_ r i = coerce @(Complex a) @(Vec2 (EltRepr a)) c in (coerce r, coerce i) - ComplexRtup -> let T2 r i = coerce c in (r, i) + ComplexRvec _ -> let V2 r i = coerce @(Complex a) @(Vec2 (EltRepr a)) c in (coerce r, coerce i) + ComplexRtup -> let T2 r i = coerce c in (r, i) coerce :: EltRepr a ~ EltRepr b => Exp a -> Exp b coerce (Exp e) = Exp e diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index db9cc145c..52026b41f 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -1,275 +1,230 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ <= 800 -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif --- | --- Module : Data.Array.Accelerate.Pattern --- Copyright : [2018..2019] The Accelerate Team --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.Pattern ( - - pattern Pattern, - pattern T2, pattern T3, pattern T4, pattern T5, pattern T6, - pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, - pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, - - pattern Z_, pattern Ix, pattern (::.), - pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, - pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, - - pattern V2_, pattern V3_, pattern V4_, pattern V8_, pattern V16_, - -) where - -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Type - -import Language.Haskell.TH hiding ( Exp ) -import Language.Haskell.TH.Extra - - --- | A pattern synonym for working with (product) data types. You can declare --- your own pattern synonyms based off of this. --- -pattern Pattern :: forall b a context. IsPattern context a b => b -> context a -pattern Pattern vars <- (destruct @context -> vars) - where Pattern = construct @context - -class IsPattern con a t where - construct :: t -> con a - destruct :: con a -> t - - --- | Pattern synonyms for indices, which may be more convenient to use than --- 'Data.Array.Accelerate.Lift.lift' and --- 'Data.Array.Accelerate.Lift.unlift'. --- -pattern Z_ :: Exp DIM0 -pattern Z_ = Pattern Z -{-# COMPLETE Z_ #-} - -infixl 3 ::. -pattern (::.) :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) -pattern a ::. b = Pattern (a :. b) -{-# COMPLETE (::.) #-} - -pattern Ix :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) -pattern a `Ix` b = a ::. b -{-# COMPLETE Ix #-} - --- IsPattern instances for Shape nil and cons --- -instance IsPattern Exp Z Z where - construct _ = constant Z - destruct _ = Z - -instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where - construct (Exp a :. Exp b) = Exp $ SmartExp $ Pair a b - destruct (Exp t) = Exp (SmartExp $ Prj PairIdxLeft t) :. Exp (SmartExp $ Prj PairIdxRight t) - --- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of the --- (unremarkable) boilerplate for us, but since the implementation is a little --- tricky it is debatable whether or not this is a good idea... --- -$(runQ $ do - let - -- Generate instance declarations for IsPattern of the form: - -- instance (Elt x, EltRepr x ~ (((), EltRepr a), EltRepr b), Elt a, Elt b,) => IsPattern Exp x (Exp a, Exp b) - mkIsPattern :: Name -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] - mkIsPattern con cst repr smart prj nil pair n = do - a <- newName "a" - let - -- Type variables for the elements - xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - -- Last argument to `IsPattern`, eg (Exp, a, Exp b) in the example - b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs - -- Representation as snoc-list of pairs, eg (((), EltRepr a), EltRepr b) - snoc = foldl (\sn t -> [t| ($sn, $(appT repr $ varT t)) |]) [t| () |] xs - -- Constraints for the type class, consisting of Elt constraints on all type variables, - -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`. - contexts = appT cst [t| $(varT a) |] - : [t| $repr $(varT a) ~ $snoc |] - : map (\t -> appT cst (varT t)) xs - -- Store all constraints in a tuple - context = foldl (\ts t -> appT ts t) (tupleT $ length contexts) contexts - -- - get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] - get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) - -- - _x <- newName "_x" - [d| instance $context => IsPattern $(conT con) $(varT a) $b where - construct $(tupP (map (conP con . return . varP) xs)) = - $(conE con) $(foldl (\vs v -> appE smart (appE (appE pair vs) (varE v))) (appE smart nil) xs) - destruct $(conP con [varP _x]) = - $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0])) - |] - - mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [t| EltRepr |] [| SmartExp |] [| Prj |] [| Nil |] [| Pair |] - mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [t| ArrRepr |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] - -- - es <- mapM mkExpPattern [0..16] - as <- mapM mkAccPattern [0..16] - return $ concat (es ++ as) - ) - --- | Specialised pattern synonyms for tuples, which may be more convenient to --- use than 'Data.Array.Accelerate.Lift.lift' and --- 'Data.Array.Accelerate.Lift.unlift'. For example, to construct a pair: --- --- > let a = 4 :: Exp Int --- > let b = 2 :: Exp Float --- > let c = T2 a b -- :: Exp (Int, Float); equivalent to 'lift (a,b)' --- --- Similarly they can be used to destruct values: --- --- > let T2 x y = c -- x :: Exp Int, y :: Exp Float; equivalent to 'let (x,y) = unlift c' --- --- These pattern synonyms can be used for both 'Exp' and 'Acc' terms. --- --- Similarly, we have patterns for constructing and destructing indices of --- a given dimensionality: --- --- > let ix = Ix 2 3 -- :: Exp DIM2 --- > let I2 y x = ix -- y :: Exp Int, x :: Exp Int --- -$(runQ $ do - let - mkT :: Int -> Q [Dec] - mkT n = - let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - ts = map varT xs - name = mkName ('T':show n) - con = varT (mkName "con") - ty1 = tupT ts - ty2 = tupT (map (con `appT`) ts) - sig = foldr (\t r -> [t| $con $t -> $r |]) (appT con ty1) ts - in - sequence - [ patSynSigD name [t| IsPattern $con $ty1 $ty2 => $sig |] - , patSynD name (prefixPatSyn xs) implBidir [p| Pattern $(tupP (map varP xs)) |] - , pragCompleteD [name] (Just ''Acc) - , pragCompleteD [name] (Just ''Exp) - ] - - mkI :: Int -> Q [Dec] - mkI n = - let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - ts = map varT xs - name = mkName ('I':show n) - ix = mkName "Ix" - cst = tupT (map (\t -> [t| Elt $t |]) ts) - dim = foldl (\h t -> [t| $h :. $t |]) [t| Z |] ts - sig = foldr (\t r -> [t| Exp $t -> $r |]) [t| Exp $dim |] ts - in - sequence - [ patSynSigD name [t| $cst => $sig |] - , patSynD name (prefixPatSyn xs) implBidir (foldl (\ps p -> infixP ps ix (varP p)) [p| Z_ |] xs) - , pragCompleteD [name] Nothing - ] - -- - ts <- mapM mkT [2..16] - is <- mapM mkI [0..9] - return $ concat (ts ++ is) - ) - --- Newtype to make difference between T and P instances clear -newtype VecPattern a = VecPattern a - -instance VecElt a => IsPattern Exp (Vec 2 a) (VecPattern (Exp a, Exp a)) where - construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup - where - r = vecR2 $ singleType @(EltRepr a) - Exp tup = construct as :: Exp (a, a) - destruct e = VecPattern $ destruct e' - where - e' :: Exp (a, a) - e' = Exp $ SmartExp $ VecUnpack r $ unExp e - r = vecR2 $ singleType @(EltRepr a) - -instance VecElt a => IsPattern Exp (Vec 3 a) (VecPattern (Exp a, Exp a, Exp a)) where - construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup - where - r = vecR3 $ singleType @(EltRepr a) - Exp tup = construct as :: Exp (a, a, a) - destruct e = VecPattern $ destruct e' - where - e' :: Exp (a, a, a) - e' = Exp $ SmartExp $ VecUnpack r $ unExp e - r = vecR3 $ singleType @(EltRepr a) - -instance VecElt a => IsPattern Exp (Vec 4 a) (VecPattern (Exp a, Exp a, Exp a, Exp a)) where - construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup - where - r = vecR4 $ singleType @(EltRepr a) - Exp tup = construct as :: Exp (a, a, a, a) - destruct e = VecPattern $ destruct e' - where - e' :: Exp (a, a, a, a) - e' = Exp $ SmartExp $ VecUnpack r $ unExp e - r = vecR4 $ singleType @(EltRepr a) - -instance VecElt a => IsPattern Exp (Vec 8 a) (VecPattern (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)) where - construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup - where - r = vecR8 $ singleType @(EltRepr a) - Exp tup = construct as :: Exp (a, a, a, a, a, a, a, a) - destruct e = VecPattern $ destruct e' - where - e' :: Exp (a, a, a, a, a, a, a, a) - e' = Exp $ SmartExp $ VecUnpack r $ unExp e - r = vecR8 $ singleType @(EltRepr a) - -instance VecElt a => IsPattern Exp (Vec 16 a) (VecPattern (Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a, Exp a)) where - construct (VecPattern as) = Exp $ SmartExp $ VecPack r tup - where - r = vecR16 $ singleType @(EltRepr a) - Exp tup = construct as :: Exp (a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a) - destruct e = VecPattern $ destruct e' - where - e' :: Exp (a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a) - e' = Exp $ SmartExp $ VecUnpack r $ unExp e - r = vecR16 $ singleType @(EltRepr a) - -pattern V2_ :: VecElt a => Exp a -> Exp a -> Exp (Vec 2 a) -pattern V2_ a b = Pattern (VecPattern (a, b)) -{-# COMPLETE V2_ #-} - -pattern V3_ :: VecElt a => Exp a -> Exp a -> Exp a -> Exp (Vec 3 a) -pattern V3_ a b c = Pattern (VecPattern (a, b, c)) -{-# COMPLETE V3_ #-} - -pattern V4_ :: VecElt a => Exp a -> Exp a -> Exp a -> Exp a -> Exp (Vec 4 a) -pattern V4_ a b c d = Pattern (VecPattern (a, b, c, d)) -{-# COMPLETE V4_ #-} - -pattern V8_ :: VecElt a => Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp (Vec 8 a) -pattern V8_ a b c d e f g h = Pattern (VecPattern (a, b, c, d, e, f, g, h)) -{-# COMPLETE V8_ #-} - -pattern V16_ :: VecElt a - => Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> - Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp a -> Exp (Vec 16 a) -pattern V16_ a b c d e f g h - i j k l m n o p = Pattern (VecPattern (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)) -{-# COMPLETE V16_ #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +#if __GLASGOW_HASKELL__ <= 800 +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} +#endif +-- | +-- Module : Data.Array.Accelerate.Pattern +-- Copyright : [2018..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Pattern ( + + pattern Pattern, + pattern T2, pattern T3, pattern T4, pattern T5, pattern T6, + pattern T7, pattern T8, pattern T9, pattern T10, pattern T11, + pattern T12, pattern T13, pattern T14, pattern T15, pattern T16, + + pattern Z_, pattern Ix, pattern (::.), + pattern I0, pattern I1, pattern I2, pattern I3, pattern I4, + pattern I5, pattern I6, pattern I7, pattern I8, pattern I9, + + pattern V2, pattern V3, pattern V4, pattern V8, pattern V16, + +) where + +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Representation ( VecR(..) ) +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Type + +import Language.Haskell.TH hiding ( Exp ) +import Language.Haskell.TH.Extra + + +-- | A pattern synonym for working with (product) data types. You can declare +-- your own pattern synonyms based off of this. +-- +pattern Pattern :: forall b a context. IsPattern context a b => b -> context a +pattern Pattern vars <- (destruct @context -> vars) + where Pattern = construct @context + +class IsPattern con a t where + construct :: t -> con a + destruct :: con a -> t + + +-- | Pattern synonyms for indices, which may be more convenient to use than +-- 'Data.Array.Accelerate.Lift.lift' and +-- 'Data.Array.Accelerate.Lift.unlift'. +-- +pattern Z_ :: Exp DIM0 +pattern Z_ = Pattern Z +{-# COMPLETE Z_ #-} + +infixl 3 ::. +pattern (::.) :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) +pattern a ::. b = Pattern (a :. b) +{-# COMPLETE (::.) #-} + +pattern Ix :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) +pattern a `Ix` b = a ::. b +{-# COMPLETE Ix #-} + +-- IsPattern instances for Shape nil and cons +-- +instance IsPattern Exp Z Z where + construct _ = constant Z + destruct _ = Z + +instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where + construct (Exp a :. Exp b) = Exp $ SmartExp $ Pair a b + destruct (Exp t) = Exp (SmartExp $ Prj PairIdxLeft t) :. Exp (SmartExp $ Prj PairIdxRight t) + +-- Newtype wrapper to distinguish between T and V patterns +-- +newtype VecPattern a = VecPattern a + +-- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of the +-- (unremarkable) boilerplate for us, but since the implementation is a little +-- tricky it is debatable whether or not this is a good idea... +-- +$(runQ $ do + let + -- Generate instance declarations for IsPattern of the form: + -- instance (Elt x, EltRepr x ~ (((), EltRepr a), EltRepr b), Elt a, Elt b,) => IsPattern Exp x (Exp a, Exp b) + mkIsPattern :: Name -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] + mkIsPattern con cst repr smart prj nil pair n = do + a <- newName "a" + let + -- Type variables for the elements + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + -- Last argument to `IsPattern`, eg (Exp, a, Exp b) in the example + b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs + -- Representation as snoc-list of pairs, eg (((), EltRepr a), EltRepr b) + snoc = foldl (\sn t -> [t| ($sn, $(appT repr $ varT t)) |]) [t| () |] xs + -- Constraints for the type class, consisting of Elt constraints on all type variables, + -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`. + contexts = appT cst [t| $(varT a) |] + : [t| $repr $(varT a) ~ $snoc |] + : map (\t -> appT cst (varT t)) xs + -- Store all constraints in a tuple + context = foldl (\ts t -> appT ts t) (tupleT $ length contexts) contexts + -- + get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] + get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) + -- + _x <- newName "_x" + [d| instance $context => IsPattern $(conT con) $(varT a) $b where + construct $(tupP (map (conP con . return . varP) xs)) = + $(conE con) $(foldl (\vs v -> appE smart (appE (appE pair vs) (varE v))) (appE smart nil) xs) + destruct $(conP con [varP _x]) = + $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0])) + |] + + mkVecPattern :: Int -> Q [Dec] + mkVecPattern n = do + a <- newName "a" + let + v = foldr appE [| VecRnil (singleType @(EltRepr $(varT a))) |] (replicate n [| VecRsucc |]) + r = tupT (replicate n [t| Exp $(varT a) |]) + t = tupT (replicate n (varT a)) + -- + [d| instance VecElt $(varT a) => IsPattern Exp (Vec $(litT (numTyLit (fromIntegral n))) $(varT a)) (VecPattern $r) where + construct (VecPattern x) = + case construct x :: Exp $t of + Exp x' -> Exp (SmartExp (VecPack $v x')) + destruct (Exp x) = VecPattern (destruct (Exp (SmartExp (VecUnpack $v x)) :: Exp $t)) + |] + + mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [t| EltRepr |] [| SmartExp |] [| Prj |] [| Nil |] [| Pair |] + mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [t| ArrRepr |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] + -- + es <- mapM mkExpPattern [0..16] + as <- mapM mkAccPattern [0..16] + vs <- mapM mkVecPattern [2,3,4,8,16] + return $ concat (es ++ as ++ vs) + ) + +-- | Specialised pattern synonyms for tuples, which may be more convenient to +-- use than 'Data.Array.Accelerate.Lift.lift' and +-- 'Data.Array.Accelerate.Lift.unlift'. For example, to construct a pair: +-- +-- > let a = 4 :: Exp Int +-- > let b = 2 :: Exp Float +-- > let c = T2 a b -- :: Exp (Int, Float); equivalent to 'lift (a,b)' +-- +-- Similarly they can be used to destruct values: +-- +-- > let T2 x y = c -- x :: Exp Int, y :: Exp Float; equivalent to 'let (x,y) = unlift c' +-- +-- These pattern synonyms can be used for both 'Exp' and 'Acc' terms. +-- +-- Similarly, we have patterns for constructing and destructing indices of +-- a given dimensionality: +-- +-- > let ix = Ix 2 3 -- :: Exp DIM2 +-- > let I2 y x = ix -- y :: Exp Int, x :: Exp Int +-- +$(runQ $ do + let + mkT :: Int -> Q [Dec] + mkT n = + let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + name = mkName ('T':show n) + con = varT (mkName "con") + ty1 = tupT ts + ty2 = tupT (map (con `appT`) ts) + sig = foldr (\t r -> [t| $con $t -> $r |]) (appT con ty1) ts + in + sequence + [ patSynSigD name [t| IsPattern $con $ty1 $ty2 => $sig |] + , patSynD name (prefixPatSyn xs) implBidir [p| Pattern $(tupP (map varP xs)) |] + , pragCompleteD [name] (Just ''Acc) + , pragCompleteD [name] (Just ''Exp) + ] + + mkI :: Int -> Q [Dec] + mkI n = + let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + name = mkName ('I':show n) + ix = mkName "Ix" + cst = tupT (map (\t -> [t| Elt $t |]) ts) + dim = foldl (\h t -> [t| $h :. $t |]) [t| Z |] ts + sig = foldr (\t r -> [t| Exp $t -> $r |]) [t| Exp $dim |] ts + in + sequence + [ patSynSigD name [t| $cst => $sig |] + , patSynD name (prefixPatSyn xs) implBidir (foldl (\ps p -> infixP ps ix (varP p)) [p| Z_ |] xs) + , pragCompleteD [name] Nothing + ] + + mkV :: Int -> Q [Dec] + mkV n = do + a <- newName "a" + let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = replicate n (varT a) + name = mkName ('V':show n) + sig = foldr (\t r -> [t| Exp $t -> $r |]) [t| Exp (Vec $(litT (numTyLit (fromIntegral n))) $(varT a)) |] ts + -- + sequence + [ patSynSigD name [t| VecElt $(varT a) => $sig |] + , patSynD name (prefixPatSyn xs) implBidir [p| Pattern (VecPattern $(tupP (map varP xs))) |] + , pragCompleteD [name] Nothing + ] + -- + ts <- mapM mkT [2..16] + is <- mapM mkI [0..9] + vs <- mapM mkV [2,3,4,8,16] + return $ concat (ts ++ is ++ vs) + ) + diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs index 49140e88d..9e728f591 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs @@ -132,7 +132,7 @@ test_inject_v2 runN dim e = sh2 <- forAll dim xs <- forAll (array sh1 e) ys <- forAll (array sh2 e) - let !go = runN (A.zipWith A.V2_) in go xs ys === zipWithRef Vec2 xs ys + let !go = runN (A.zipWith A.V2) in go xs ys === zipWithRef Vec2 xs ys test_inject_v3 :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) @@ -148,7 +148,7 @@ test_inject_v3 runN dim e = xs <- forAll (array sh1 e) ys <- forAll (array sh2 e) zs <- forAll (array sh3 e) - let !go = runN (A.zipWith3 A.V3_) in go xs ys zs === zipWith3Ref Vec3 xs ys zs + let !go = runN (A.zipWith3 A.V3) in go xs ys zs === zipWith3Ref Vec3 xs ys zs test_inject_v4 :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) @@ -166,17 +166,17 @@ test_inject_v4 runN dim e = ys <- forAll (array sh2 e) zs <- forAll (array sh3 e) ws <- forAll (array sh4 e) - let !go = runN (A.zipWith4 A.V4_) in go xs ys zs ws === zipWith4Ref Vec4 xs ys zs ws + let !go = runN (A.zipWith4 A.V4) in go xs ys zs ws === zipWith4Ref Vec4 xs ys zs ws unpackVec2' :: VecElt e => Exp (Vec2 e) -> (Exp e, Exp e) -unpackVec2' (A.V2_ a b) = (a, b) +unpackVec2' (A.V2 a b) = (a, b) unpackVec3' :: VecElt e => Exp (Vec3 e) -> (Exp e, Exp e, Exp e) -unpackVec3' (A.V3_ a b c) = (a, b, c) +unpackVec3' (A.V3 a b c) = (a, b, c) unpackVec4' :: VecElt e => Exp (Vec4 e) -> (Exp e, Exp e, Exp e, Exp e) -unpackVec4' (A.V4_ a b c d) = (a, b, c, d) +unpackVec4' (A.V4 a b c d) = (a, b, c, d) -- Reference Implementation From a0616a47a2fc76258bcfd476583d0696072b96ae Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 8 Jun 2020 17:15:56 +0200 Subject: [PATCH 237/316] use TH to generate Exp lift and unlift instances --- src/Data/Array/Accelerate/Lift.hs | 234 ++------------ src/Data/Array/Accelerate/Smart.hs | 495 +---------------------------- 2 files changed, 33 insertions(+), 696 deletions(-) diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 663dba18e..5a5cdfca6 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -39,6 +39,7 @@ module Data.Array.Accelerate.Lift ( ) where import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -46,7 +47,7 @@ import Language.Haskell.TH hiding ( Exp import Language.Haskell.TH.Extra --- |Lift a unary function into 'Exp'. +-- | Lift a unary function into 'Exp'. -- lift1 :: (Unlift Exp a, Lift Exp b) => (a -> b) @@ -54,7 +55,7 @@ lift1 :: (Unlift Exp a, Lift Exp b) -> Exp (Plain b) lift1 f = lift . f . unlift --- |Lift a binary function into 'Exp'. +-- | Lift a binary function into 'Exp'. -- lift2 :: (Unlift Exp a, Unlift Exp b, Lift Exp c) => (a -> b -> c) @@ -63,7 +64,7 @@ lift2 :: (Unlift Exp a, Unlift Exp b, Lift Exp c) -> Exp (Plain c) lift2 f x y = lift $ f (unlift x) (unlift y) --- |Lift a ternary function into 'Exp'. +-- | Lift a ternary function into 'Exp'. -- lift3 :: (Unlift Exp a, Unlift Exp b, Unlift Exp c, Lift Exp d) => (a -> b -> c -> d) @@ -73,17 +74,17 @@ lift3 :: (Unlift Exp a, Unlift Exp b, Unlift Exp c, Lift Exp d) -> 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. +-- | 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. +-- | 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. +-- | 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) @@ -119,7 +120,8 @@ class Lift c e => Unlift c e where unlift :: c (Plain e) -> e --- identity instances +-- Identity instances +-- ------------------ instance Lift Exp (Exp e) where type Plain (Exp e) = e @@ -143,45 +145,40 @@ instance Unlift Acc (Acc a) where -- unlift = id --- instances for indices - -instance Lift Exp () where - type Plain () = () - lift _ = Exp $ SmartExp Nil - -instance Unlift Exp () where - unlift _ = () +-- Instances for indices +-- --------------------- instance Lift Exp Z where type Plain Z = Z - lift _ = Exp $ SmartExp Nil + lift _ = Z_ instance Unlift Exp Z where unlift _ = Z instance (Elt (Plain ix), Lift Exp ix) => Lift Exp (ix :. Int) where type Plain (ix :. Int) = Plain ix :. Int - lift (ix:.i) = Exp $ SmartExp $ Pair (unExp $ lift ix) (unExp $ expConst i) + lift (ix :. i) = lift ix ::. lift i instance (Elt (Plain ix), Lift Exp ix) => Lift Exp (ix :. All) where type Plain (ix :. All) = Plain ix :. All - lift (ix:.i) = Exp $ SmartExp $ Pair (unExp $ lift ix) (unExp $ constant i) + lift (ix :. i) = lift ix ::. constant i instance (Elt e, Elt (Plain ix), Lift Exp ix) => Lift Exp (ix :. Exp e) where type Plain (ix :. Exp e) = Plain ix :. e - lift (ix :. Exp i) = Exp $ SmartExp $ Pair (unExp $ lift ix) i + lift (ix :. i) = lift ix ::. i instance {-# OVERLAPPABLE #-} (Elt e, Elt (Plain ix), Unlift Exp ix) => Unlift Exp (ix :. Exp e) where - unlift (Exp e) = unlift (Exp $ SmartExp $ Prj PairIdxLeft e) :. Exp (SmartExp $ Prj PairIdxRight e) + unlift (ix ::. i) = unlift ix :. i instance {-# OVERLAPPABLE #-} (Elt e, Elt ix) => Unlift Exp (Exp ix :. Exp e) where - unlift (Exp e) = (Exp $ SmartExp $ Prj PairIdxLeft e) :. Exp (SmartExp $ Prj PairIdxRight e) + unlift (ix ::. i) = ix :. i instance (Shape sh, Elt (Any sh)) => Lift Exp (Any sh) where type Plain (Any sh) = Any sh lift Any = constant Any --- instances for numeric types +-- Instances for numeric types +-- --------------------------- {-# INLINE expConst #-} expConst :: forall e. Elt e => IsScalar (EltRepr e) => e -> Exp e @@ -300,193 +297,22 @@ instance Lift Exp CUChar where lift = expConst -- 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 - -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, Lift Exp p, - 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), Elt (Plain p)) - => Lift Exp (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where - type Plain (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) - = (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, Plain p) - lift (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) - = tup16 (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, lift p) - -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) - => 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, Exp p) where - unlift = untup16 +instance Lift Exp () where + type Plain () = () + lift _ = Exp (SmartExp Nil) +instance Unlift Exp () where + unlift _ = () instance Lift Acc () where type Plain () = () lift _ = Acc (SmartAcc Anil) +instance Unlift Acc () where + unlift _ = () + instance (Shape sh, Elt e) => Lift Acc (Array sh e) where type Plain (Array sh e) = Array sh e lift (Array arr) = Acc $ SmartAcc $ Use (arrayR @sh @e) arr @@ -525,8 +351,10 @@ $(runQ $ do |] mkAccInstances = mkInstances (mkName "Acc") [t| Arrays |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] + mkExpInstances = mkInstances (mkName "Exp") [t| Elt |] [| SmartExp |] [| Prj |] [| Nil |] [| Pair |] -- as <- mapM mkAccInstances [2..16] - return $ concat as + es <- mapM mkExpInstances [2..16] + return $ concat (as ++ es) ) diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index bd381b206..c2749b57d 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -6,7 +6,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -37,10 +36,6 @@ module Data.Array.Accelerate.Smart ( -- * Smart destructors for shapes indexHead, indexTail, - -- * 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, - -- * Smart constructors for constants mkMinBound, mkMaxBound, mkPi, mkSin, mkCos, mkTan, @@ -940,9 +935,6 @@ instance (Stencil (sh:.Int) a row8, stencilPrj @(sh:.Int) @a $ prj1 s, stencilPrj @(sh:.Int) @a $ prj0 s) --- Auxiliary tuple index constants --- - prjTail :: SmartExp (t, a) -> SmartExp t prjTail = SmartExp . Prj PairIdxLeft @@ -973,26 +965,6 @@ prj7 = prj6 . prjTail prj8 :: SmartExp (((((((((t, a), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a prj8 = prj7 . prjTail -prj9 :: SmartExp ((((((((((t, a), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a -prj9 = prj8 . prjTail - -prj10 :: SmartExp (((((((((((t, a), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a -prj10 = prj9 . prjTail - -prj11 :: SmartExp ((((((((((((t, a), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a -prj11 = prj10 . prjTail - -prj12 :: SmartExp (((((((((((((t, a), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a -prj12 = prj11 . prjTail - -prj13 :: SmartExp ((((((((((((((t, a), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a -prj13 = prj12 . prjTail - -prj14 :: SmartExp (((((((((((((((t, a), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a -prj14 = prj13 . prjTail - -prj15 :: SmartExp ((((((((((((((((t, a), s14), s13), s12), s11), s10), s9), s8), s7), s6), s5), s4), s3), s2), s1), s0) -> SmartExp a -prj15 = prj14 . prjTail -- Smart constructor for literals -- @@ -1064,444 +1036,6 @@ indexHead (Exp x) = exp $ Prj PairIdxRight x -- | Get all but the innermost element of a shape -- indexTail :: (Elt sh, Elt a) => Exp (sh :. a) -> Exp sh -indexTail (Exp x) = exp $ Prj PairIdxLeft x - --- Smart constructor and destructors for scalar tuples --- -nilTup :: SmartExp () -nilTup = SmartExp Nil - -snocTup :: Elt b => SmartExp a -> Exp b -> SmartExp (a, EltRepr b) -snocTup a (Exp b) = SmartExp $ Pair a b - -tup2 :: (Elt a, Elt b) => (Exp a, Exp b) -> Exp (a, b) -tup2 (a, b) - = Exp - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 - $ 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 (Exp e) = - ( Exp $ prj1 e - , Exp $ prj0 e ) - -untup3 :: (Elt a, Elt b, Elt c) => Exp (a, b, c) -> (Exp a, Exp b, Exp c) -untup3 (Exp e) = - ( Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 e ) - -untup4 :: (Elt a, Elt b, Elt c, Elt d) - => Exp (a, b, c, d) - -> (Exp a, Exp b, Exp c, Exp d) -untup4 (Exp e) = - ( Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj7 e - , Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj8 e - , Exp $ prj7 e - , Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj9 e - , Exp $ prj8 e - , Exp $ prj7 e - , Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj10 e - , Exp $ prj9 e - , Exp $ prj8 e - , Exp $ prj7 e - , Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj11 e - , Exp $ prj10 e - , Exp $ prj9 e - , Exp $ prj8 e - , Exp $ prj7 e - , Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj12 e - , Exp $ prj11 e - , Exp $ prj10 e - , Exp $ prj9 e - , Exp $ prj8 e - , Exp $ prj7 e - , Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj13 e - , Exp $ prj12 e - , Exp $ prj11 e - , Exp $ prj10 e - , Exp $ prj9 e - , Exp $ prj8 e - , Exp $ prj7 e - , Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj14 e - , Exp $ prj13 e - , Exp $ prj12 e - , Exp $ prj11 e - , Exp $ prj10 e - , Exp $ prj9 e - , Exp $ prj8 e - , Exp $ prj7 e - , Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 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 (Exp e) = - ( Exp $ prj15 e - , Exp $ prj14 e - , Exp $ prj13 e - , Exp $ prj12 e - , Exp $ prj11 e - , Exp $ prj10 e - , Exp $ prj9 e - , Exp $ prj8 e - , Exp $ prj7 e - , Exp $ prj6 e - , Exp $ prj5 e - , Exp $ prj4 e - , Exp $ prj3 e - , Exp $ prj2 e - , Exp $ prj1 e - , Exp $ prj0 e ) -- Smart constructor for constants @@ -1529,6 +1063,8 @@ mkCos :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t mkCos = mkPrimUnary $ PrimCos floatingType mkTan :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +indexTail (Exp x) = exp $ Prj PairIdxLeft x + mkTan = mkPrimUnary $ PrimTan floatingType mkAsin :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t @@ -1926,30 +1462,3 @@ showPreExpOp ShapeSize{} = "ShapeSize" showPreExpOp Foreign{} = "Foreign" showPreExpOp Coerce{} = "Coerce" -vecR2 :: SingleType s -> VecR 2 s (Tup2 s s) -vecR2 s = VecRsucc $ VecRsucc $ VecRnil s - -vecR3 :: SingleType s -> VecR 3 s (Tup3 s s s) -vecR3 = VecRsucc . vecR2 - -vecR4 :: SingleType s -> VecR 4 s (Tup4 s s s s) -vecR4 = VecRsucc . vecR3 - -vecR5 :: SingleType s -> VecR 5 s (Tup5 s s s s s) -vecR5 = VecRsucc . vecR4 - -vecR6 :: SingleType s -> VecR 6 s (Tup6 s s s s s s) -vecR6 = VecRsucc . vecR5 - -vecR7 :: SingleType s -> VecR 7 s (Tup7 s s s s s s s) -vecR7 = VecRsucc . vecR6 - -vecR8 :: SingleType s -> VecR 8 s (Tup8 s s s s s s s s) -vecR8 = VecRsucc . vecR7 - -vecR9 :: SingleType s -> VecR 9 s (Tup9 s s s s s s s s s) -vecR9 = VecRsucc . vecR8 - -vecR16 :: SingleType s -> VecR 16 s (Tup16 s s s s s s s s s s s s s s s s) -vecR16 = VecRsucc . VecRsucc . VecRsucc . VecRsucc . VecRsucc . VecRsucc . VecRsucc . vecR9 - From d172d1ed3805240852013ad0ae3303211727dcfd Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 8 Jun 2020 17:16:13 +0200 Subject: [PATCH 238/316] rename helper function --- src/Data/Array/Accelerate/Classes/Eq.hs | 2 +- src/Data/Array/Accelerate/Data/Bits.hs | 2 +- src/Data/Array/Accelerate/Data/Complex.hs | 2 +- src/Data/Array/Accelerate/Language.hs | 20 +++++------ src/Data/Array/Accelerate/Smart.hs | 44 +++++++++++------------ 5 files changed, 35 insertions(+), 35 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 1df177519..79c309211 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -125,7 +125,7 @@ cond :: Elt t -> Exp t -- ^ then-expression -> Exp t -- ^ else-expression -> Exp t -cond (Exp c) (Exp x) (Exp y) = exp $ Cond c x y +cond (Exp c) (Exp x) (Exp y) = mkExp $ Cond c x y $(runQ $ do let diff --git a/src/Data/Array/Accelerate/Data/Bits.hs b/src/Data/Array/Accelerate/Data/Bits.hs index ad17ec9fe..1a27d04d0 100644 --- a/src/Data/Array/Accelerate/Data/Bits.hs +++ b/src/Data/Array/Accelerate/Data/Bits.hs @@ -759,7 +759,7 @@ isSignedDefault :: forall b. B.Bits b => Exp b -> Exp Bool isSignedDefault _ = constant (B.isSigned (undefined::b)) constInt :: IsIntegral (EltRepr e) => EltRepr e -> Exp e -constInt = exp . Const (SingleScalarType $ NumSingleType $ IntegralNumType $ integralType) +constInt = mkExp . Const (SingleScalarType (NumSingleType (IntegralNumType integralType))) {-- _popCountDefault :: forall a. (B.FiniteBits a, IsScalar a, Bits a, Num a) => Exp a -> Exp Int diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index ddf4d111a..702d940c6 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -50,7 +50,7 @@ import Data.Array.Accelerate.Classes import Data.Array.Accelerate.Data.Functor import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude -import Data.Array.Accelerate.Smart hiding (exp) +import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type import Data.Complex ( Complex(..) ) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index f2fd3510c..011608f13 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1220,7 +1220,7 @@ foreignExp -> (Exp x -> Exp y) -> Exp x -> Exp y -foreignExp a f (Exp x) = exp $ Foreign (eltType @y) a (unExpFunction f) x +foreignExp a f (Exp x) = mkExp $ Foreign (eltType @y) a (unExpFunction f) x -- Composition of array computations @@ -1281,12 +1281,12 @@ toIndex => Exp sh -- ^ extent of the array -> Exp sh -- ^ index to remap -> Exp Int -toIndex (Exp sh) (Exp ix) = exp $ ToIndex (shapeR @sh) sh ix +toIndex (Exp sh) (Exp ix) = mkExp $ ToIndex (shapeR @sh) sh ix -- | Inverse of 'toIndex' -- fromIndex :: forall sh. Shape sh => Exp sh -> Exp Int -> Exp sh -fromIndex (Exp sh) (Exp e) = exp $ FromIndex (shapeR @sh) sh e +fromIndex (Exp sh) (Exp e) = mkExp $ FromIndex (shapeR @sh) sh e -- | Intersection of two shapes -- @@ -1327,7 +1327,7 @@ cond :: Elt t -> Exp t -- ^ then-expression -> Exp t -- ^ else-expression -> Exp t -cond (Exp c) (Exp x) (Exp y) = exp $ Cond c x y +cond (Exp c) (Exp x) (Exp y) = mkExp $ Cond c x y -- | While construct. Continue to apply the given function, starting with the -- initial value, until the test function evaluates to 'False'. @@ -1338,9 +1338,9 @@ while :: forall e. Elt e -> Exp e -- ^ initial value -> Exp e #if __GLASGOW_HASKELL__ < 804 -while c f (Exp e) = exp $ While @SmartAcc @SmartExp @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e +while c f (Exp e) = mkExp $ While @SmartAcc @SmartExp @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e #else -while c f (Exp e) = exp $ While @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e +while c f (Exp e) = mkExp $ While @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e #endif @@ -1364,7 +1364,7 @@ while c f (Exp e) = exp $ While @(EltRepr e) (eltType @e) (u -- infixl 9 ! (!) :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -> Exp e -Acc a ! Exp ix = exp $ Index (eltType @e) a ix +Acc a ! Exp ix = mkExp $ Index (eltType @e) a ix -- | Extract the value from an array at the specified linear index. -- Multidimensional arrays in Accelerate are stored in row-major order with @@ -1384,12 +1384,12 @@ Acc a ! Exp ix = exp $ Index (eltType @e) a ix -- infixl 9 !! (!!) :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Exp Int -> Exp e -Acc a !! Exp ix = exp $ LinearIndex (eltType @e) a ix +Acc a !! Exp ix = mkExp $ LinearIndex (eltType @e) a ix -- | Extract the shape (extent) of an array. -- shape :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -shape = exp . Shape (shapeR @sh) . unAcc +shape = mkExp . Shape (shapeR @sh) . unAcc -- | The number of elements in the array -- @@ -1399,7 +1399,7 @@ size = shapeSize . shape -- | The number of elements that would be held by an array of the given shape. -- shapeSize :: forall sh. Shape sh => Exp sh -> Exp Int -shapeSize (Exp sh) = exp $ ShapeSize (shapeR @sh) sh +shapeSize (Exp sh) = mkExp $ ShapeSize (shapeR @sh) sh -- Numeric functions diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index c2749b57d..a3cb01122 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -28,7 +28,7 @@ module Data.Array.Accelerate.Smart ( -- * HOAS AST Acc(..), SmartAcc(..), PreSmartAcc(..), PairIdx(..), Exp(..), SmartExp(..), PreSmartExp(..), - Boundary(..), PreBoundary(..), Stencil(..), Level, unExp, + Boundary(..), PreBoundary(..), Stencil(..), Level, -- * Smart constructors for literals constant, undef, @@ -57,8 +57,9 @@ module Data.Array.Accelerate.Smart ( mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkCoerce, Coerce, -- * Auxiliary functions - ($$), ($$$), ($$$$), ($$$$$), unAcc, unAccFunction, ApplyAcc(..), exp, unPair, mkPairToTuple, HasExpType(..), HasArraysRepr(..), - vecR2, vecR3, vecR4, vecR5, vecR6, vecR7, vecR8, vecR9, vecR16, unExpFunction, + ($$), ($$$), ($$$$), ($$$$$), + ApplyAcc(..), HasExpType(..), HasArraysRepr(..), + unAcc, unAccFunction, mkExp, unExp, unExpFunction, unPair, mkPairToTuple, -- Debugging showPreAccOp, showPreExpOp, @@ -1031,24 +1032,25 @@ undef = Exp $ go $ eltType @e -- innermost nested loop. -- indexHead :: (Elt sh, Elt a) => Exp (sh :. a) -> Exp a -indexHead (Exp x) = exp $ Prj PairIdxRight x +indexHead (Exp x) = mkExp $ Prj PairIdxRight x -- | Get all but the innermost element of a shape -- indexTail :: (Elt sh, Elt a) => Exp (sh :. a) -> Exp sh +indexTail (Exp x) = mkExp $ Prj PairIdxLeft x -- Smart constructor for constants -- mkMinBound :: (Elt t, IsBounded (EltRepr t)) => Exp t -mkMinBound = exp $ PrimConst (PrimMinBound boundedType) +mkMinBound = mkExp $ PrimConst (PrimMinBound boundedType) mkMaxBound :: (Elt t, IsBounded (EltRepr t)) => Exp t -mkMaxBound = exp $ PrimConst (PrimMaxBound boundedType) +mkMaxBound = mkExp $ PrimConst (PrimMaxBound boundedType) mkPi :: (Elt r, IsFloating (EltRepr r)) => Exp r -mkPi = exp $ PrimConst (PrimPi floatingType) +mkPi = mkExp $ PrimConst (PrimPi floatingType) -- Smart constructors for primitive applications @@ -1063,8 +1065,6 @@ mkCos :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t mkCos = mkPrimUnary $ PrimCos floatingType mkTan :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t -indexTail (Exp x) = exp $ Prj PairIdxLeft x - mkTan = mkPrimUnary $ PrimTan floatingType mkAsin :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t @@ -1139,8 +1139,8 @@ mkRem = mkPrimBinary $ PrimRem integralType mkQuotRem :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> (Exp t, Exp t) mkQuotRem (Exp x) (Exp y) = - let pair = SmartExp $ PrimQuotRem integralType `PrimApp` (SmartExp $ Pair x y) - in (exp $ Prj PairIdxLeft pair, exp $ Prj PairIdxRight pair) + let pair = SmartExp $ PrimQuotRem integralType `PrimApp` SmartExp (Pair x y) + in (mkExp $ Prj PairIdxLeft pair, mkExp $ Prj PairIdxRight pair) mkIDiv :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t mkIDiv = mkPrimBinary $ PrimIDiv integralType @@ -1150,8 +1150,8 @@ mkMod = mkPrimBinary $ PrimMod integralType mkDivMod :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> (Exp t, Exp t) mkDivMod (Exp x) (Exp y) = - let pair = SmartExp $ PrimDivMod integralType `PrimApp` (SmartExp $ Pair x y) - in (exp $ Prj PairIdxLeft pair, exp $ Prj PairIdxRight pair) + let pair = SmartExp $ PrimDivMod integralType `PrimApp` SmartExp (Pair x y) + in (mkExp $ Prj PairIdxLeft pair, mkExp $ Prj PairIdxRight pair) -- Operators from Bits and FiniteBits @@ -1280,12 +1280,12 @@ mkToFloating = mkPrimUnary $ PrimToFloating numType floatingType -- Other conversions mkBoolToInt :: Exp Bool -> Exp Int -mkBoolToInt (Exp b) = exp $ PrimBoolToInt `PrimApp` b +mkBoolToInt (Exp b) = mkExp $ PrimBoolToInt `PrimApp` b -- NOTE: Restricted to scalar types with a type-level BitSizeEq constraint to -- make this version "safe" mkBitcast :: forall b a. (Elt a, Elt b, IsScalar (EltRepr a), IsScalar (EltRepr b), BitSizeEq (EltRepr a) (EltRepr b)) => Exp a -> Exp b -mkBitcast (Exp a) = exp $ Coerce (scalarType @(EltRepr a)) (scalarType @(EltRepr b)) a +mkBitcast (Exp a) = mkExp $ Coerce (scalarType @(EltRepr a)) (scalarType @(EltRepr b)) a mkCoerce :: Coerce (EltRepr a) (EltRepr b) => Exp a -> Exp b mkCoerce (Exp a) = Exp $ mkCoerce' a @@ -1300,22 +1300,19 @@ instance (Coerce a1 b1, Coerce a2 b2) => Coerce (a1, a2) (b1, b2) where mkCoerce' a = SmartExp $ Pair (mkCoerce' $ SmartExp $ Prj PairIdxLeft a) (mkCoerce' $ SmartExp $ Prj PairIdxRight a) instance Coerce () () where - mkCoerce' _ = SmartExp $ Nil + mkCoerce' _ = SmartExp Nil instance Coerce ((), a) a where mkCoerce' a = SmartExp $ Prj PairIdxRight a instance Coerce a ((), a) where - mkCoerce' = SmartExp . Pair (SmartExp $ Nil) + mkCoerce' = SmartExp . Pair (SmartExp Nil) -- Auxiliary functions -- -------------------- -exp :: PreSmartExp SmartAcc SmartExp (EltRepr t) -> Exp t -exp = Exp . SmartExp - infixr 0 $$ ($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a (f $$ g) x y = f (g x y) @@ -1338,6 +1335,9 @@ unAcc (Acc a) = a unAccFunction :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> SmartAcc (ArrRepr a) -> SmartAcc (ArrRepr b) unAccFunction f = unAcc . f . Acc +mkExp :: PreSmartExp SmartAcc SmartExp (EltRepr t) -> Exp t +mkExp = Exp . SmartExp + unExp :: Elt e => Exp e -> SmartExp (EltRepr e) unExp (Exp e) = e @@ -1348,10 +1348,10 @@ unExpBinaryFunction :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> Exp c) -> Sma unExpBinaryFunction f a b = unExp $ f (Exp a) (Exp b) mkPrimUnary :: (Elt a, Elt b) => PrimFun (EltRepr a -> EltRepr b) -> Exp a -> Exp b -mkPrimUnary prim (Exp a) = exp $ PrimApp prim a +mkPrimUnary prim (Exp a) = mkExp $ PrimApp prim a mkPrimBinary :: (Elt a, Elt b, Elt c) => PrimFun ((EltRepr a, EltRepr b) -> EltRepr c) -> Exp a -> Exp b -> Exp c -mkPrimBinary prim (Exp a) (Exp b) = exp $ PrimApp prim (SmartExp $ Pair a b) +mkPrimBinary prim (Exp a) (Exp b) = mkExp $ PrimApp prim (SmartExp $ Pair a b) unPair :: SmartExp (a, b) -> (SmartExp a, SmartExp b) unPair e = (SmartExp $ Prj PairIdxLeft e, SmartExp $ Prj PairIdxRight e) From 18273405bcb89dd633823612304698b4fd6efca7 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 8 Jun 2020 18:34:24 +0200 Subject: [PATCH 239/316] get stack cache directory programatically --- .github/workflows/ci.yml | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7154e666b..cfeda723a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -42,20 +42,27 @@ jobs: - uses: actions/checkout@v2 - uses: actions/setup-haskell@v1.1 - name: Setup Haskell Stack with: enable-stack: true ghc-version: ${{ matrix.ghc }} + - name: Setup Haskell Stack + id: stack-setup + run: | + ln -s stack-${{ matrix.ghc }}.yaml stack.yaml + echo "::set-output name=stack-root::$(stack path --stack-root)" + - uses: actions/cache@v1 - name: Cache ~/.stack with: - path: ~/.stack + path: ${{ steps.stack-setup.outputs.stack-root }} key: ${{ runner.os }}-${{ matrix.ghc }}-stack + - name: Build Dependencies + run: | + stack build $STACK_FLAGS --test --no-run-tests --only-dependencies + - name: Build run: | - ln -s stack-${{ matrix.ghc }}.yaml stack.yaml stack build $STACK_FLAGS --test --no-run-tests - name: Test From ab3e1aa9fae8d4d12252283b71b0e292619eea46 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 8 Jun 2020 18:39:33 +0200 Subject: [PATCH 240/316] =?UTF-8?q?don=E2=80=99t=20install=20ghc?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index cfeda723a..cb9d26a09 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -50,7 +50,7 @@ jobs: id: stack-setup run: | ln -s stack-${{ matrix.ghc }}.yaml stack.yaml - echo "::set-output name=stack-root::$(stack path --stack-root)" + echo "::set-output name=stack-root::$(stack path --no-install-ghc --stack-root)" - uses: actions/cache@v1 with: From 170a2474705544bc4037f0ac2814a44edeb0790e Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 8 Jun 2020 18:41:13 +0200 Subject: [PATCH 241/316] =?UTF-8?q?still=20requires=20=E2=80=94system-ghc?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index cb9d26a09..7fb8fdd1c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -50,7 +50,7 @@ jobs: id: stack-setup run: | ln -s stack-${{ matrix.ghc }}.yaml stack.yaml - echo "::set-output name=stack-root::$(stack path --no-install-ghc --stack-root)" + echo "::set-output name=stack-root::$(stack path --system-ghc --no-install-ghc --stack-root)" - uses: actions/cache@v1 with: From 9ed1fbe62de0c168882023c763c661454d541442 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 9 Jun 2020 09:38:21 +0200 Subject: [PATCH 242/316] ci wibble --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7fb8fdd1c..15ec95764 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -46,7 +46,7 @@ jobs: enable-stack: true ghc-version: ${{ matrix.ghc }} - - name: Setup Haskell Stack + - name: Set up stack id: stack-setup run: | ln -s stack-${{ matrix.ghc }}.yaml stack.yaml @@ -57,7 +57,7 @@ jobs: path: ${{ steps.stack-setup.outputs.stack-root }} key: ${{ runner.os }}-${{ matrix.ghc }}-stack - - name: Build Dependencies + - name: Build dependencies run: | stack build $STACK_FLAGS --test --no-run-tests --only-dependencies From 3388f9e6216fd7aac512cb845e1e61cb5f4ee5f6 Mon Sep 17 00:00:00 2001 From: Ivo Gabe de Wolff Date: Tue, 9 Jun 2020 23:31:37 +0200 Subject: [PATCH 243/316] Reduce number of constructors for folds and scans --- src/Data/Array/Accelerate/AST.hs | 136 ++++++------------ src/Data/Array/Accelerate/Analysis/Hash.hs | 22 +-- src/Data/Array/Accelerate/Analysis/Match.hs | 54 ++----- src/Data/Array/Accelerate/Interpreter.hs | 21 +-- src/Data/Array/Accelerate/Language.hs | 22 +-- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 60 ++++---- src/Data/Array/Accelerate/Pretty/Print.hs | 58 ++++---- src/Data/Array/Accelerate/Smart.hs | 76 +++------- src/Data/Array/Accelerate/Trafo/Fusion.hs | 48 +++---- src/Data/Array/Accelerate/Trafo/LetSplit.hs | 10 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 97 ++++++------- src/Data/Array/Accelerate/Trafo/Shrink.hs | 17 +-- .../Array/Accelerate/Trafo/Substitution.hs | 23 +-- 13 files changed, 254 insertions(+), 390 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index b201c0784..5d4659a47 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -92,7 +92,7 @@ module Data.Array.Accelerate.AST ( -- * Accelerated array expressions PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc, - Boundary(..), StencilR(..), + Boundary(..), StencilR(..), Direction(..), HasArraysRepr(..), arrayRepr, lhsToTupR, PairIdx(..), ArrayR(..), ArraysR, ShapeR(..), SliceIndex(..), VecR(..), vecRvector, vecRtuple, @@ -490,13 +490,7 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- /associative/ function. -- Fold :: Fun aenv (e -> e -> e) -- combination function - -> Exp aenv e -- default value - -> acc aenv (Array (sh, Int) e) -- folded array - -> PreOpenAcc acc aenv (Array sh e) - - -- As 'Fold' without a default value - -- - Fold1 :: Fun aenv (e -> e -> e) -- combination function + -> Maybe (Exp aenv e) -- default value -> acc aenv (Array (sh, Int) e) -- folded array -> PreOpenAcc acc aenv (Array sh e) @@ -505,63 +499,32 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- FoldSeg :: IntegralType i -> Fun aenv (e -> e -> e) -- combination function - -> Exp aenv e -- default value + -> Maybe (Exp 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) - -- As 'FoldSeg' without a default value + -- Haskell-style scan of a linear array with a given + -- /associative/ function and optionally an initial element + -- (which does not need to be the neutral of the associative operations) + -- If no initial value is given, this is a scan1 -- - Fold1Seg :: IntegralType i + Scan :: Direction -> Fun 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 :: Fun aenv (e -> e -> e) -- combination function - -> Exp 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' :: Fun aenv (e -> e -> e) -- combination function - -> Exp 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 :: Fun aenv (e -> e -> e) -- combination function + -> Maybe (Exp aenv e) -- initial value -> acc aenv (Array (sh, Int) e) -> PreOpenAcc acc aenv (Array (sh, Int) e) - -- Right-to-left version of 'Scanl' + -- Like 'Scan', but produces a rightmost (in case of a left-to-right scan) + -- 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) -- - Scanr :: Fun aenv (e -> e -> e) -- combination function - -> Exp aenv e -- initial value - -> acc aenv (Array (sh, Int) e) - -> PreOpenAcc acc aenv (Array (sh, Int) e) - - -- Right-to-left version of 'Scanl\'' - -- - Scanr' :: Fun aenv (e -> e -> e) -- combination function + Scan' :: Direction + -> Fun aenv (e -> e -> e) -- combination function -> Exp 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 :: Fun 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 @@ -619,6 +582,8 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -> acc aenv (Array sh b) -- source array #2 -> PreOpenAcc acc aenv (Array sh c) +data Direction = LeftToRight | RightToLeft deriving Eq + -- A sequence of operations. -- Collect :: Arrays arrs -- => PreOpenSeq acc aenv () arrs @@ -799,18 +764,10 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where in arraysRarray sh tp arraysRepr (Fold _ _ a) = let ArrayR (ShapeRsnoc sh) tp = arrayRepr a in arraysRarray sh tp - arraysRepr (Fold1 _ a) = let ArrayR (ShapeRsnoc sh) tp = arrayRepr a - in arraysRarray sh tp arraysRepr (FoldSeg _ _ _ a _) = arraysRepr a - arraysRepr (Fold1Seg _ _ a _) = arraysRepr a - arraysRepr (Scanl _ _ a) = arraysRepr a - arraysRepr (Scanl' _ _ a) = let repr@(ArrayR (ShapeRsnoc sh) tp) = arrayRepr a - in TupRsingle repr `TupRpair` TupRsingle (ArrayR sh tp) - arraysRepr (Scanl1 _ a) = arraysRepr a - arraysRepr (Scanr _ _ a) = arraysRepr a - arraysRepr (Scanr' _ _ a) = let repr@(ArrayR (ShapeRsnoc sh) tp) = arrayRepr a + arraysRepr (Scan _ _ _ a) = arraysRepr a + arraysRepr (Scan' _ _ _ a) = let repr@(ArrayR (ShapeRsnoc sh) tp) = arrayRepr a in TupRsingle repr `TupRpair` TupRsingle (ArrayR sh tp) - arraysRepr (Scanr1 _ a) = arraysRepr a arraysRepr (Permute _ a _ _) = arraysRepr a arraysRepr (Backpermute sh _ _ a) = let ArrayR _ tp = arrayRepr a in arraysRarray sh tp @@ -821,6 +778,7 @@ instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where instance HasArraysRepr OpenAcc where arraysRepr (OpenAcc a) = arraysRepr a + -- Embedded expressions -- -------------------- @@ -1315,16 +1273,10 @@ rnfPreOpenAcc rnfA pacc = Slice slice a sh -> rnfSliceIndex slice `seq` rnfE sh `seq` rnfA a Map tp f a -> rnfTupleType tp `seq` rnfF f `seq` rnfA a ZipWith tp f a1 a2 -> rnfTupleType tp `seq` 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 i f z a s -> rnfIntegralType i `seq` rnfF f `seq` rnfE z `seq` rnfA a `seq` rnfA s - Fold1Seg i f a s -> rnfIntegralType i `seq` 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 + Fold f z a -> rnfF f `seq` rnfMaybe rnfE z `seq` rnfA a + FoldSeg i f z a s -> rnfIntegralType i `seq` rnfF f `seq` rnfMaybe rnfE z `seq` rnfA a `seq` rnfA s + Scan d f z a -> d `seq` rnfF f `seq` rnfMaybe rnfE z `seq` rnfA a + Scan' d f z a -> d `seq` 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 shr sh f a -> rnfShapeR shr `seq` rnfE sh `seq` rnfF f `seq` rnfA a Stencil sr tp f b a -> @@ -1394,7 +1346,9 @@ rnfBoundary _ Wrap = () rnfBoundary (ArrayR _ tp) (Constant c) = rnfConst tp c rnfBoundary _ (Function f) = rnfOpenFun f - +rnfMaybe :: (a -> ()) -> Maybe a -> () +rnfMaybe _ Nothing = () +rnfMaybe f (Just x) = f x {-- -- Sequence expressions @@ -1685,16 +1639,10 @@ liftPreOpenAcc liftA pacc = Slice slix a sh -> [|| Slice $$(liftSliceIndex slix) $$(liftA a) $$(liftE sh) ||] Map tp f a -> [|| Map $$(liftTupleType tp) $$(liftF f) $$(liftA a) ||] ZipWith tp f a b -> [|| ZipWith $$(liftTupleType tp) $$(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 i f z a s -> [|| FoldSeg $$(liftIntegralType i) $$(liftF f) $$(liftE z) $$(liftA a) $$(liftA s) ||] - Fold1Seg i f a s -> [|| Fold1Seg $$(liftIntegralType i) $$(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) ||] + Fold f z a -> [|| Fold $$(liftF f) $$(liftMaybe liftE z) $$(liftA a) ||] + FoldSeg i f z a s -> [|| FoldSeg $$(liftIntegralType i) $$(liftF f) $$(liftMaybe liftE z) $$(liftA a) $$(liftA s) ||] + Scan d f z a -> [|| Scan $$(liftDirection d) $$(liftF f) $$(liftMaybe liftE z) $$(liftA a) ||] + Scan' d f z a -> [|| Scan' $$(liftDirection d) $$(liftF f) $$(liftE z) $$(liftA a) ||] Permute f d p a -> [|| Permute $$(liftF f) $$(liftA d) $$(liftF p) $$(liftA a) ||] Backpermute shr sh p a -> [|| Backpermute $$(liftShapeR shr) $$(liftE sh) $$(liftF p) $$(liftA a) ||] Stencil sr tp f b a -> @@ -1747,6 +1695,14 @@ liftStencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) = [|| StencilRtup9 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) $$(liftStencilR s6) $$(liftStencilR s7) $$(liftStencilR s8) $$(liftStencilR s9) ||] +liftDirection :: Direction -> Q (TExp Direction) +liftDirection LeftToRight = [|| LeftToRight ||] +liftDirection RightToLeft = [|| RightToLeft ||] + +liftMaybe :: (a -> Q (TExp a)) -> Maybe a -> Q (TExp (Maybe a)) +liftMaybe _ Nothing = [|| Nothing ||] +liftMaybe f (Just x) = [|| Just $$(f x) ||] + liftOpenFun :: OpenFun env aenv t -> Q (TExp (OpenFun env aenv t)) @@ -2130,22 +2086,22 @@ showPreAccOp Replicate{} = "Replicate" showPreAccOp Slice{} = "Slice" showPreAccOp Map{} = "Map" showPreAccOp ZipWith{} = "ZipWith" +showPreAccOp (Fold _ Nothing _) = "Fold1" showPreAccOp Fold{} = "Fold" -showPreAccOp Fold1{} = "Fold1" +showPreAccOp (FoldSeg _ _ Nothing _ _) = "Fold1Seg" 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 (Scan d _ Nothing _) = "Scan" ++ show d ++ "1" +showPreAccOp (Scan d _ _ _) = "Scan" ++ show d +showPreAccOp (Scan' d _ _ _) = "Scan" ++ show d ++ "'" showPreAccOp Permute{} = "Permute" showPreAccOp Backpermute{} = "Backpermute" showPreAccOp Stencil{} = "Stencil" showPreAccOp Stencil2{} = "Stencil2" -- showPreAccOp Collect{} = "Collect" +instance Show Direction where + show LeftToRight = "l" + show RightToLeft = "r" showShortendArr :: ArrayR (Array sh e) -> Array sh e -> String showShortendArr repr@(ArrayR _ tp) arr diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index f1eb6b5e1..c8897f7bc 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -142,6 +142,14 @@ encodePreOpenAcc options encodeAcc pacc = travF :: OpenFun env' aenv' f -> Builder travF = encodeOpenFun + travD :: Direction -> Builder + travD LeftToRight = intHost $(hashQ "L") + travD RightToLeft = intHost $(hashQ "R") + + travMaybe :: (a -> Builder) -> Maybe a -> Builder + travMaybe _ Nothing = intHost $(hashQ "Nothing") + travMaybe f (Just x) = intHost $(hashQ "Just") <> f x + deep :: Builder -> Builder deep | perfect options = id | otherwise = const mempty @@ -172,16 +180,10 @@ encodePreOpenAcc options encodeAcc pacc = Slice spec a ix -> intHost $(hashQ "Slice") <> deepE 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 + Fold f e a -> intHost $(hashQ "Fold") <> travF f <> travMaybe travE e <> travA a + FoldSeg _ f e a s -> intHost $(hashQ "FoldSeg") <> travF f <> travMaybe travE e <> travA a <> travA s + Scan d f e a -> intHost $(hashQ "Scan") <> travD d <> travF f <> travMaybe travE e <> travA a + Scan' d f e a -> intHost $(hashQ "Scan'") <> travD d <> travF f <> travE e <> travA a Permute f1 a1 f2 a2 -> intHost $(hashQ "Permute") <> travF f1 <> travA a1 <> travF f2 <> travA a2 Stencil s _ f b a -> intHost $(hashQ "Stencil") <> travF f <> encodeBoundary (stencilElt s) b <> travA a Stencil2 s1 s2 _ f b1 a1 b2 a2 -> intHost $(hashQ "Stencil2") <> travF f <> encodeBoundary (stencilElt s1) b1 <> travA a1 <> encodeBoundary (stencilElt s2) b2 <> travA a2 diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index d88c27b2f..b89aa18d5 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -169,62 +169,31 @@ matchPreOpenAcc matchAcc = match 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 + , matchMaybe matchExp z1 z2 , 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 + , matchMaybe 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 + match (Scan d1 f1 z1 a1) (Scan d2 f2 z2 a2) + | d1 == d2 + , Just Refl <- matchFun f1 f2 + , matchMaybe matchExp z1 z2 , Just Refl <- matchAcc a1 a2 = Just Refl - match (Scanr' f1 z1 a1) (Scanr' f2 z2 a2) - | Just Refl <- matchFun f1 f2 + match (Scan' d1 f1 z1 a1) (Scan' d2 f2 z2 a2) + | d1 == d2 + , 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 @@ -323,6 +292,11 @@ matchBoundary _ (Function f) (Function g) matchBoundary _ _ _ = False +matchMaybe :: (s1 -> s2 -> Maybe (t1 :~: t2)) -> Maybe s1 -> Maybe s2 -> Bool +matchMaybe _ Nothing Nothing = True +matchMaybe f (Just x) (Just y) + | Just Refl <- f x y = True +matchMaybe _ _ _ = False {-- -- Match sequences diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index f833b4659..3a0cbfbbc 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -236,20 +236,21 @@ evalOpenAcc (AST.Manifest pacc) aenv = -- Consumers -- --------- - Fold f z acc -> foldOp (evalF f) (evalE z) (delayed acc) - Fold1 f acc -> fold1Op (evalF f) (delayed acc) - FoldSeg i f z acc seg -> foldSegOp i (evalF f) (evalE z) (delayed acc) (delayed seg) - Fold1Seg i f acc seg -> fold1SegOp i (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) + Fold f (Just z) acc -> foldOp (evalF f) (evalE z) (delayed acc) + Fold f Nothing acc -> fold1Op (evalF f) (delayed acc) + FoldSeg i f (Just z) acc seg -> foldSegOp i (evalF f) (evalE z) (delayed acc) (delayed seg) + FoldSeg i f Nothing acc seg -> fold1SegOp i (evalF f) (delayed acc) (delayed seg) + Scan d f (Just z) acc -> dir d scanlOp scanrOp (evalF f) (evalE z) (delayed acc) + Scan d f Nothing acc -> dir d scanl1Op scanr1Op (evalF f) (delayed acc) + Scan' d f z acc -> dir d scanl'Op scanr'Op (evalF f) (evalE z) (delayed acc) Permute f def p acc -> permuteOp (evalF f) (manifest def) (evalF p) (delayed acc) Stencil s tp sten b acc -> stencilOp s tp (evalF sten) (evalB b) (delayed acc) Stencil2 s1 s2 tp sten b1 a1 b2 a2 -> stencil2Op s1 s2 tp (evalF sten) (evalB b1) (delayed a1) (evalB b2) (delayed a2) + where + dir :: Direction -> t -> t -> t + dir LeftToRight l _ = l + dir RightToLeft _ r = r -- Array primitives -- ---------------- diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index f2fd3510c..e812d1017 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -125,7 +125,7 @@ import Data.Array.Accelerate.Classes.Num import Data.Array.Accelerate.Classes.Ord -- standard libraries -import Prelude ( ($), (.) ) +import Prelude ( ($), (.), Maybe(..) ) -- $setup -- >>> :seti -XFlexibleContexts @@ -527,7 +527,7 @@ fold :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array sh a) -fold = Acc $$$ applyAcc (Fold $ eltType @a) +fold f (Exp x) = Acc . applyAcc (Fold (eltType @a) (unExpBinaryFunction f) (Just x)) -- | Variant of 'fold' that requires the innermost dimension of the array to be -- non-empty and doesn't need an default value. @@ -544,7 +544,7 @@ fold1 :: forall sh a. => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array sh a) -fold1 = Acc $$ applyAcc (Fold1 $ eltType @a) +fold1 f = Acc . applyAcc (Fold (eltType @a) (unExpBinaryFunction f) Nothing) -- | Segmented reduction along the innermost dimension of an array. The -- segment descriptor specifies the starting index (offset) along the @@ -567,7 +567,7 @@ foldSeg' -> Acc (Array (sh:.Int) a) -> Acc (Segments i) -> Acc (Array (sh:.Int) a) -foldSeg' = Acc $$$$ applyAcc (FoldSeg (integralType @i) (eltType @a)) +foldSeg' f (Exp x) = Acc $$ applyAcc (FoldSeg (integralType @i) (eltType @a) (unExpBinaryFunction f) (Just x)) -- | Variant of 'foldSeg'' that requires /all/ segments of the reduced -- array to be non-empty, and doesn't need a default value. The segment @@ -583,7 +583,7 @@ fold1Seg' -> Acc (Array (sh:.Int) a) -> Acc (Segments i) -> Acc (Array (sh:.Int) a) -fold1Seg' = Acc $$$ applyAcc (Fold1Seg (integralType @i) (eltType @a)) +fold1Seg' f = Acc $$ applyAcc (FoldSeg (integralType @i) (eltType @a) (unExpBinaryFunction f) Nothing) -- Scan functions -- -------------- @@ -611,7 +611,7 @@ scanl :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanl = Acc $$$ applyAcc (Scanl $ eltType @a) +scanl f (Exp x) (Acc a) = Acc $ SmartAcc $ Scan LeftToRight (eltType @a) (unExpBinaryFunction f) (Just x) a -- | Variant of 'scanl', where the last element (final reduction result) along -- each dimension is returned separately. Denotationally we have: @@ -645,7 +645,7 @@ scanl' :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a, Array sh a) -scanl' = Acc . mkPairToTuple $$$ applyAcc (Scanl' $ eltType @a) +scanl' = Acc . mkPairToTuple $$$ applyAcc (Scan' LeftToRight $ eltType @a) -- | 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 @@ -664,7 +664,7 @@ scanl1 :: forall sh a. => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanl1 = Acc $$ applyAcc (Scanl1 $ eltType @a) +scanl1 f (Acc a) = Acc $ SmartAcc $ Scan LeftToRight (eltType @a) (unExpBinaryFunction f) Nothing a -- | Right-to-left variant of 'scanl'. -- @@ -674,7 +674,7 @@ scanr :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanr = Acc $$$ applyAcc (Scanr $ eltType @a) +scanr f (Exp x) (Acc a) = Acc $ SmartAcc $ Scan RightToLeft (eltType @a) (unExpBinaryFunction f) (Just x) a -- | Right-to-left variant of 'scanl''. -- @@ -684,7 +684,7 @@ scanr' :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a, Array sh a) -scanr' = Acc . mkPairToTuple $$$ applyAcc (Scanr' $ eltType @a) +scanr' = Acc . mkPairToTuple $$$ applyAcc (Scan' RightToLeft $ eltType @a) -- | Right-to-left variant of 'scanl1'. -- @@ -693,7 +693,7 @@ scanr1 :: forall sh a. => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanr1 = Acc $$ applyAcc (Scanr1 $ eltType @a) +scanr1 f (Acc a) = Acc $ SmartAcc $ Scan RightToLeft (eltType @a) (unExpBinaryFunction f) Nothing a -- Permutations -- ------------ diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 3533a6472..718b7c0ef 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -211,10 +211,10 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = deps = (vt, Just "T") : (ve, Just "F") : map (,port) vs return $ PNode ident doc deps - Apply _ afun acc -> apply <$> prettyDelayedAfun detail aenv afun + Apply _ afun acc -> apply <$> prettyDelayedAfun detail aenv afun <*> prettyDelayedOpenAcc detail ctx aenv acc - Awhile p f x -> do + Awhile p f x -> do ident <- mkNodeId atop x' <- replant =<< prettyDelayedOpenAcc detail app aenv x p' <- prettyDelayedAfun detail aenv p @@ -224,36 +224,36 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = loop = nest 2 (sep ["awhile", pretty p', pretty f', xb ]) return $ PNode ident (Leaf (Nothing,loop)) fvs - a@(Apair a1 a2) -> mkNodeId a >>= prettyDelayedApair detail aenv a1 a2 - - Anil -> "()" .$ [] - - Use repr arr -> "use" .$ [ return $ PDoc (prettyArray repr arr) [] ] - Unit _ e -> "unit" .$ [ ppE e ] - Generate _ sh f -> "generate" .$ [ ppE sh, ppF f ] - Transform _ sh ix f xs -> "transform" .$ [ ppE sh, ppF ix, ppF f, ppA xs ] - Reshape _ sh xs -> "reshape" .$ [ ppE sh, ppA xs ] - Replicate _ty ix xs -> "replicate" .$ [ ppE ix, ppA xs ] - Slice _ty xs ix -> "slice" .$ [ ppA xs, ppE 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" .$ [ ppE sh, ppF p, ppA xs ] + a@(Apair a1 a2) -> mkNodeId a >>= prettyDelayedApair detail aenv a1 a2 + + Anil -> "()" .$ [] + + Use repr arr -> "use" .$ [ return $ PDoc (prettyArray repr arr) [] ] + Unit _ e -> "unit" .$ [ ppE e ] + Generate _ sh f -> "generate" .$ [ ppE sh, ppF f ] + Transform _ sh ix f xs -> "transform" .$ [ ppE sh, ppF ix, ppF f, ppA xs ] + Reshape _ sh xs -> "reshape" .$ [ ppE sh, ppA xs ] + Replicate _ty ix xs -> "replicate" .$ [ ppE ix, ppA xs ] + Slice _ty xs ix -> "slice" .$ [ ppA xs, ppE ix ] + Map _ f xs -> "map" .$ [ ppF f, ppA xs ] + ZipWith _ f xs ys -> "zipWith" .$ [ ppF f, ppA xs, ppA ys ] + Fold f (Just z) a -> "fold" .$ [ ppF f, ppE z, ppA a ] + Fold f Nothing a -> "fold1" .$ [ ppF f, ppA a ] + FoldSeg _ f (Just z) a s -> "foldSeg" .$ [ ppF f, ppE z, ppA a, ppA s ] + FoldSeg _ f Nothing a s -> "fold1Seg" .$ [ ppF f, ppA a, ppA s ] + Scan d f (Just z) a -> fromString ("scan" ++ show d) + .$ [ ppF f, ppE z, ppA a ] + Scan d f Nothing a -> fromString ("scan" ++ show d ++ "1") + .$ [ ppF f, ppA a ] + Scan' d f z a -> fromString ("scan" ++ show d ++ "'") + .$ [ ppF f, ppE z, ppA a ] + Permute f dfts p xs -> "permute" .$ [ ppF f, ppA dfts, ppF p, ppA xs ] + Backpermute _ sh p xs -> "backpermute" .$ [ ppE sh, ppF p, ppA xs ] Stencil s _ sten bndy xs - -> "stencil" .$ [ ppF sten, ppB (stencilElt s) bndy, ppA xs ] + -> "stencil" .$ [ ppF sten, ppB (stencilElt s) bndy, ppA xs ] Stencil2 s1 s2 _ sten bndy1 acc1 bndy2 acc2 - -> "stencil2" .$ [ ppF sten, ppB (stencilElt s1) bndy1, ppA acc1, ppB (stencilElt s2) bndy2, ppA acc2 ] - Aforeign _ ff _afun xs -> "aforeign" .$ [ return (PDoc (pretty (strForeign ff)) []), {- ppAf afun, -} ppA xs ] + -> "stencil2" .$ [ ppF sten, ppB (stencilElt s1) bndy1, ppA acc1, ppB (stencilElt s2) bndy2, ppA acc2 ] + Aforeign _ ff _afun xs -> "aforeign" .$ [ return (PDoc (pretty (strForeign ff)) []), {- ppAf afun, -} ppA xs ] -- Collect{} -> error "Collect" where diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index fee90733b..af27680bc 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -149,32 +149,32 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = , hang shiftwidth (sep [ then_, t' ]) , hang shiftwidth (sep [ else_, e' ]) ] - Aforeign _ ff _ a -> "aforeign" .$ [ pretty (strForeign ff), ppA a ] - Awhile p f a -> "awhile" .$ [ ppAF p, ppAF f, ppA a ] - Use repr arr -> "use" .$ [ prettyArray repr arr ] - Unit _ e -> "unit" .$ [ ppE e ] - Reshape _ sh a -> "reshape" .$ [ ppE sh, ppA a ] - Generate _ sh f -> "generate" .$ [ ppE sh, ppF f ] - Transform _ sh p f a -> "transform" .$ [ ppE sh, ppF p, ppF f, ppA a ] - Replicate _ ix a -> "replicate" .$ [ ppE ix, ppA a ] - Slice _ a ix -> "slice" .$ [ ppE ix, ppA a ] - Map _ f a -> "map" .$ [ ppF f, ppA a ] - ZipWith _ f a b -> "zipWith" .$ [ ppF f, ppA a, ppA b ] - Fold f z a -> "fold" .$ [ ppF f, ppE z, ppA a ] - Fold1 f a -> "fold1" .$ [ ppF f, ppA a ] - FoldSeg _ f z a s -> "foldSeg" .$ [ ppF f, ppE z, ppA a, ppA s ] - Fold1Seg _ f a s -> "fold1Seg" .$ [ ppF f, ppA a, ppA s ] - Scanl f z a -> "scanl" .$ [ ppF f, ppE z, ppA a ] - Scanl' f z a -> "scanl'" .$ [ ppF f, ppE z, ppA a ] - Scanl1 f a -> "scanl1" .$ [ ppF f, ppA a ] - Scanr f z a -> "scanr" .$ [ ppF f, ppE z, ppA a ] - Scanr' f z a -> "scanr'" .$ [ ppF f, ppE z, ppA a ] - Scanr1 f a -> "scanr1" .$ [ ppF f, ppA a ] - Permute f d p s -> "permute" .$ [ ppF f, ppA d, ppF p, ppA s ] - Backpermute _ sh f a -> "backpermute" .$ [ ppE sh, ppF f, ppA a ] - Stencil s _ f b a -> "stencil" .$ [ ppF f, ppB (stencilElt s) b, ppA a ] + Aforeign _ ff _ a -> "aforeign" .$ [ pretty (strForeign ff), ppA a ] + Awhile p f a -> "awhile" .$ [ ppAF p, ppAF f, ppA a ] + Use repr arr -> "use" .$ [ prettyArray repr arr ] + Unit _ e -> "unit" .$ [ ppE e ] + Reshape _ sh a -> "reshape" .$ [ ppE sh, ppA a ] + Generate _ sh f -> "generate" .$ [ ppE sh, ppF f ] + Transform _ sh p f a -> "transform" .$ [ ppE sh, ppF p, ppF f, ppA a ] + Replicate _ ix a -> "replicate" .$ [ ppE ix, ppA a ] + Slice _ a ix -> "slice" .$ [ ppE ix, ppA a ] + Map _ f a -> "map" .$ [ ppF f, ppA a ] + ZipWith _ f a b -> "zipWith" .$ [ ppF f, ppA a, ppA b ] + Fold f (Just z) a -> "fold" .$ [ ppF f, ppE z, ppA a ] + Fold f Nothing a -> "fold1" .$ [ ppF f, ppA a ] + FoldSeg _ f (Just z) a s -> "foldSeg" .$ [ ppF f, ppE z, ppA a, ppA s ] + FoldSeg _ f Nothing a s -> "fold1Seg" .$ [ ppF f, ppA a, ppA s ] + Scan d f (Just z) a -> fromString ("scan" ++ show d) + .$ [ ppF f, ppE z, ppA a ] + Scan d f Nothing a -> fromString ("scan" ++ show d ++ "1") + .$ [ ppF f, ppA a ] + Scan' d f z a -> fromString ("scan" ++ show d ++ "'") + .$ [ ppF f, ppE z, ppA a ] + Permute f d p s -> "permute" .$ [ ppF f, ppA d, ppF p, ppA s ] + Backpermute _ sh f a -> "backpermute" .$ [ ppE sh, ppF f, ppA a ] + Stencil s _ f b a -> "stencil" .$ [ ppF f, ppB (stencilElt s) b, ppA a ] Stencil2 s1 s2 _ f b1 a1 b2 a2 - -> "stencil2" .$ [ ppF f, ppB (stencilElt s1) b1, ppA a1, ppB (stencilElt s2) b2, ppA a2 ] + -> "stencil2" .$ [ ppF f, ppB (stencilElt s1) b1, ppA a1, ppB (stencilElt s2) b2, ppA a2 ] where infixr 0 .$ f .$ xs @@ -543,18 +543,18 @@ prettyPrimConst PrimPi{} = "pi" -- associativity, and fixity of the primitive scalar operators. -- -data Direction = L | N | R +data Dir = L | N | R deriving Eq data Fixity = App | Infix | Prefix deriving Eq type Precedence = Int -type Associativity = Direction +type Associativity = Dir data Context = Context { ctxAssociativity :: Associativity - , ctxPosition :: Direction + , ctxPosition :: Dir , ctxPrecedence :: Precedence } @@ -581,7 +581,7 @@ context0 = Context N N 0 app :: Context app = Context L N 10 -arg :: Operator -> Direction -> Context +arg :: Operator -> Dir -> Context arg Operator{..} side = Context opAssociativity side opPrecedence isPrefix :: Operator -> Bool diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index bd381b206..6e82a6434 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -29,7 +29,7 @@ module Data.Array.Accelerate.Smart ( -- * HOAS AST Acc(..), SmartAcc(..), PreSmartAcc(..), PairIdx(..), Exp(..), SmartExp(..), PreSmartExp(..), - Boundary(..), PreBoundary(..), Stencil(..), Level, unExp, + Boundary(..), PreBoundary(..), Stencil(..), Level, unExp, Direction(..), -- * Smart constructors for literals constant, undef, @@ -63,7 +63,7 @@ module Data.Array.Accelerate.Smart ( -- * Auxiliary functions ($$), ($$$), ($$$$), ($$$$$), unAcc, unAccFunction, ApplyAcc(..), exp, unPair, mkPairToTuple, HasExpType(..), HasArraysRepr(..), - vecR2, vecR3, vecR4, vecR5, vecR6, vecR7, vecR8, vecR9, vecR16, unExpFunction, + vecR2, vecR3, vecR4, vecR5, vecR6, vecR7, vecR8, vecR9, vecR16, unExpFunction, unExpBinaryFunction, -- Debugging showPreAccOp, showPreExpOp, @@ -369,64 +369,32 @@ data PreSmartAcc acc exp as where Fold :: TupleType e -> (SmartExp e -> SmartExp e -> exp e) - -> exp e - -> acc (Array (sh, Int) e) - -> PreSmartAcc acc exp (Array sh e) - - Fold1 :: TupleType e - -> (SmartExp e -> SmartExp e -> exp e) + -> Maybe (exp e) -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array sh e) FoldSeg :: IntegralType i -> TupleType e -> (SmartExp e -> SmartExp e -> exp e) - -> exp e + -> Maybe (exp e) -> acc (Array (sh, Int) e) -> acc (Segments i) -> PreSmartAcc acc exp (Array (sh, Int) e) - Fold1Seg :: IntegralType i + Scan :: Direction -> TupleType e -> (SmartExp e -> SmartExp e -> exp e) + -> Maybe (exp e) -> acc (Array (sh, Int) e) - -> acc (Segments i) -> PreSmartAcc acc exp (Array (sh, Int) e) - Scanl :: TupleType e - -> (SmartExp e -> SmartExp e -> exp e) - -> exp e - -> acc (Array (sh, Int) e) - -> PreSmartAcc acc exp (Array (sh, Int) e) - - Scanl' :: TupleType e - -> (SmartExp e -> SmartExp e -> exp e) - -> exp e - -> acc (Array (sh, Int) e) - -> PreSmartAcc acc exp (Array (sh, Int) e, Array sh e) - - Scanl1 :: TupleType e - -> (SmartExp e -> SmartExp e -> exp e) - -> acc (Array (sh, Int) e) - -> PreSmartAcc acc exp (Array (sh, Int) e) - - Scanr :: TupleType e - -> (SmartExp e -> SmartExp e -> exp e) - -> exp e - -> acc (Array (sh, Int) e) - -> PreSmartAcc acc exp (Array (sh, Int) e) - - Scanr' :: TupleType e + Scan' :: Direction + -> TupleType e -> (SmartExp e -> SmartExp e -> exp e) -> exp e -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array (sh, Int) e, Array sh e) - Scanr1 :: TupleType e - -> (SmartExp e -> SmartExp e -> exp e) - -> acc (Array (sh, Int) e) - -> PreSmartAcc acc exp (Array (sh, Int) e) - Permute :: ArrayR (Array sh e) -> (SmartExp e -> SmartExp e -> exp e) -> acc (Array sh' e) @@ -497,18 +465,10 @@ instance HasArraysRepr acc => HasArraysRepr (PreSmartAcc acc exp) where in TupRsingle $ ArrayR shr tp Fold _ _ _ a -> let ArrayR (ShapeRsnoc shr) tp = arrayRepr a in TupRsingle (ArrayR shr tp) - Fold1 _ _ a -> let ArrayR (ShapeRsnoc shr) tp = arrayRepr a - in TupRsingle (ArrayR shr tp) FoldSeg _ _ _ _ a _ -> arraysRepr a - Fold1Seg _ _ _ a _ -> arraysRepr a - Scanl _ _ _ a -> arraysRepr a - Scanl' _ _ _ a -> let repr@(ArrayR (ShapeRsnoc shr) tp) = arrayRepr a - in TupRsingle repr `TupRpair` TupRsingle (ArrayR shr tp) - Scanl1 _ _ a -> arraysRepr a - Scanr _ _ _ a -> arraysRepr a - Scanr' _ _ _ a -> let repr@(ArrayR (ShapeRsnoc shr) tp) = arrayRepr a + Scan _ _ _ _ a -> arraysRepr a + Scan' _ _ _ _ a -> let repr@(ArrayR (ShapeRsnoc shr) tp) = arrayRepr a in TupRsingle repr `TupRpair` TupRsingle (ArrayR shr tp) - Scanr1 _ _ a -> arraysRepr a Permute _ _ a _ _ -> arraysRepr a Backpermute shr _ _ a -> let ArrayR _ tp = arrayRepr a in TupRsingle (ArrayR shr tp) @@ -1874,16 +1834,12 @@ 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 (Fold _ _ Just{} _) = "Fold" +showPreAccOp Fold{} = "Fold1" +showPreAccOp (FoldSeg _ _ _ Just{} _ _) = "FoldSeg" +showPreAccOp FoldSeg{} = "Fold1Seg" +showPreAccOp (Scan d _ _ z _) = "Scan" ++ show d ++ maybe "1" (const "") z -- Scanl, Scanl1, Scanr, Scanr1 +showPreAccOp (Scan' d _ _ _ _) = "Scan" ++ show d ++ "'" showPreAccOp Permute{} = "Permute" showPreAccOp Backpermute{} = "Backpermute" showPreAccOp Stencil{} = "Stencil" diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index b2f4258a2..ea03face1 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -188,15 +188,9 @@ manifest config (OpenAcc pacc) = -- consumer already -- Fold f z a -> Fold f z (delayed config a) - Fold1 f a -> Fold1 f (delayed config a) FoldSeg i f z a s -> FoldSeg i f z (delayed config a) (delayed config s) - Fold1Seg i f a s -> Fold1Seg i f (delayed config a) (delayed config s) - Scanl f z a -> Scanl f z (delayed config a) - Scanl1 f a -> Scanl1 f (delayed config a) - Scanl' f z a -> Scanl' f z (delayed config a) - Scanr f z a -> Scanr f z (delayed config a) - Scanr1 f a -> Scanr1 f (delayed config a) - Scanr' f z a -> Scanr' f z (delayed config a) + Scan d f z a -> Scan d f z (delayed config a) + Scan' d f z a -> Scan' d f z (delayed config a) Permute f d p a -> Permute f (manifest config d) p (delayed config a) Stencil s tp f x a -> Stencil s tp f x (delayed config a) Stencil2 s1 s2 tp f x a y b @@ -397,20 +391,14 @@ embedPreAcc config embedAcc elimAcc pacc -- node, so that the producer can be directly embedded into the consumer -- during the code generation phase. -- - Fold f z a -> embed repr (into2 Fold (cvtF f) (cvtE z)) a - Fold1 f a -> embed repr (into Fold1 (cvtF f)) a - FoldSeg i f z a s -> embed2 repr (into2 (FoldSeg i) (cvtF f) (cvtE z)) a s - Fold1Seg i f a s -> embed2 repr (into (Fold1Seg i) (cvtF f)) a s - Scanl f z a -> embed repr (into2 Scanl (cvtF f) (cvtE z)) a - Scanl1 f a -> embed repr (into Scanl1 (cvtF f)) a - Scanl' f z a -> embed repr (into2 Scanl' (cvtF f) (cvtE z)) a - Scanr f z a -> embed repr (into2 Scanr (cvtF f) (cvtE z)) a - Scanr1 f a -> embed repr (into Scanr1 (cvtF f)) a - Scanr' f z a -> embed repr (into2 Scanr' (cvtF f) (cvtE z)) a - Permute f d p a -> embed2 repr (into2 permute (cvtF f) (cvtF p)) d a - Stencil s t f x a -> embed repr (into2 (stencil1 s t) (cvtF f) (cvtB x)) a + Fold f z a -> embed repr (into2M Fold (cvtF f) (cvtE <$> z)) a + FoldSeg i f z a s -> embed2 repr (into2M (FoldSeg i) (cvtF f) (cvtE <$> z)) a s + Scan d f z a -> embed repr (into2M (Scan d) (cvtF f) (cvtE <$> z)) a + Scan' d f z a -> embed repr (into2 (Scan' d) (cvtF f) (cvtE z)) a + Permute f d p a -> embed2 repr (into2 permute (cvtF f) (cvtF p)) d a + Stencil s t f x a -> embed repr (into2 (stencil1 s t) (cvtF f) (cvtB x)) a Stencil2 s1 s2 t f x a y b - -> embed2 repr (into3 (stencil2 s1 s2 t) (cvtF f) (cvtB x) (cvtB y)) a b + -> embed2 repr (into3 (stencil2 s1 s2 t) (cvtF f) (cvtB x) (cvtB y)) a b where repr = arraysRepr pacc @@ -474,6 +462,10 @@ embedPreAcc config embedAcc elimAcc pacc => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b -> Extend ArrayR acc env env' -> c into2 op a b env = op (sinkA env a) (sinkA env b) + into2M :: (Sink f1, Sink f2) + => (f1 env' a -> Maybe (f2 env' b) -> c) -> f1 env a -> Maybe (f2 env b) -> Extend ArrayR acc env env' -> c + into2M op a b env = op (sinkA env a) (sinkA 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 ArrayR acc env env' -> d into3 op a b c env = op (sinkA env a) (sinkA env b) (sinkA env c) @@ -1435,16 +1427,10 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en Slice slix a sl -> Slice slix (cvtA a) (cvtE sl) Replicate slix sh a -> Replicate slix (cvtE sh) (cvtA a) Reshape shr sl a -> Reshape shr (cvtE sl) (cvtA a) - Fold f z a -> Fold (cvtF f) (cvtE z) (cvtA a) - Fold1 f a -> Fold1 (cvtF f) (cvtA a) - FoldSeg i f z a s -> FoldSeg i (cvtF f) (cvtE z) (cvtA a) (cvtA s) - Fold1Seg i f a s -> Fold1Seg i (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) + Fold f z a -> Fold (cvtF f) (cvtE <$> z) (cvtA a) + FoldSeg i f z a s -> FoldSeg i (cvtF f) (cvtE <$> z) (cvtA a) (cvtA s) + Scan d f z a -> Scan d (cvtF f) (cvtE <$> z) (cvtA a) + Scan' d f z a -> Scan' d (cvtF f) (cvtE z) (cvtA a) Permute f d p a -> Permute (cvtF f) (cvtA d) (cvtF p) (cvtA a) Stencil s t f x a -> Stencil s t (cvtF f) (cvtB x) (cvtA a) Stencil2 s1 s2 t f x a y b diff --git a/src/Data/Array/Accelerate/Trafo/LetSplit.hs b/src/Data/Array/Accelerate/Trafo/LetSplit.hs index 6294de7ea..bb77b96a5 100644 --- a/src/Data/Array/Accelerate/Trafo/LetSplit.hs +++ b/src/Data/Array/Accelerate/Trafo/LetSplit.hs @@ -43,15 +43,9 @@ travA (Slice slix a sl) = inject $ Slice slix (convertAcc a) sl travA (Map tp f a) = inject $ Map tp f (convertAcc a) travA (ZipWith tp f a1 a2) = inject $ ZipWith tp f (convertAcc a1) (convertAcc a2) travA (Fold f e a) = inject $ Fold f e (convertAcc a) -travA (Fold1 f a) = inject $ Fold1 f (convertAcc a) travA (FoldSeg i f e a s) = inject $ FoldSeg i f e (convertAcc a) (convertAcc s) -travA (Fold1Seg i f a s) = inject $ Fold1Seg i f (convertAcc a) (convertAcc s) -travA (Scanl f e a) = inject $ Scanl f e (convertAcc a) -travA (Scanl' f e a) = inject $ Scanl' f e (convertAcc a) -travA (Scanl1 f a) = inject $ Scanl1 f (convertAcc a) -travA (Scanr f e a) = inject $ Scanr f e (convertAcc a) -travA (Scanr' f e a) = inject $ Scanr' f e (convertAcc a) -travA (Scanr1 f a) = inject $ Scanr1 f (convertAcc a) +travA (Scan d f e a) = inject $ Scan d f e (convertAcc a) +travA (Scan' d f e a) = inject $ Scan' d f e (convertAcc a) travA (Permute f a1 g a2) = inject $ Permute f (convertAcc a1) g (convertAcc a2) travA (Backpermute shr sh f a) = inject $ Backpermute shr sh f (convertAcc a) travA (Stencil s tp f b a) = inject $ Stencil s tp f b (convertAcc a) diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index d15737b55..a2fc58d13 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -332,16 +332,10 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) Map t1 t2 f acc -> AST.Map t2 (cvtF1 t1 f) (cvtA acc) ZipWith t1 t2 t3 f acc1 acc2 -> AST.ZipWith t3 (cvtF2 t1 t2 f) (cvtA acc1) (cvtA acc2) - Fold tp f e acc -> AST.Fold (cvtF2 tp tp f) (cvtE e) (cvtA acc) - Fold1 tp f acc -> AST.Fold1 (cvtF2 tp tp f) (cvtA acc) - FoldSeg i tp f e acc1 acc2 -> AST.FoldSeg i (cvtF2 tp tp f) (cvtE e) (cvtA acc1) (cvtA acc2) - Fold1Seg i tp f acc1 acc2 -> AST.Fold1Seg i (cvtF2 tp tp f) (cvtA acc1) (cvtA acc2) - Scanl tp f e acc -> AST.Scanl (cvtF2 tp tp f) (cvtE e) (cvtA acc) - Scanl' tp f e acc -> AST.Scanl' (cvtF2 tp tp f) (cvtE e) (cvtA acc) - Scanl1 tp f acc -> AST.Scanl1 (cvtF2 tp tp f) (cvtA acc) - Scanr tp f e acc -> AST.Scanr (cvtF2 tp tp f) (cvtE e) (cvtA acc) - Scanr' tp f e acc -> AST.Scanr' (cvtF2 tp tp f) (cvtE e) (cvtA acc) - Scanr1 tp f acc -> AST.Scanr1 (cvtF2 tp tp f) (cvtA acc) + Fold tp f e acc -> AST.Fold (cvtF2 tp tp f) (cvtE <$> e) (cvtA acc) + FoldSeg i tp f e acc1 acc2 -> AST.FoldSeg i (cvtF2 tp tp f) (cvtE <$> e) (cvtA acc1) (cvtA acc2) + Scan d tp f e acc -> AST.Scan d (cvtF2 tp tp f) (cvtE <$> e) (cvtA acc) + Scan' d tp f e acc -> AST.Scan' d (cvtF2 tp tp f) (cvtE e) (cvtA acc) Permute (ArrayR shr tp) f dftAcc perm acc -> AST.Permute (cvtF2 tp tp f) (cvtA dftAcc) (cvtF1 (shapeType shr) perm) (cvtA acc) Backpermute shr newDim perm acc @@ -1384,22 +1378,16 @@ makeOccMapSharingAcc config accOccMap = traverseAcc return (Map t1 t2 f' acc', h1 `max` h2 + 1) ZipWith t1 t2 t3 f acc1 acc2 -> travF2A2 (ZipWith t1 t2 t3) t1 t2 f acc1 acc2 - Fold tp f e acc -> travF2EA (Fold tp) tp tp f e acc - Fold1 tp f acc -> travF2A (Fold1 tp) tp tp f acc + Fold tp f e acc -> travF2MEA (Fold tp) tp tp f e acc FoldSeg i tp f e acc1 acc2 -> do (f' , h1) <- traverseFun2 lvl tp tp f - (e' , h2) <- traverseExp lvl e + (e' , h2) <- travME e (acc1', h3) <- traverseAcc lvl acc1 (acc2', h4) <- traverseAcc lvl acc2 return (FoldSeg i tp f' e' acc1' acc2', h1 `max` h2 `max` h3 `max` h4 + 1) - Fold1Seg i tp f acc1 acc2 -> travF2A2 (Fold1Seg i tp) tp tp f acc1 acc2 - Scanl tp f e acc -> travF2EA (Scanl tp) tp tp f e acc - Scanl' tp f e acc -> travF2EA (Scanl' tp) tp tp f e acc - Scanl1 tp f acc -> travF2A (Scanl1 tp) tp tp f acc - Scanr tp f e acc -> travF2EA (Scanr tp) tp tp f e acc - Scanr' tp f e acc -> travF2EA (Scanr' tp) tp tp f e acc - Scanr1 tp f acc -> travF2A (Scanr1 tp) tp tp f acc + Scan d tp f e acc -> travF2MEA (Scan d tp) tp tp f e acc + Scan' d tp f e acc -> travF2EA (Scan' d tp) tp tp f e acc Permute repr@(ArrayR shr tp) c acc1 p acc2 -> do (c' , h1) <- traverseFun2 lvl tp tp c @@ -1449,17 +1437,6 @@ makeOccMapSharingAcc config accOccMap = traverseAcc (acc', h2) <- traverseAcc lvl acc return (c exp' acc', h1 `max` h2 + 1) - travF2A :: ((SmartExp b -> SmartExp c -> RootExp d) -> UnscopedAcc arrs' - -> PreSmartAcc UnscopedAcc RootExp arrs) - -> TupleType b -> TupleType c - -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartAcc arrs' - -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) - travF2A c t1 t2 fun acc - = do - (fun', h1) <- traverseFun2 lvl t1 t2 fun - (acc', h2) <- traverseAcc lvl acc - return (c fun' acc', h1 `max` h2 + 1) - travF2EA :: ((SmartExp b -> SmartExp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) -> TupleType b -> TupleType c -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartExp e -> SmartAcc arrs' @@ -1471,6 +1448,23 @@ makeOccMapSharingAcc config accOccMap = traverseAcc (acc', h3) <- traverseAcc lvl acc return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1) + travF2MEA :: ((SmartExp b -> SmartExp c -> RootExp d) -> Maybe (RootExp e) -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> TupleType b -> TupleType c + -> (SmartExp b -> SmartExp c -> SmartExp d) -> Maybe (SmartExp e) -> SmartAcc arrs' + -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) + travF2MEA c t1 t2 fun exp acc + = do + (fun', h1) <- traverseFun2 lvl t1 t2 fun + (exp', h2) <- travME exp + (acc', h3) <- traverseAcc lvl acc + return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1) + + travME :: Maybe (SmartExp t) -> IO (Maybe (RootExp t), Int) + travME Nothing = return (Nothing, 0) + travME (Just e) = do + (e', c) <- traverseExp lvl e + return (Just e', c) + travF2A2 :: ((SmartExp b -> SmartExp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreSmartAcc UnscopedAcc RootExp arrs) -> TupleType b -> TupleType c -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartAcc arrs1 -> SmartAcc arrs2 @@ -2197,23 +2191,17 @@ determineScopesSharingAcc config accOccMap = scopesAcc reconstruct (Map t1 t2 f' acc') (accCount1 +++ accCount2) ZipWith t1 t2 t3 f acc1 acc2 -> travF2A2 (ZipWith t1 t2 t3) f acc1 acc2 - Fold tp f z acc -> travF2EA (Fold tp) f z acc - Fold1 tp f acc -> travF2A (Fold1 tp) f acc + Fold tp f z acc -> travF2MEA (Fold tp) f z acc FoldSeg i tp f z acc1 acc2 -> let (f' , accCount1) = scopesFun2 f - (z' , accCount2) = scopesExp z + (z' , accCount2) = travME z (acc1', accCount3) = scopesAcc acc1 (acc2', accCount4) = scopesAcc acc2 in reconstruct (FoldSeg i tp f' z' acc1' acc2') (accCount1 +++ accCount2 +++ accCount3 +++ accCount4) - Fold1Seg i tp f acc1 acc2 -> travF2A2 (Fold1Seg i tp) f acc1 acc2 - Scanl tp f z acc -> travF2EA (Scanl tp) f z acc - Scanl' tp f z acc -> travF2EA (Scanl' tp) f z acc - Scanl1 tp f acc -> travF2A (Scanl1 tp) f acc - Scanr tp f z acc -> travF2EA (Scanr tp) f z acc - Scanr' tp f z acc -> travF2EA (Scanr' tp) f z acc - Scanr1 tp f acc -> travF2A (Scanr1 tp) f acc + Scan d tp f z acc -> travF2MEA (Scan d tp) f z acc + Scan' d tp f z acc -> travF2EA (Scan' d tp) f z acc Permute repr fc acc1 fp acc2 -> let (fc' , accCount1) = scopesFun2 fc @@ -2262,16 +2250,6 @@ determineScopesSharingAcc config accOccMap = scopesAcc (e' , accCount1) = scopesExp e (acc', accCount2) = scopesAcc acc - travF2A :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedAcc arrs' - -> PreSmartAcc ScopedAcc ScopedExp arrs) - -> (SmartExp a -> SmartExp 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 :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedExp e -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) -> (SmartExp a -> SmartExp b -> RootExp c) @@ -2284,6 +2262,23 @@ determineScopesSharingAcc config accOccMap = scopesAcc (e' , accCount2) = scopesExp e (acc', accCount3) = scopesAcc acc + travF2MEA :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> Maybe (ScopedExp e) + -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) + -> (SmartExp a -> SmartExp b -> RootExp c) + -> Maybe (RootExp e) + -> UnscopedAcc arrs' + -> (ScopedAcc arrs, NodeCounts) + travF2MEA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3) + where + (f' , accCount1) = scopesFun2 f + (e' , accCount2) = travME e + (acc', accCount3) = scopesAcc acc + + travME :: Maybe (RootExp e) -> (Maybe (ScopedExp e), NodeCounts) + travME Nothing = (Nothing, noNodeCounts) + travME (Just e) = (Just e', c) + where (e', c) = scopesExp e + travF2A2 :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedAcc arrs1 -> ScopedAcc arrs2 -> PreSmartAcc ScopedAcc ScopedExp arrs) -> (SmartExp a -> SmartExp b -> RootExp c) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index a3d04a426..ee78260d9 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -547,16 +547,10 @@ usesOfPreAcc withShape countAcc idx = count 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 + Fold f z a -> countF f + countME z + countA a + FoldSeg _ f z a s -> countF f + countME z + countA a + countA s + Scan _ f z a -> countF f + countME z + countA a + Scan' _ f z a -> countF f + countE z + 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 @@ -590,6 +584,9 @@ usesOfPreAcc withShape countAcc idx = count Foreign _ _ _ e -> countE e Coerce _ _ e -> countE e + countME :: Maybe (OpenExp env aenv e) -> Int + countME = maybe 0 countE + countA :: acc aenv a -> Int countA = countAcc withShape idx diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index e4e3c7249..c1a50c86f 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -515,6 +515,15 @@ shiftE' (LeftHandSideSingle _) (LeftHandSideSingle _) v = shiftE v shiftE' (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) v = shiftE' b1 b2 $ shiftE' a1 a2 v shiftE' _ _ _ = error "Substitution: left hand sides do not match" +{-# INLINEABLE rebuildMaybeExp #-} +rebuildMaybeExp + :: (Applicative f, SyntacticExp fe) + => RebuildEvar f fe env env' aenv' + -> ReindexAvar f aenv aenv' + -> Maybe (OpenExp env aenv t) + -> f (Maybe (OpenExp env' aenv' t)) +rebuildMaybeExp _ _ Nothing = pure Nothing +rebuildMaybeExp v av (Just x) = Just <$> rebuildOpenExp v av x {-# INLINEABLE rebuildOpenExp #-} rebuildOpenExp @@ -669,16 +678,10 @@ rebuildPreOpenAcc k av acc = Slice sl a slix -> Slice sl <$> k av a <*> rebuildOpenExp (pure . IE) av' slix Map tp f a -> Map tp <$> rebuildFun (pure . IE) av' f <*> k av a ZipWith tp f a1 a2 -> ZipWith tp <$> rebuildFun (pure . IE) av' f <*> k av a1 <*> k av a2 - Fold f z a -> Fold <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a - Fold1 f a -> Fold1 <$> rebuildFun (pure . IE) av' f <*> k av a - FoldSeg itp f z a s -> FoldSeg itp <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a <*> k av s - Fold1Seg itp f a s -> Fold1Seg itp <$> rebuildFun (pure . IE) av' f <*> k av a <*> k av s - Scanl f z a -> Scanl <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a - Scanl' f z a -> Scanl' <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a - Scanl1 f a -> Scanl1 <$> rebuildFun (pure . IE) av' f <*> k av a - Scanr f z a -> Scanr <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a - Scanr' f z a -> Scanr' <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a - Scanr1 f a -> Scanr1 <$> rebuildFun (pure . IE) av' f <*> k av a + Fold f z a -> Fold <$> rebuildFun (pure . IE) av' f <*> rebuildMaybeExp (pure . IE) av' z <*> k av a + FoldSeg itp f z a s -> FoldSeg itp <$> rebuildFun (pure . IE) av' f <*> rebuildMaybeExp (pure . IE) av' z <*> k av a <*> k av s + Scan d f z a -> Scan d <$> rebuildFun (pure . IE) av' f <*> rebuildMaybeExp (pure . IE) av' z <*> k av a + Scan' d f z a -> Scan' d <$> rebuildFun (pure . IE) av' f <*> rebuildOpenExp (pure . IE) av' z <*> k av a Permute f1 a1 f2 a2 -> Permute <$> rebuildFun (pure . IE) av' f1 <*> k av a1 <*> rebuildFun (pure . IE) av' f2 <*> k av a2 Backpermute shr sh f a -> Backpermute shr <$> rebuildOpenExp (pure . IE) av' sh <*> rebuildFun (pure . IE) av' f <*> k av a Stencil sr tp f b a -> Stencil sr tp <$> rebuildFun (pure . IE) av' f <*> rebuildBoundary av' b <*> k av a From 447544a8b30700c248b7bc44b77d83da955d2a3c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 17 Jun 2020 10:40:07 +0200 Subject: [PATCH 244/316] massive internal refactoring * Splits the modules D.A.A.Array.{Sugar,Representation} into several modules under the tree D.A.A.{Sugar,Representation}.* * Remove D.A.A.Trafo.Base, which was a lazy dumping ground for unrelated functionality * Move various definitions around into new modules, for example putting lift and rnf instances close to where those data structures are defined, rather than dumping them all into D.A.A.AST --- accelerate.cabal | 29 +- icebox/AST.hs | 188 ++ .../Array/Accelerate/Trafo => icebox}/Base.hs | 0 .../Array => icebox}/Representation.hs | 0 icebox/Smart.hs | 123 ++ .../Accelerate/Array => icebox}/Sugar.hs | 0 src/Data/Array/Accelerate.hs | 11 +- src/Data/Array/Accelerate/AST.hs | 1510 +++++------------ src/Data/Array/Accelerate/AST/Environment.hs | 91 + src/Data/Array/Accelerate/AST/Idx.hs | 44 + src/Data/Array/Accelerate/AST/LeftHandSide.hs | 62 + src/Data/Array/Accelerate/AST/Var.hs | 44 + src/Data/Array/Accelerate/Analysis/Hash.hs | 40 +- src/Data/Array/Accelerate/Analysis/Match.hs | 59 +- src/Data/Array/Accelerate/Analysis/Shape.hs | 15 +- src/Data/Array/Accelerate/Analysis/Stencil.hs | 20 +- src/Data/Array/Accelerate/Analysis/Type.hs | 13 +- src/Data/Array/Accelerate/Array/Data.hs | 513 +++--- .../Array/Accelerate/Array/Remote/Class.hs | 8 +- src/Data/Array/Accelerate/Array/Remote/LRU.hs | 48 +- .../Array/Accelerate/Array/Remote/Table.hs | 27 +- src/Data/Array/Accelerate/Array/Unique.hs | 66 +- src/Data/Array/Accelerate/Classes/Bounded.hs | 2 +- src/Data/Array/Accelerate/Classes/Eq.hs | 3 +- src/Data/Array/Accelerate/Classes/Num.hs | 2 +- src/Data/Array/Accelerate/Classes/Ord.hs | 12 +- src/Data/Array/Accelerate/Classes/Rational.hs | 1 + .../Array/Accelerate/Classes/RealFloat.hs | 7 +- src/Data/Array/Accelerate/Classes/RealFrac.hs | 12 +- src/Data/Array/Accelerate/Data/Bits.hs | 28 +- src/Data/Array/Accelerate/Data/Complex.hs | 157 +- src/Data/Array/Accelerate/Data/Either.hs | 15 +- src/Data/Array/Accelerate/Data/Functor.hs | 2 +- src/Data/Array/Accelerate/Data/Maybe.hs | 16 +- src/Data/Array/Accelerate/Data/Monoid.hs | 3 +- src/Data/Array/Accelerate/Data/Ratio.hs | 4 +- src/Data/Array/Accelerate/Data/Semigroup.hs | 2 +- src/Data/Array/Accelerate/Interpreter.hs | 142 +- src/Data/Array/Accelerate/Language.hs | 120 +- src/Data/Array/Accelerate/Lift.hs | 12 +- src/Data/Array/Accelerate/Pattern.hs | 29 +- src/Data/Array/Accelerate/Prelude.hs | 25 +- src/Data/Array/Accelerate/Pretty.hs | 20 +- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 35 +- src/Data/Array/Accelerate/Pretty/Print.hs | 36 +- .../Array/Accelerate/Representation/Array.hs | 261 +++ .../Array/Accelerate/Representation/Elt.hs | 79 + .../Array/Accelerate/Representation/Shape.hs | 198 +++ .../Array/Accelerate/Representation/Slice.hs | 108 ++ .../Accelerate/Representation/Stencil.hs | 163 ++ .../Array/Accelerate/Representation/Type.hs | 123 ++ .../Array/Accelerate/Representation/Vec.hs | 95 ++ src/Data/Array/Accelerate/Smart.hs | 684 ++++---- src/Data/Array/Accelerate/Sugar/Array.hs | 316 ++++ src/Data/Array/Accelerate/Sugar/Elt.hs | 269 +++ src/Data/Array/Accelerate/Sugar/Foreign.hs | 37 + src/Data/Array/Accelerate/Sugar/Shape.hs | 366 ++++ src/Data/Array/Accelerate/Sugar/Stencil.hs | 118 ++ src/Data/Array/Accelerate/Sugar/Vec.hs | 37 + src/Data/Array/Accelerate/Test/NoFib/Base.hs | 9 +- .../Accelerate/Test/NoFib/Imaginary/DotP.hs | 9 +- .../Accelerate/Test/NoFib/Imaginary/SASUM.hs | 9 +- .../Accelerate/Test/NoFib/Imaginary/SAXPY.hs | 10 +- .../Accelerate/Test/NoFib/Issues/Issue264.hs | 10 +- .../Accelerate/Test/NoFib/Issues/Issue364.hs | 11 +- .../Accelerate/Test/NoFib/Issues/Issue407.hs | 6 +- .../Accelerate/Test/NoFib/Issues/Issue409.hs | 6 +- .../Test/NoFib/Prelude/Backpermute.hs | 16 +- .../Accelerate/Test/NoFib/Prelude/Filter.hs | 20 +- .../Accelerate/Test/NoFib/Prelude/Fold.hs | 29 +- .../Accelerate/Test/NoFib/Prelude/Map.hs | 69 +- .../Accelerate/Test/NoFib/Prelude/Permute.hs | 34 +- .../Accelerate/Test/NoFib/Prelude/SIMD.hs | 37 +- .../Accelerate/Test/NoFib/Prelude/Scan.hs | 111 +- .../Accelerate/Test/NoFib/Prelude/Stencil.hs | 30 +- .../Accelerate/Test/NoFib/Prelude/ZipWith.hs | 80 +- .../Test/NoFib/Spectral/BlackScholes.hs | 9 +- .../Test/NoFib/Spectral/RadixSort.hs | 14 +- .../Accelerate/Test/NoFib/Spectral/SMVM.hs | 12 +- src/Data/Array/Accelerate/Test/Similar.hs | 4 +- src/Data/Array/Accelerate/Trafo.hs | 60 +- src/Data/Array/Accelerate/Trafo/Algebra.hs | 30 +- src/Data/Array/Accelerate/Trafo/Config.hs | 3 +- src/Data/Array/Accelerate/Trafo/Delayed.hs | 125 ++ .../Array/Accelerate/Trafo/Environment.hs | 164 ++ src/Data/Array/Accelerate/Trafo/Fusion.hs | 702 ++++---- src/Data/Array/Accelerate/Trafo/LetSplit.hs | 107 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 269 +-- src/Data/Array/Accelerate/Trafo/Shrink.hs | 52 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 82 +- .../Array/Accelerate/Trafo/Substitution.hs | 61 +- src/Data/Array/Accelerate/Trafo/Var.hs | 79 + src/Data/Array/Accelerate/Type.hs | 504 ++---- src/Data/Array/Accelerate/Unsafe.hs | 6 +- src/Data/Primitive/Vec.hs | 290 ++++ 95 files changed, 6112 insertions(+), 3407 deletions(-) create mode 100644 icebox/AST.hs rename {src/Data/Array/Accelerate/Trafo => icebox}/Base.hs (100%) rename {src/Data/Array/Accelerate/Array => icebox}/Representation.hs (100%) create mode 100644 icebox/Smart.hs rename {src/Data/Array/Accelerate/Array => icebox}/Sugar.hs (100%) create mode 100644 src/Data/Array/Accelerate/AST/Environment.hs create mode 100644 src/Data/Array/Accelerate/AST/Idx.hs create mode 100644 src/Data/Array/Accelerate/AST/LeftHandSide.hs create mode 100644 src/Data/Array/Accelerate/AST/Var.hs create mode 100644 src/Data/Array/Accelerate/Representation/Array.hs create mode 100644 src/Data/Array/Accelerate/Representation/Elt.hs create mode 100644 src/Data/Array/Accelerate/Representation/Shape.hs create mode 100644 src/Data/Array/Accelerate/Representation/Slice.hs create mode 100644 src/Data/Array/Accelerate/Representation/Stencil.hs create mode 100644 src/Data/Array/Accelerate/Representation/Type.hs create mode 100644 src/Data/Array/Accelerate/Representation/Vec.hs create mode 100644 src/Data/Array/Accelerate/Sugar/Array.hs create mode 100644 src/Data/Array/Accelerate/Sugar/Elt.hs create mode 100644 src/Data/Array/Accelerate/Sugar/Foreign.hs create mode 100644 src/Data/Array/Accelerate/Sugar/Shape.hs create mode 100644 src/Data/Array/Accelerate/Sugar/Stencil.hs create mode 100644 src/Data/Array/Accelerate/Sugar/Vec.hs create mode 100644 src/Data/Array/Accelerate/Trafo/Delayed.hs create mode 100644 src/Data/Array/Accelerate/Trafo/Environment.hs create mode 100644 src/Data/Array/Accelerate/Trafo/Var.hs create mode 100644 src/Data/Primitive/Vec.hs diff --git a/accelerate.cabal b/accelerate.cabal index f7a168b8a..388ebad78 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -315,6 +315,10 @@ Library -- For backend development (hidden) Data.Array.Accelerate.AST + Data.Array.Accelerate.AST.Environment + Data.Array.Accelerate.AST.Idx + Data.Array.Accelerate.AST.LeftHandSide + Data.Array.Accelerate.AST.Var Data.Array.Accelerate.Analysis.Hash Data.Array.Accelerate.Analysis.Match Data.Array.Accelerate.Analysis.Shape @@ -325,16 +329,29 @@ Library Data.Array.Accelerate.Array.Remote.Class Data.Array.Accelerate.Array.Remote.LRU Data.Array.Accelerate.Array.Remote.Table - Data.Array.Accelerate.Array.Representation - Data.Array.Accelerate.Array.Sugar Data.Array.Accelerate.Array.Unique Data.Array.Accelerate.Async Data.Array.Accelerate.Debug Data.Array.Accelerate.Error Data.Array.Accelerate.Lifetime Data.Array.Accelerate.Pretty + Data.Array.Accelerate.Representation.Array + Data.Array.Accelerate.Representation.Elt + Data.Array.Accelerate.Representation.Shape + Data.Array.Accelerate.Representation.Slice + Data.Array.Accelerate.Representation.Stencil + Data.Array.Accelerate.Representation.Type + Data.Array.Accelerate.Representation.Vec Data.Array.Accelerate.Smart + Data.Array.Accelerate.Sugar.Array + Data.Array.Accelerate.Sugar.Elt + Data.Array.Accelerate.Sugar.Foreign + Data.Array.Accelerate.Sugar.Shape + Data.Array.Accelerate.Sugar.Vec Data.Array.Accelerate.Trafo + Data.Array.Accelerate.Trafo.Config + Data.Array.Accelerate.Trafo.Fusion + Data.Array.Accelerate.Trafo.Sharing Data.Array.Accelerate.Type -- For testing @@ -343,6 +360,7 @@ Library -- Other Data.BitSet + Data.Primitive.Vec Other-modules: Data.Array.Accelerate.Analysis.Hash.TH @@ -377,14 +395,13 @@ Library Data.Array.Accelerate.Pretty.Graphviz.Type Data.Array.Accelerate.Pretty.Print Data.Array.Accelerate.Trafo.Algebra - Data.Array.Accelerate.Trafo.Base - Data.Array.Accelerate.Trafo.Config - Data.Array.Accelerate.Trafo.Fusion + Data.Array.Accelerate.Trafo.Delayed + Data.Array.Accelerate.Trafo.Environment Data.Array.Accelerate.Trafo.LetSplit - Data.Array.Accelerate.Trafo.Sharing Data.Array.Accelerate.Trafo.Shrink Data.Array.Accelerate.Trafo.Simplify Data.Array.Accelerate.Trafo.Substitution + Data.Array.Accelerate.Trafo.Var Data.Atomic -- Data.Array.Accelerate.Array.Lifted diff --git a/icebox/AST.hs b/icebox/AST.hs new file mode 100644 index 000000000..1d2b7736f --- /dev/null +++ b/icebox/AST.hs @@ -0,0 +1,188 @@ + +module Data.Array.Accelerate.AST + +data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where + -- A sequence of operations. + Collect :: Arrays arrs + => PreOpenSeq acc aenv () arrs + -> PreOpenAcc acc aenv arrs + + +-- |Closed sequence computation +-- +type Seq = PreOpenSeq OpenAcc () () + +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 + + +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 @a) (fromArr a) `seq` rnfArrs as + + rnfAF :: PreOpenAfun acc aenv' t' -> () + rnfAF = rnfPreOpenAfun rnfA + + rnfF :: OpenFun env' aenv' t' -> () + rnfF = rnfOpenFun rnfA + + rnfE :: OpenExp env' aenv' t' -> () + rnfE = rnfOpenExp 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 :: OpenFun env' aenv' t' -> () + rnfF = rnfOpenFun rnfA + + rnfE :: OpenExp env' aenv' t' -> () + rnfE = rnfOpenExp 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 + diff --git a/src/Data/Array/Accelerate/Trafo/Base.hs b/icebox/Base.hs similarity index 100% rename from src/Data/Array/Accelerate/Trafo/Base.hs rename to icebox/Base.hs diff --git a/src/Data/Array/Accelerate/Array/Representation.hs b/icebox/Representation.hs similarity index 100% rename from src/Data/Array/Accelerate/Array/Representation.hs rename to icebox/Representation.hs diff --git a/icebox/Smart.hs b/icebox/Smart.hs new file mode 100644 index 000000000..403798bbf --- /dev/null +++ b/icebox/Smart.hs @@ -0,0 +1,123 @@ + +module Data.Array.Accelerate.Smart + + +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 + + +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" + diff --git a/src/Data/Array/Accelerate/Array/Sugar.hs b/icebox/Sugar.hs similarity index 100% rename from src/Data/Array/Accelerate/Array/Sugar.hs rename to icebox/Sugar.hs diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 71d3a2838..3cb76ce0b 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -420,15 +420,20 @@ module Data.Array.Accelerate ( ) 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.Pattern import Data.Array.Accelerate.Prelude import Data.Array.Accelerate.Pretty () -- show instances +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Array ( Array, Arrays, Scalar, Vector, Matrix, Segments, fromFunction, fromFunctionM, toList, fromList ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape hiding ( size, ignore, toIndex, fromIndex, intersect ) +import Data.Array.Accelerate.Sugar.Vec import Data.Array.Accelerate.Type -import qualified Data.Array.Accelerate.Array.Sugar as S +import Data.Primitive.Vec +import qualified Data.Array.Accelerate.Sugar.Array as S +import qualified Data.Array.Accelerate.Sugar.Shape as S import Prelude ( (.), ($), Show, undefined, error, const, otherwise ) import GHC.Generics ( Generic ) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index b201c0784..87a081382 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -1,22 +1,13 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.AST @@ -83,123 +74,81 @@ module Data.Array.Accelerate.AST ( - -- * Typed de Bruijn indices - Idx(..), idxToInt, Var(..), Vars(..), TupR(..), ArrayVar, ArrayVars, ExpVar, ExpVars, - evars, varsType, LeftHandSide(..), ALeftHandSide, ELeftHandSide, - - -- * Valuation environment - Val(..), push, prj, - - -- * Accelerated array expressions - PreOpenAfun(..), OpenAfun, PreAfun, Afun, PreOpenAcc(..), OpenAcc(..), Acc, - Boundary(..), StencilR(..), - HasArraysRepr(..), arrayRepr, lhsToTupR, PairIdx(..), - ArrayR(..), ArraysR, ShapeR(..), SliceIndex(..), VecR(..), vecRvector, vecRtuple, - - -- * Accelerated sequences - -- PreOpenSeq(..), Seq, - -- Producer(..), Consumer(..), - - -- * Scalar expressions - OpenFun(..), Fun, OpenExp(..), Exp, PrimConst(..), - PrimFun(..), expType, primConstType, primFunType, - - -- NFData + -- * Internal AST + -- ** Array computations + Afun, PreAfun, OpenAfun, PreOpenAfun(..), + Acc, OpenAcc(..), PreOpenAcc(..), + ALeftHandSide, ArrayVar, ArrayVars, + + -- ** Scalar expressions + ELeftHandSide, ExpVar, ExpVars, expVars, + Fun, OpenFun(..), + Exp, OpenExp(..), + Boundary(..), + PrimConst(..), + PrimFun(..), + + -- ** Extracting type information + HasArraysR(..), arrayR, + expType, + primConstType, + primFunType, + + -- ** Normal-form NFDataAcc, - rnfPreOpenAfun, rnfPreOpenAcc, rnfOpenFun, rnfOpenExp, - rnfArrays, rnfArrayR, - - -- TemplateHaskell + rnfOpenAfun, rnfPreOpenAfun, + rnfOpenAcc, rnfPreOpenAcc, + rnfALeftHandSide, + rnfArrayVar, + rnfOpenFun, + rnfOpenExp, + rnfELeftHandSide, + rnfExpVar, + rnfBoundary, + rnfConst, + rnfPrimConst, + rnfPrimFun, + + -- ** Template Haskell LiftAcc, - liftIdx, - liftConst, liftSliceIndex, liftPrimConst, liftPrimFun, - liftPreOpenAfun, liftPreOpenAcc, liftOpenFun, liftOpenExp, - liftALhs, liftELhs, liftArray, liftArraysR, liftTupleType, liftArrayR, - liftScalarType, liftShapeR, liftVecR, liftIntegralType, - - -- Utilities - Exists(..), weakenWithLHS, (:>), weakenId, weakenSucc, weakenSucc', weakenEmpty, (.>), (>:>), - sink, sinkWithLHS, - - -- debugging - showPreAccOp, showPreExpOp, showShortendArr, showElement + liftPreOpenAfun, + liftPreOpenAcc, + liftALeftHandSide, + liftArrayVar, + liftOpenFun, + liftOpenExp, + liftELeftHandSide, + liftExpVar, + liftBoundary, + liftPrimConst, + liftPrimFun, + + -- ** Miscellaneous + showPreAccOp, + showExpOp, ) where ---standard library +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Slice +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Representation.Vec +import Data.Array.Accelerate.Sugar.Foreign +import Data.Array.Accelerate.Type +import Data.Primitive.Vec + import Control.DeepSeq -import Control.Monad.ST -import Data.List ( intercalate ) import Data.Kind -import Foreign.ForeignPtr -import Foreign.Marshal -import Foreign.Ptr -import Foreign.Storable -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 - -import GHC.Base ( Int#, isTrue# ) -import GHC.Int ( Int(..) ) -import GHC.Prim ( (<#), (+#), indexWord8Array#, sizeofByteArray# ) -import GHC.Ptr ( Ptr(..) ) -import GHC.Word ( Word8(..) ) -import GHC.TypeNats - --- friends -import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Representation -import qualified Data.Array.Accelerate.Array.Sugar as Sugar -import Data.Array.Accelerate.Array.Unique -import Data.Array.Accelerate.Type -#if __GLASGOW_HASKELL__ < 800 -import Data.Array.Accelerate.Error -#endif +import GHC.TypeLits --- 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 - - --- Environments --- ------------ - --- Valuation for an environment --- -data Val env where - Empty :: Val () - Push :: Val env -> t -> Val (env, t) - -push :: Val env -> (LeftHandSide s arrs env env', arrs) -> Val env' -push env (LeftHandSideWildcard _, _ ) = env -push env (LeftHandSideSingle _ , a ) = env `Push` a -push env (LeftHandSidePair l1 l2, (a, b)) = push env (l1, a) `push` (l2, b) - --- 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 -- Array expressions -- ----------------- @@ -230,104 +179,12 @@ newtype OpenAcc aenv t = OpenAcc (PreOpenAcc OpenAcc aenv t) -- type Acc = OpenAcc () -type ALeftHandSide = LeftHandSide ArrayR - -type ELeftHandSide = LeftHandSide ScalarType - -data LeftHandSide (s :: Type -> Type) v env env' where - LeftHandSideSingle - :: s v - -> LeftHandSide s v env (env, v) - - -- Note: a unit is represented as LeftHandSideWildcard TupRunit - LeftHandSideWildcard - :: TupR s v - -> LeftHandSide s v env env - - LeftHandSidePair - :: LeftHandSide s v1 env env' - -> LeftHandSide s v2 env' env'' - -> LeftHandSide s (v1, v2) env env'' - -lhsToTupR :: LeftHandSide s arrs aenv aenv' -> TupR s arrs -lhsToTupR (LeftHandSideSingle s) = TupRsingle s -lhsToTupR (LeftHandSideWildcard r) = r -lhsToTupR (LeftHandSidePair as bs) = TupRpair (lhsToTupR as) (lhsToTupR bs) - --- TODO: We should move the weakening utilities elsewhere - --- The type of shifting terms from one context into another --- This is defined as a newtype, as a type synonym containing a forall quantifier --- may give issues with impredicative polymorphism which GHC does not support. +-- Types for array binders -- -newtype env :> env' = Weaken (forall t'. Idx env t' -> Idx env' t') -- Weak or Weaken - -weakenId :: env :> env -weakenId = Weaken id - -(>:>) :: env :> env' -> Idx env t -> Idx env' t -(>:>) (Weaken k) ix = k ix - -weakenSucc' :: env :> env' -> env :> (env', t) -weakenSucc' (Weaken f) = Weaken (SuccIdx . f) - -weakenSucc :: (env, t) :> env' -> env :> env' -weakenSucc (Weaken f) = Weaken (f . SuccIdx) +type ALeftHandSide = LeftHandSide ArrayR +type ArrayVar = Var ArrayR +type ArrayVars aenv = Vars ArrayR aenv -weakenEmpty :: () :> env' -weakenEmpty = Weaken (\x -> case x of {}) - -sink :: forall env env' t. env :> env' -> (env, t) :> (env', t) -sink (Weaken f) = Weaken g - where - g :: Idx (env, t) t' -> Idx (env', t) t' - g ZeroIdx = ZeroIdx - g (SuccIdx ix) = SuccIdx $ f ix - -infixr 9 .> -(.>) :: env2 :> env3 -> env1 :> env2 -> env1 :> env3 -(.>) (Weaken f) (Weaken g) = Weaken (f . g) - -sinkWithLHS :: LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> env1 :> env2 -> env1' :> env2' -sinkWithLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k -sinkWithLHS (LeftHandSideSingle _) (LeftHandSideSingle _) k = sink k -sinkWithLHS (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k = sinkWithLHS b1 b2 $ sinkWithLHS a1 a2 k -sinkWithLHS _ _ _ = error "sinkWithLHS: left hand sides do not match" - -weakenWithLHS :: forall s t env env'. LeftHandSide s t env env' -> env :> env' -weakenWithLHS = go weakenId - where - go :: env2 :> env' -> LeftHandSide s arrs env1 env2 -> env1 :> env' - go k (LeftHandSideWildcard _) = k - go k (LeftHandSideSingle _) = weakenSucc k - go k (LeftHandSidePair l1 l2) = go (go k l2) l1 - --- Often useful when working with LeftHandSide, when you need to --- existentially quantify on the resulting environment type. -data Exists f where - Exists :: f a -> Exists f - -type ArrayVar = Var ArrayR -type ArrayVars = Vars ArrayR - -type ExpVar = Var ScalarType -type ExpVars = Vars ScalarType - -data Var s env t = Var (s t) (Idx env t) -data Vars s env t where - VarsSingle :: Var s env a -> Vars s env a - VarsNil :: Vars s aenv () - VarsPair :: Vars s aenv a -> Vars s aenv b -> Vars s aenv (a, b) - -evars :: ExpVars env tp -> OpenExp env aenv tp -evars VarsNil = Nil -evars (VarsSingle var) = Evar var -evars (VarsPair v1 v2) = evars v1 `Pair` evars v2 - -varsType :: Vars s env t -> TupR s t -varsType (VarsSingle (Var tp _)) = TupRsingle tp -varsType VarsNil = TupRunit -varsType (VarsPair v1 v2) = varsType v1 `TupRpair` varsType v2 -- | Collective array computations parametrised over array variables -- represented with de Bruijn indices. @@ -385,7 +242,7 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- Accelerate version for use with other backends. The functions must be -- closed. -- - Aforeign :: Sugar.Foreign asm + Aforeign :: Foreign asm => ArraysR bs -> asm (as -> bs) -- The foreign function for a given backend -> PreAfun acc (as -> bs) -- Fallback implementation(s) @@ -416,7 +273,7 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- Capture a scalar (or a tuple of scalars) in a singleton array -- - Unit :: TupleType e + Unit :: TypeR e -> Exp aenv e -> PreOpenAcc acc aenv (Scalar e) @@ -471,7 +328,7 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- Apply the given unary function to all elements of the given array -- - Map :: TupleType e' + Map :: TypeR e' -> Fun aenv (e -> e') -> acc aenv (Array sh e) -> PreOpenAcc acc aenv (Array sh e') @@ -480,7 +337,7 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- arrays. The length of the result is the length of the shorter of the -- two argument arrays. -- - ZipWith :: TupleType e3 + ZipWith :: TypeR e3 -> Fun aenv (e1 -> e2 -> e3) -> acc aenv (Array sh e1) -> acc aenv (Array sh e2) @@ -601,7 +458,7 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- a stencil function is an entire /neighbourhood/ of each array element. -- Stencil :: StencilR sh e stencil - -> TupleType e' + -> TypeR e' -> Fun aenv (stencil -> e') -- stencil function -> Boundary aenv (Array sh e) -- boundary condition -> acc aenv (Array sh e) -- source array @@ -611,7 +468,7 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- Stencil2 :: StencilR sh a stencil1 -> StencilR sh b stencil2 - -> TupleType c + -> TypeR c -> Fun aenv (stencil1 -> stencil2 -> c) -- stencil function -> Boundary aenv (Array sh a) -- boundary condition #1 -> acc aenv (Array sh a) -- source array #1 @@ -619,128 +476,6 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -> 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 boundary condition specification for stencil operations -- @@ -762,87 +497,42 @@ data Boundary aenv t where Function :: Fun aenv (sh -> e) -> Boundary aenv (Array sh e) -data PairIdx p a where - PairIdxLeft :: PairIdx (a, b) a - PairIdxRight :: PairIdx (a, b) b - -class HasArraysRepr f where - arraysRepr :: f aenv a -> ArraysR a - -arrayRepr :: HasArraysRepr f => f aenv (Array sh e) -> ArrayR (Array sh e) -arrayRepr a = case arraysRepr a of - TupRsingle repr -> repr - -instance HasArraysRepr acc => HasArraysRepr (PreOpenAcc acc) where - arraysRepr (Alet _ _ body) = arraysRepr body - arraysRepr (Avar (Var repr _)) = TupRsingle repr - arraysRepr (Apair as bs) = TupRpair (arraysRepr as) (arraysRepr bs) - arraysRepr Anil = TupRunit - arraysRepr (Apply repr _ _) = repr - arraysRepr (Aforeign r _ _ _) = r - arraysRepr (Acond _ whenTrue _) = arraysRepr whenTrue - arraysRepr (Awhile _ (Alam lhs _) _) = lhsToTupR lhs - arraysRepr (Awhile _ _ _) = error "I want my, I want my MTV!" - arraysRepr (Use repr _) = TupRsingle repr - arraysRepr (Unit tp _) = arraysRarray ShapeRz tp - arraysRepr (Reshape sh _ a) = let ArrayR _ tp = arrayRepr a - in arraysRarray sh tp - arraysRepr (Generate repr _ _) = TupRsingle repr - arraysRepr (Transform repr _ _ _ _) = TupRsingle repr - arraysRepr (Replicate slice _ a) = let ArrayR _ tp = arrayRepr a - in arraysRarray (sliceDomainR slice) tp - arraysRepr (Slice slice a _) = let ArrayR _ tp = arrayRepr a - in arraysRarray (sliceShapeR slice) tp - arraysRepr (Map tp _ a) = let ArrayR sh _ = arrayRepr a - in arraysRarray sh tp - arraysRepr (ZipWith tp _ a _) = let ArrayR sh _ = arrayRepr a - in arraysRarray sh tp - arraysRepr (Fold _ _ a) = let ArrayR (ShapeRsnoc sh) tp = arrayRepr a - in arraysRarray sh tp - arraysRepr (Fold1 _ a) = let ArrayR (ShapeRsnoc sh) tp = arrayRepr a - in arraysRarray sh tp - arraysRepr (FoldSeg _ _ _ a _) = arraysRepr a - arraysRepr (Fold1Seg _ _ a _) = arraysRepr a - arraysRepr (Scanl _ _ a) = arraysRepr a - arraysRepr (Scanl' _ _ a) = let repr@(ArrayR (ShapeRsnoc sh) tp) = arrayRepr a - in TupRsingle repr `TupRpair` TupRsingle (ArrayR sh tp) - arraysRepr (Scanl1 _ a) = arraysRepr a - arraysRepr (Scanr _ _ a) = arraysRepr a - arraysRepr (Scanr' _ _ a) = let repr@(ArrayR (ShapeRsnoc sh) tp) = arrayRepr a - in TupRsingle repr `TupRpair` TupRsingle (ArrayR sh tp) - arraysRepr (Scanr1 _ a) = arraysRepr a - arraysRepr (Permute _ a _ _) = arraysRepr a - arraysRepr (Backpermute sh _ _ a) = let ArrayR _ tp = arrayRepr a - in arraysRarray sh tp - arraysRepr (Stencil _ tp _ _ a) = let ArrayR sh _ = arrayRepr a - in arraysRarray sh tp - arraysRepr (Stencil2 _ _ tp _ _ a _ _) = let ArrayR sh _ = arrayRepr a - in arraysRarray sh tp - -instance HasArraysRepr OpenAcc where - arraysRepr (OpenAcc a) = arraysRepr a + -- Embedded expressions -- -------------------- --- |Vanilla open function abstraction +-- | Vanilla open function abstraction -- data OpenFun env aenv t where Body :: OpenExp env aenv t -> OpenFun env aenv t Lam :: ELeftHandSide a env env' -> OpenFun env' aenv t -> OpenFun env aenv (a -> t) --- |Vanilla function without free scalar variables +-- | Vanilla function without free scalar variables -- type Fun = OpenFun () --- |Vanilla expression without free scalar variables +-- | Vanilla expression without free scalar variables -- type Exp = OpenExp () --- |Vanilla 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. +-- Types for scalar bindings -- --- The data type is parametrised over the representation type (not the surface types). +type ELeftHandSide = LeftHandSide ScalarType +type ExpVar = Var ScalarType +type ExpVars env = Vars ScalarType env + +expVars :: ExpVars env t -> OpenExp env aenv t +expVars TupRunit = Nil +expVars (TupRsingle var) = Evar var +expVars (TupRpair v1 v2) = expVars v1 `Pair` expVars v2 + + +-- | Vanilla 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 representation type (not the +-- surface types). -- data OpenExp env aenv t where @@ -857,8 +547,8 @@ data OpenExp env aenv t where -> OpenExp env aenv t -- Apply a backend-specific foreign function - Foreign :: Sugar.Foreign asm - => TupleType y + Foreign :: Foreign asm + => TypeR y -> asm (x -> y) -- foreign function -> Fun () (x -> y) -- alternate implementation (for other backends) -> OpenExp env aenv x @@ -961,33 +651,6 @@ data OpenExp env aenv t where -> OpenExp env aenv a -> OpenExp env aenv b - -expType :: OpenExp aenv env t -> TupleType t -expType expr = case expr of - Let _ _ body -> expType body - Evar (Var tp _) -> TupRsingle tp - Foreign tp _ _ _ -> tp - Pair e1 e2 -> TupRpair (expType e1) (expType e2) - Nil -> TupRunit - VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR - VecUnpack vecR _ -> vecRtuple vecR - IndexSlice si _ _ -> shapeType $ sliceShapeR si - IndexFull si _ _ -> shapeType $ sliceDomainR si - ToIndex _ _ _ -> TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType $ TypeInt - FromIndex shr _ _ -> shapeType shr - Cond _ e _ -> expType e - While _ (Lam lhs _) _ -> lhsToTupR lhs - While _ _ _ -> error "What's the matter, you're running in the shadows" - Const tp _ -> TupRsingle tp - PrimConst c -> TupRsingle $ SingleScalarType $ primConstType c - PrimApp f _ -> snd $ primFunType f - Index (Var repr _) _ -> arrayRtype repr - LinearIndex (Var repr _) _ -> arrayRtype repr - Shape (Var repr _) -> shapeType $ arrayRshape repr - ShapeSize _ _ -> TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType $ TypeInt - Undef tp -> TupRsingle tp - Coerce _ tp _ -> TupRsingle tp - -- |Primitive constant values -- data PrimConst ty where @@ -999,6 +662,7 @@ data PrimConst ty where -- constant from Floating PrimPi :: FloatingType a -> PrimConst a + -- |Primitive scalar operations -- data PrimFun sig where @@ -1078,12 +742,15 @@ data PrimFun sig where PrimMin :: SingleType a -> PrimFun ((a, a) -> a ) -- logical operators - -- Note that these operators are strict in both arguments, - -- eg the second argument of PrimLAnd is always evaluated - -- even when the first argument is false. We thus define - -- (&&) and (||) using if-then-else to enable short-circuiting. - -- (&&!) and (||!) are strict versions of these operators, - -- which are defined using PrimLAnd and PrimLOr. + -- + -- Note that these operators are strict in both arguments. That is, the + -- second argument of PrimLAnd is always evaluated even when the first + -- argument is false. + -- + -- We define (surface level) (&&) and (||) using if-then-else to enable + -- short-circuiting, while (&&!) and (||!) are strict versions of these + -- operators, which are defined using PrimLAnd and PrimLOr. + -- PrimLAnd :: PrimFun ((Bool, Bool) -> Bool) PrimLOr :: PrimFun ((Bool, Bool) -> Bool) PrimLNot :: PrimFun (Bool -> Bool) @@ -1099,81 +766,167 @@ data PrimFun sig where PrimFromIntegral :: IntegralType a -> NumType b -> PrimFun (a -> b) PrimToFloating :: NumType a -> FloatingType b -> PrimFun (a -> b) + +-- Type utilities +-- -------------- + +class HasArraysR f where + arraysR :: f aenv a -> ArraysR a + +instance HasArraysR OpenAcc where + arraysR (OpenAcc a) = arraysR a + +arrayR :: HasArraysR f => f aenv (Array sh e) -> ArrayR (Array sh e) +arrayR a = case arraysR a of + TupRsingle aR -> aR + +instance HasArraysR acc => HasArraysR (PreOpenAcc acc) where + arraysR (Alet _ _ body) = arraysR body + arraysR (Avar (Var aR _)) = TupRsingle aR + arraysR (Apair as bs) = TupRpair (arraysR as) (arraysR bs) + arraysR Anil = TupRunit + arraysR (Apply aR _ _) = aR + arraysR (Aforeign r _ _ _) = r + arraysR (Acond _ a _) = arraysR a + arraysR (Awhile _ (Alam lhs _) _) = lhsToTupR lhs + arraysR Awhile{} = error "I want my, I want my MTV!" + arraysR (Use aR _) = TupRsingle aR + arraysR (Unit tR _) = arraysRarray ShapeRz tR + arraysR (Reshape sh _ a) = let ArrayR _ tR = arrayR a + in arraysRarray sh tR + arraysR (Generate aR _ _) = TupRsingle aR + arraysR (Transform aR _ _ _ _) = TupRsingle aR + arraysR (Replicate slice _ a) = let ArrayR _ tR = arrayR a + in arraysRarray (sliceDomainR slice) tR + arraysR (Slice slice a _) = let ArrayR _ tR = arrayR a + in arraysRarray (sliceShapeR slice) tR + arraysR (Map tR _ a) = let ArrayR sh _ = arrayR a + in arraysRarray sh tR + arraysR (ZipWith tR _ a _) = let ArrayR sh _ = arrayR a + in arraysRarray sh tR + arraysR (Fold _ _ a) = let ArrayR (ShapeRsnoc sh) tR = arrayR a + in arraysRarray sh tR + arraysR (Fold1 _ a) = let ArrayR (ShapeRsnoc sh) tR = arrayR a + in arraysRarray sh tR + arraysR (FoldSeg _ _ _ a _) = arraysR a + arraysR (Fold1Seg _ _ a _) = arraysR a + arraysR (Scanl _ _ a) = arraysR a + arraysR (Scanl' _ _ a) = let aR@(ArrayR (ShapeRsnoc sh) tR) = arrayR a + in TupRsingle aR `TupRpair` TupRsingle (ArrayR sh tR) + arraysR (Scanl1 _ a) = arraysR a + arraysR (Scanr _ _ a) = arraysR a + arraysR (Scanr' _ _ a) = let aR@(ArrayR (ShapeRsnoc sh) tR) = arrayR a + in TupRsingle aR `TupRpair` TupRsingle (ArrayR sh tR) + arraysR (Scanr1 _ a) = arraysR a + arraysR (Permute _ a _ _) = arraysR a + arraysR (Backpermute sh _ _ a) = let ArrayR _ tR = arrayR a + in arraysRarray sh tR + arraysR (Stencil _ tR _ _ a) = let ArrayR sh _ = arrayR a + in arraysRarray sh tR + arraysR (Stencil2 _ _ tR _ _ a _ _) = let ArrayR sh _ = arrayR a + in arraysRarray sh tR + +expType :: OpenExp aenv env t -> TypeR t +expType = \case + Let _ _ body -> expType body + Evar (Var tR _) -> TupRsingle tR + Foreign tR _ _ _ -> tR + Pair e1 e2 -> TupRpair (expType e1) (expType e2) + Nil -> TupRunit + VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR + VecUnpack vecR _ -> vecRtuple vecR + IndexSlice si _ _ -> shapeType $ sliceShapeR si + IndexFull si _ _ -> shapeType $ sliceDomainR si + ToIndex{} -> TupRsingle scalarTypeInt + FromIndex shr _ _ -> shapeType shr + Cond _ e _ -> expType e + While _ (Lam lhs _) _ -> lhsToTupR lhs + While{} -> error "What's the matter, you're running in the shadows" + Const tR _ -> TupRsingle tR + PrimConst c -> TupRsingle $ SingleScalarType $ primConstType c + PrimApp f _ -> snd $ primFunType f + Index (Var repr _) _ -> arrayRtype repr + LinearIndex (Var repr _) _ -> arrayRtype repr + Shape (Var repr _) -> shapeType $ arrayRshape repr + ShapeSize{} -> TupRsingle scalarTypeInt + Undef tR -> TupRsingle tR + Coerce _ tR _ -> TupRsingle tR + primConstType :: PrimConst a -> SingleType a -primConstType prim = case prim of - PrimMinBound t -> boundedTp t - PrimMaxBound t -> boundedTp t - PrimPi t -> floatingTp t +primConstType = \case + PrimMinBound t -> bounded t + PrimMaxBound t -> bounded t + PrimPi t -> floating t where - boundedTp :: BoundedType a -> SingleType a - boundedTp (IntegralBoundedType t) = NumSingleType $ IntegralNumType t - boundedTp (NonNumBoundedType t) = NonNumSingleType t + bounded :: BoundedType a -> SingleType a + bounded (IntegralBoundedType t) = NumSingleType $ IntegralNumType t + bounded (NonNumBoundedType t) = NonNumSingleType t - floatingTp :: FloatingType t -> SingleType t - floatingTp = NumSingleType . FloatingNumType + floating :: FloatingType t -> SingleType t + floating = NumSingleType . FloatingNumType -primFunType :: PrimFun (a -> b) -> (TupleType a, TupleType b) -primFunType prim = case prim of +primFunType :: PrimFun (a -> b) -> (TypeR a, TypeR b) +primFunType = \case -- Num - PrimAdd t -> binary' $ numTp t - PrimSub t -> binary' $ numTp t - PrimMul t -> binary' $ numTp t - PrimNeg t -> unary' $ numTp t - PrimAbs t -> unary' $ numTp t - PrimSig t -> unary' $ numTp t + PrimAdd t -> binary' $ num t + PrimSub t -> binary' $ num t + PrimMul t -> binary' $ num t + PrimNeg t -> unary' $ num t + PrimAbs t -> unary' $ num t + PrimSig t -> unary' $ num t -- Integral - PrimQuot t -> binary' $ integralTp t - PrimRem t -> binary' $ integralTp t - PrimQuotRem t -> divModT t - PrimIDiv t -> binary' $ integralTp t - PrimMod t -> binary' $ integralTp t - PrimDivMod t -> divModT t + PrimQuot t -> binary' $ integral t + PrimRem t -> binary' $ integral t + PrimQuotRem t -> unary' $ integral t `TupRpair` integral t + PrimIDiv t -> binary' $ integral t + PrimMod t -> binary' $ integral t + PrimDivMod t -> unary' $ integral t `TupRpair` integral t -- Bits & FiniteBits - PrimBAnd t -> binary' $ integralTp t - PrimBOr t -> binary' $ integralTp t - PrimBXor t -> binary' $ integralTp t - PrimBNot t -> unary' $ integralTp t - PrimBShiftL t -> (integralTp t `TupRpair` typeInt, integralTp t) - PrimBShiftR t -> (integralTp t `TupRpair` typeInt, integralTp t) - PrimBRotateL t -> (integralTp t `TupRpair` typeInt, integralTp t) - PrimBRotateR t -> (integralTp t `TupRpair` typeInt, integralTp t) - PrimPopCount t -> unary (integralTp t) typeInt - PrimCountLeadingZeros t -> unary (integralTp t) typeInt - PrimCountTrailingZeros t -> unary (integralTp t) typeInt + PrimBAnd t -> binary' $ integral t + PrimBOr t -> binary' $ integral t + PrimBXor t -> binary' $ integral t + PrimBNot t -> unary' $ integral t + PrimBShiftL t -> (integral t `TupRpair` int, integral t) + PrimBShiftR t -> (integral t `TupRpair` int, integral t) + PrimBRotateL t -> (integral t `TupRpair` int, integral t) + PrimBRotateR t -> (integral t `TupRpair` int, integral t) + PrimPopCount t -> unary (integral t) int + PrimCountLeadingZeros t -> unary (integral t) int + PrimCountTrailingZeros t -> unary (integral t) int -- Fractional, Floating - PrimFDiv t -> binary' $ floatingTp t - PrimRecip t -> unary' $ floatingTp t - PrimSin t -> unary' $ floatingTp t - PrimCos t -> unary' $ floatingTp t - PrimTan t -> unary' $ floatingTp t - PrimAsin t -> unary' $ floatingTp t - PrimAcos t -> unary' $ floatingTp t - PrimAtan t -> unary' $ floatingTp t - PrimSinh t -> unary' $ floatingTp t - PrimCosh t -> unary' $ floatingTp t - PrimTanh t -> unary' $ floatingTp t - PrimAsinh t -> unary' $ floatingTp t - PrimAcosh t -> unary' $ floatingTp t - PrimAtanh t -> unary' $ floatingTp t - PrimExpFloating t -> unary' $ floatingTp t - PrimSqrt t -> unary' $ floatingTp t - PrimLog t -> unary' $ floatingTp t - PrimFPow t -> binary' $ floatingTp t - PrimLogBase t -> binary' $ floatingTp t + PrimFDiv t -> binary' $ floating t + PrimRecip t -> unary' $ floating t + PrimSin t -> unary' $ floating t + PrimCos t -> unary' $ floating t + PrimTan t -> unary' $ floating t + PrimAsin t -> unary' $ floating t + PrimAcos t -> unary' $ floating t + PrimAtan t -> unary' $ floating t + PrimSinh t -> unary' $ floating t + PrimCosh t -> unary' $ floating t + PrimTanh t -> unary' $ floating t + PrimAsinh t -> unary' $ floating t + PrimAcosh t -> unary' $ floating t + PrimAtanh t -> unary' $ floating t + PrimExpFloating t -> unary' $ floating t + PrimSqrt t -> unary' $ floating t + PrimLog t -> unary' $ floating t + PrimFPow t -> binary' $ floating t + PrimLogBase t -> binary' $ floating t -- RealFrac - PrimTruncate a b -> unary (floatingTp a) (integralTp b) - PrimRound a b -> unary (floatingTp a) (integralTp b) - PrimFloor a b -> unary (floatingTp a) (integralTp b) - PrimCeiling a b -> unary (floatingTp a) (integralTp b) + PrimTruncate a b -> unary (floating a) (integral b) + PrimRound a b -> unary (floating a) (integral b) + PrimFloor a b -> unary (floating a) (integral b) + PrimCeiling a b -> unary (floating a) (integral b) -- RealFloat - PrimAtan2 t -> binary' $ floatingTp t - PrimIsNaN t -> unary (floatingTp t) typeBool - PrimIsInfinite t -> unary (floatingTp t) typeBool + PrimAtan2 t -> binary' $ floating t + PrimIsNaN t -> unary (floating t) bool + PrimIsInfinite t -> unary (floating t) bool -- Relational and equality PrimLt t -> compare' t @@ -1182,66 +935,43 @@ primFunType prim = case prim of PrimGtEq t -> compare' t PrimEq t -> compare' t PrimNEq t -> compare' t - PrimMax t -> binary' $ singleTp t - PrimMin t -> binary' $ singleTp t + PrimMax t -> binary' $ single t + PrimMin t -> binary' $ single t -- Logical - PrimLAnd -> binary' typeBool - PrimLOr -> binary' typeBool - PrimLNot -> unary' typeBool + PrimLAnd -> binary' bool + PrimLOr -> binary' bool + PrimLNot -> unary' bool -- character conversions - PrimOrd -> unary typeChar typeInt - PrimChr -> unary typeInt typeChar + PrimOrd -> unary char int + PrimChr -> unary int char -- boolean conversion - PrimBoolToInt -> unary typeBool typeInt + PrimBoolToInt -> unary bool int -- general conversion between types - PrimFromIntegral a b -> unary (integralTp a) (numTp b) - PrimToFloating a b -> unary (numTp a) (floatingTp b) + PrimFromIntegral a b -> unary (integral a) (num b) + PrimToFloating a b -> unary (num a) (floating b) where - unary :: TupleType a -> TupleType b -> (TupleType a, TupleType b) - unary a b = (a, b) - - unary' :: TupleType a -> (TupleType a, TupleType a) - unary' a = unary a a - - binary :: TupleType a -> TupleType b -> (TupleType (a, a), TupleType b) + unary a b = (a, b) + unary' a = unary a a binary a b = (a `TupRpair` a, b) + binary' a = binary a a + compare' a = binary (single a) bool - binary' :: TupleType a -> (TupleType (a, a), TupleType a) - binary' a = binary a a - - compare' :: SingleType a -> (TupleType (a, a), TupleType Bool) - compare' a = binary (singleTp a) typeBool - - singleTp :: SingleType t -> TupleType t - singleTp = TupRsingle . SingleScalarType - - numTp :: NumType t -> TupleType t - numTp = TupRsingle . SingleScalarType . NumSingleType - - integralTp :: IntegralType t -> TupleType t - integralTp = numTp . IntegralNumType + single = TupRsingle . SingleScalarType + num = TupRsingle . SingleScalarType . NumSingleType + integral = num . IntegralNumType + floating = num . FloatingNumType - floatingTp :: FloatingType t -> TupleType t - floatingTp = numTp . FloatingNumType + bool = TupRsingle scalarTypeBool + int = TupRsingle scalarTypeInt + char = TupRsingle $ SingleScalarType $ NonNumSingleType TypeChar - divModT :: IntegralType t -> (TupleType (t, t), TupleType (t, t)) - divModT t = unary' $ integralTp t `TupRpair` integralTp t - typeBool :: TupleType Bool - typeBool = TupRsingle $ SingleScalarType $ NonNumSingleType $ TypeBool - - typeChar :: TupleType Char - typeChar = TupRsingle $ SingleScalarType $ NonNumSingleType $ TypeChar - - typeInt :: TupleType Int - typeInt = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType TypeInt - --- NFData instances +-- Normal form data -- ================ instance NFData (OpenAfun aenv f) where @@ -1250,9 +980,6 @@ instance NFData (OpenAfun aenv f) where instance NFData (OpenAcc aenv t) where rnf = rnfOpenAcc --- instance NFData (Seq t) where --- rnf = rnfPreOpenSeq rnfOpenAcc - instance NFData (OpenExp env aenv t) where rnf = rnfOpenExp @@ -1260,26 +987,19 @@ instance NFData (OpenFun env aenv t) where rnf = rnfOpenFun --- Array expressions --- ----------------- - type NFDataAcc acc = forall aenv t. acc aenv t -> () -rnfIdx :: Idx env t -> () -rnfIdx ZeroIdx = () -rnfIdx (SuccIdx ix) = rnfIdx ix - 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 lhs f) = rnfALhs lhs `seq` rnfPreOpenAfun rnfA f +rnfPreOpenAfun rnfA (Alam lhs f) = rnfALeftHandSide lhs `seq` rnfPreOpenAfun rnfA f -rnfPreOpenAcc :: forall acc aenv t. HasArraysRepr acc => NFDataAcc acc -> PreOpenAcc acc aenv t -> () +rnfOpenAcc :: OpenAcc aenv t -> () +rnfOpenAcc (OpenAcc pacc) = rnfPreOpenAcc rnfOpenAcc pacc + +rnfPreOpenAcc :: forall acc aenv t. HasArraysR acc => NFDataAcc acc -> PreOpenAcc acc aenv t -> () rnfPreOpenAcc rnfA pacc = let rnfAF :: PreOpenAfun acc aenv' t' -> () @@ -1291,30 +1011,27 @@ rnfPreOpenAcc rnfA pacc = rnfF :: OpenFun env' aenv' t' -> () rnfF = rnfOpenFun - -- rnfS :: PreOpenSeq acc aenv' senv' t' -> () - -- rnfS = rnfPreOpenSeq rnfA - rnfB :: ArrayR (Array sh e) -> Boundary aenv' (Array sh e) -> () rnfB = rnfBoundary in case pacc of - Alet lhs bnd body -> rnfALhs lhs `seq` rnfA bnd `seq` rnfA body + Alet lhs bnd body -> rnfALeftHandSide lhs `seq` rnfA bnd `seq` rnfA body Avar var -> rnfArrayVar var Apair as bs -> rnfA as `seq` rnfA bs Anil -> () Apply repr afun acc -> rnfTupR rnfArrayR repr `seq` rnfAF afun `seq` rnfA acc - Aforeign repr asm afun a -> rnfTupR rnfArrayR repr `seq` rnf (Sugar.strForeign asm) `seq` rnfAF afun `seq` rnfA a + Aforeign repr asm afun a -> rnfTupR rnfArrayR repr `seq` 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 repr arr -> rnfArray repr arr - Unit tp x -> rnfTupleType tp `seq` rnfE x + Unit tp x -> rnfTypeR tp `seq` rnfE x Reshape shr sh a -> rnfShapeR shr `seq` rnfE sh `seq` rnfA a Generate repr sh f -> rnfArrayR repr `seq` rnfE sh `seq` rnfF f Transform repr sh p f a -> rnfArrayR repr `seq` 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 tp f a -> rnfTupleType tp `seq` rnfF f `seq` rnfA a - ZipWith tp f a1 a2 -> rnfTupleType tp `seq` rnfF f `seq` rnfA a1 `seq` rnfA a2 + Map tp f a -> rnfTypeR tp `seq` rnfF f `seq` rnfA a + ZipWith tp f a1 a2 -> rnfTypeR tp `seq` 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 i f z a s -> rnfIntegralType i `seq` rnfF f `seq` rnfE z `seq` rnfA a `seq` rnfA s @@ -1329,146 +1046,32 @@ rnfPreOpenAcc rnfA pacc = Backpermute shr sh f a -> rnfShapeR shr `seq` rnfE sh `seq` rnfF f `seq` rnfA a Stencil sr tp f b a -> let - TupRsingle (ArrayR shr _) = arraysRepr a - repr = ArrayR shr $ stencilElt sr + TupRsingle (ArrayR shr _) = arraysR a + repr = ArrayR shr $ stencilEltR sr in rnfStencilR sr `seq` rnfTupR rnfScalarType tp `seq` rnfF f `seq` rnfB repr b `seq` rnfA a Stencil2 sr1 sr2 tp f b1 a1 b2 a2 -> let - TupRsingle (ArrayR shr _) = arraysRepr a1 - repr1 = ArrayR shr $ stencilElt sr1 - repr2 = ArrayR shr $ stencilElt sr2 + TupRsingle (ArrayR shr _) = arraysR a1 + repr1 = ArrayR shr $ stencilEltR sr1 + repr2 = ArrayR shr $ stencilEltR sr2 in rnfStencilR sr1 `seq` rnfStencilR sr2 `seq` rnfTupR rnfScalarType tp `seq` rnfF f `seq` rnfB repr1 b1 `seq` rnfB repr2 b2 `seq` rnfA a1 `seq` rnfA a2 - -- Collect s -> rnfS s rnfArrayVar :: ArrayVar aenv a -> () -rnfArrayVar (Var repr ix) = rnfArrayR repr `seq` rnfIdx ix - -rnfLhs :: (forall b. s b -> ()) -> LeftHandSide s arrs env env' -> () -rnfLhs rnfS (LeftHandSideWildcard r) = rnfTupR rnfS r -rnfLhs rnfS (LeftHandSideSingle s) = rnfS s -rnfLhs rnfS (LeftHandSidePair ar1 ar2) = rnfLhs rnfS ar1 `seq` rnfLhs rnfS ar2 - -rnfALhs :: ALeftHandSide arrs aenv aenv' -> () -rnfALhs = rnfLhs rnfArrayR - -rnfELhs :: ELeftHandSide t env env' -> () -rnfELhs = rnfLhs rnfScalarType - -rnfTupR :: (forall b. s b -> ()) -> TupR s a -> () -rnfTupR _ TupRunit = () -rnfTupR rnfS (TupRsingle s) = rnfS s -rnfTupR rnfS (TupRpair t1 t2) = rnfTupR rnfS t1 `seq` rnfTupR rnfS t2 - -rnfArrayR :: ArrayR arr -> () -rnfArrayR (ArrayR shr tp) = rnfShapeR shr `seq` rnfTupR rnfScalarType tp - -rnfArrays :: ArraysR arrs -> arrs -> () -rnfArrays TupRunit () = () -rnfArrays (TupRsingle repr) arr = rnfArray repr arr -rnfArrays (TupRpair ar1 ar2) (a1,a2) = rnfArrays ar1 a1 `seq` rnfArrays ar2 a2 - -rnfShapeR :: ShapeR sh -> () -rnfShapeR ShapeRz = () -rnfShapeR (ShapeRsnoc shr) = rnfShapeR shr - -rnfStencilR :: StencilR sh e pat -> () -rnfStencilR (StencilRunit3 tp) = rnfTupleType tp -rnfStencilR (StencilRunit5 tp) = rnfTupleType tp -rnfStencilR (StencilRunit7 tp) = rnfTupleType tp -rnfStencilR (StencilRunit9 tp) = rnfTupleType tp -rnfStencilR (StencilRtup3 s1 s2 s3) - = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 -rnfStencilR (StencilRtup5 s1 s2 s3 s4 s5) - = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 -rnfStencilR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) - = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 - `seq` rnfStencilR s6 `seq` rnfStencilR s7 -rnfStencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) - = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 - `seq` rnfStencilR s6 `seq` rnfStencilR s7 `seq` rnfStencilR s8 `seq` rnfStencilR s9 +rnfArrayVar = rnfVar rnfArrayR + +rnfALeftHandSide :: ALeftHandSide arrs aenv aenv' -> () +rnfALeftHandSide = rnfLeftHandSide rnfArrayR rnfBoundary :: forall aenv sh e. ArrayR (Array sh e) -> Boundary aenv (Array sh e) -> () rnfBoundary _ Clamp = () rnfBoundary _ Mirror = () rnfBoundary _ Wrap = () -rnfBoundary (ArrayR _ tp) (Constant c) = rnfConst tp c +rnfBoundary (ArrayR _ tR) (Constant c) = rnfConst tR c rnfBoundary _ (Function f) = rnfOpenFun 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 @a) (fromArr a) `seq` rnfArrs as - - rnfAF :: PreOpenAfun acc aenv' t' -> () - rnfAF = rnfPreOpenAfun rnfA - - rnfF :: OpenFun env' aenv' t' -> () - rnfF = rnfOpenFun rnfA - - rnfE :: OpenExp env' aenv' t' -> () - rnfE = rnfOpenExp 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 :: OpenFun env' aenv' t' -> () - rnfF = rnfOpenFun rnfA - - rnfE :: OpenExp env' aenv' t' -> () - rnfE = rnfOpenExp 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 --- ------------------ - rnfOpenFun :: OpenFun env aenv t -> () rnfOpenFun (Body b) = rnfOpenExp b -rnfOpenFun (Lam lhs f) = rnfELhs lhs `seq` rnfOpenFun f +rnfOpenFun (Lam lhs f) = rnfELeftHandSide lhs `seq` rnfOpenFun f rnfOpenExp :: forall env aenv t. OpenExp env aenv t -> () rnfOpenExp topExp = @@ -1480,9 +1083,9 @@ rnfOpenExp topExp = rnfE = rnfOpenExp in case topExp of - Let lhs bnd body -> rnfELhs lhs `seq` rnfE bnd `seq` rnfE body - Evar (Var tp ix) -> rnfScalarType tp `seq` rnfIdx ix - Foreign tp asm f x -> rnfTupleType tp `seq` rnf (Sugar.strForeign asm) `seq` rnfF f `seq` rnfE x + Let lhs bnd body -> rnfELeftHandSide lhs `seq` rnfE bnd `seq` rnfE body + Evar v -> rnfExpVar v + Foreign tp asm f x -> rnfTypeR tp `seq` rnf (strForeign asm) `seq` rnfF f `seq` rnfE x Const tp c -> c `seq` rnfScalarType tp -- scalars should have (nf == whnf) Undef tp -> rnfScalarType tp Pair a b -> rnfE a `seq` rnfE b @@ -1503,7 +1106,13 @@ rnfOpenExp topExp = ShapeSize shr sh -> rnfShapeR shr `seq` rnfE sh Coerce t1 t2 e -> rnfScalarType t1 `seq` rnfScalarType t2 `seq` rnfE e -rnfConst :: TupleType t -> t -> () +rnfExpVar :: ExpVar env t -> () +rnfExpVar = rnfVar rnfScalarType + +rnfELeftHandSide :: ELeftHandSide t env env' -> () +rnfELeftHandSide= rnfLeftHandSide rnfScalarType + +rnfConst :: TypeR t -> t -> () rnfConst TupRunit () = () rnfConst (TupRsingle t) !_ = rnfScalarType t -- scalars should have (nf == whnf) rnfConst (TupRpair ta tb) (a,b) = rnfConst ta a `seq` rnfConst tb b @@ -1580,75 +1189,19 @@ 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 - -rnfTupleType :: TupleType t -> () -rnfTupleType = rnfTupR rnfScalarType - -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 (VectorType !_ 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 = () -rnfNonNumType TypeChar = () - -rnfIntegralType :: IntegralType t -> () -rnfIntegralType TypeInt = () -rnfIntegralType TypeInt8 = () -rnfIntegralType TypeInt16 = () -rnfIntegralType TypeInt32 = () -rnfIntegralType TypeInt64 = () -rnfIntegralType TypeWord = () -rnfIntegralType TypeWord8 = () -rnfIntegralType TypeWord16 = () -rnfIntegralType TypeWord32 = () -rnfIntegralType TypeWord64 = () - -rnfFloatingType :: FloatingType t -> () -rnfFloatingType TypeHalf = () -rnfFloatingType TypeFloat = () -rnfFloatingType TypeDouble = () - -rnfVecR :: VecR n single tuple -> () -rnfVecR (VecRnil tp) = rnfSingleType tp -rnfVecR (VecRsucc vec) = rnfVecR vec -- 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) ||] - - liftPreOpenAfun :: LiftAcc acc -> PreOpenAfun acc aenv t -> Q (TExp (PreOpenAfun acc aenv t)) -liftPreOpenAfun liftA (Alam lhs f) = [|| Alam $$(liftALhs lhs) $$(liftPreOpenAfun liftA f) ||] +liftPreOpenAfun liftA (Alam lhs f) = [|| Alam $$(liftALeftHandSide lhs) $$(liftPreOpenAfun liftA f) ||] liftPreOpenAfun liftA (Abody b) = [|| Abody $$(liftA b) ||] liftPreOpenAcc :: forall acc aenv a. - HasArraysRepr acc + HasArraysR acc => LiftAcc acc -> PreOpenAcc acc aenv a -> Q (TExp (PreOpenAcc acc aenv a)) @@ -1668,23 +1221,23 @@ liftPreOpenAcc liftA pacc = in case pacc of - Alet lhs bnd body -> [|| Alet $$(liftALhs lhs) $$(liftA bnd) $$(liftA body) ||] + Alet lhs bnd body -> [|| Alet $$(liftALeftHandSide lhs) $$(liftA bnd) $$(liftA body) ||] Avar var -> [|| Avar $$(liftArrayVar var) ||] Apair as bs -> [|| Apair $$(liftA as) $$(liftA bs) ||] Anil -> [|| Anil ||] Apply repr f a -> [|| Apply $$(liftArraysR repr) $$(liftAF f) $$(liftA a) ||] - Aforeign repr asm f a -> [|| Aforeign $$(liftArraysR repr) $$(Sugar.liftForeign asm) $$(liftPreOpenAfun liftA f) $$(liftA a) ||] + Aforeign repr asm f a -> [|| Aforeign $$(liftArraysR repr) $$(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 repr a -> [|| Use $$(liftArrayR repr) $$(liftArray repr a) ||] - Unit tp e -> [|| Unit $$(liftTupleType tp) $$(liftE e) ||] + Unit tp e -> [|| Unit $$(liftTypeR tp) $$(liftE e) ||] Reshape shr sh a -> [|| Reshape $$(liftShapeR shr) $$(liftE sh) $$(liftA a) ||] Generate repr sh f -> [|| Generate $$(liftArrayR repr) $$(liftE sh) $$(liftF f) ||] Transform repr sh p f a -> [|| Transform $$(liftArrayR repr) $$(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 tp f a -> [|| Map $$(liftTupleType tp) $$(liftF f) $$(liftA a) ||] - ZipWith tp f a b -> [|| ZipWith $$(liftTupleType tp) $$(liftF f) $$(liftA a) $$(liftA b) ||] + Map tp f a -> [|| Map $$(liftTypeR tp) $$(liftF f) $$(liftA a) ||] + ZipWith tp f a b -> [|| ZipWith $$(liftTypeR tp) $$(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 i f z a s -> [|| FoldSeg $$(liftIntegralType i) $$(liftF f) $$(liftE z) $$(liftA a) $$(liftA s) ||] @@ -1699,58 +1252,27 @@ liftPreOpenAcc liftA pacc = Backpermute shr sh p a -> [|| Backpermute $$(liftShapeR shr) $$(liftE sh) $$(liftF p) $$(liftA a) ||] Stencil sr tp f b a -> let - TupRsingle (ArrayR shr _) = arraysRepr a - repr = ArrayR shr $ stencilElt sr - in [|| Stencil $$(liftStencilR sr) $$(liftTupleType tp) $$(liftF f) $$(liftB repr b) $$(liftA a) ||] + TupRsingle (ArrayR shr _) = arraysR a + repr = ArrayR shr $ stencilEltR sr + in [|| Stencil $$(liftStencilR sr) $$(liftTypeR tp) $$(liftF f) $$(liftB repr b) $$(liftA a) ||] Stencil2 sr1 sr2 tp f b1 a1 b2 a2 -> let - TupRsingle (ArrayR shr _) = arraysRepr a1 - repr1 = ArrayR shr $ stencilElt sr1 - repr2 = ArrayR shr $ stencilElt sr2 - in [|| Stencil2 $$(liftStencilR sr1) $$(liftStencilR sr2) $$(liftTupleType tp) $$(liftF f) $$(liftB repr1 b1) $$(liftA a1) $$(liftB repr2 b2) $$(liftA a2) ||] - -liftALhs :: ALeftHandSide arrs aenv aenv' -> Q (TExp (ALeftHandSide arrs aenv aenv')) -liftALhs (LeftHandSideSingle repr) = [|| LeftHandSideSingle $$(liftArrayR repr) ||] -liftALhs (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftArraysR r) ||] -liftALhs (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftALhs a) $$(liftALhs b) ||] - -liftELhs :: ELeftHandSide t env env' -> Q (TExp (ELeftHandSide t env env')) -liftELhs (LeftHandSideSingle t) = [|| LeftHandSideSingle $$(liftScalarType t) ||] -liftELhs (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftTupleType r) ||] -liftELhs (LeftHandSidePair a b) = [|| LeftHandSidePair $$(liftELhs a) $$(liftELhs b) ||] - -liftShapeR :: ShapeR sh -> Q (TExp (ShapeR sh)) -liftShapeR ShapeRz = [|| ShapeRz ||] -liftShapeR (ShapeRsnoc sh) = [|| ShapeRsnoc $$(liftShapeR sh) ||] - -liftArrayR :: ArrayR a -> Q (TExp (ArrayR a)) -liftArrayR (ArrayR shr tp) = [|| ArrayR $$(liftShapeR shr) $$(liftTupleType tp) ||] - -liftArraysR :: ArraysR arrs -> Q (TExp (ArraysR arrs)) -liftArraysR TupRunit = [|| TupRunit ||] -liftArraysR (TupRsingle repr) = [|| TupRsingle $$(liftArrayR repr) ||] -liftArraysR (TupRpair a b) = [|| TupRpair $$(liftArraysR a) $$(liftArraysR b) ||] - -liftStencilR :: StencilR sh e pat -> Q (TExp (StencilR sh e pat)) -liftStencilR (StencilRunit3 tp) = [|| StencilRunit3 $$(liftTupleType tp) ||] -liftStencilR (StencilRunit5 tp) = [|| StencilRunit5 $$(liftTupleType tp) ||] -liftStencilR (StencilRunit7 tp) = [|| StencilRunit7 $$(liftTupleType tp) ||] -liftStencilR (StencilRunit9 tp) = [|| StencilRunit9 $$(liftTupleType tp) ||] -liftStencilR (StencilRtup3 s1 s2 s3) - = [|| StencilRtup3 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) ||] -liftStencilR (StencilRtup5 s1 s2 s3 s4 s5) - = [|| StencilRtup5 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) ||] -liftStencilR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) - = [|| StencilRtup7 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) - $$(liftStencilR s6) $$(liftStencilR s7) ||] -liftStencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) - = [|| StencilRtup9 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) - $$(liftStencilR s6) $$(liftStencilR s7) $$(liftStencilR s8) $$(liftStencilR s9) ||] + TupRsingle (ArrayR shr _) = arraysR a1 + repr1 = ArrayR shr $ stencilEltR sr1 + repr2 = ArrayR shr $ stencilEltR sr2 + in [|| Stencil2 $$(liftStencilR sr1) $$(liftStencilR sr2) $$(liftTypeR tp) $$(liftF f) $$(liftB repr1 b1) $$(liftA a1) $$(liftB repr2 b2) $$(liftA a2) ||] + + +liftALeftHandSide :: ALeftHandSide arrs aenv aenv' -> Q (TExp (ALeftHandSide arrs aenv aenv')) +liftALeftHandSide = liftLeftHandSide liftArrayR + +liftArrayVar :: ArrayVar aenv a -> Q (TExp (ArrayVar aenv a)) +liftArrayVar = liftVar liftArrayR liftOpenFun :: OpenFun env aenv t -> Q (TExp (OpenFun env aenv t)) -liftOpenFun (Lam lhs f) = [|| Lam $$(liftELhs lhs) $$(liftOpenFun f) ||] +liftOpenFun (Lam lhs f) = [|| Lam $$(liftELeftHandSide lhs) $$(liftOpenFun f) ||] liftOpenFun (Body b) = [|| Body $$(liftOpenExp b) ||] liftOpenExp @@ -1766,10 +1288,10 @@ liftOpenExp pexp = liftF = liftOpenFun in case pexp of - Let lhs bnd body -> [|| Let $$(liftELhs lhs) $$(liftOpenExp bnd) $$(liftOpenExp body) ||] + Let lhs bnd body -> [|| Let $$(liftELeftHandSide lhs) $$(liftOpenExp bnd) $$(liftOpenExp body) ||] Evar var -> [|| Evar $$(liftExpVar var) ||] - Foreign repr asm f x -> [|| Foreign $$(liftTupleType repr) $$(Sugar.liftForeign asm) $$(liftOpenFun f) $$(liftE x) ||] - Const tp c -> [|| Const $$(liftScalarType tp) $$(liftConst (TupRsingle tp) c) ||] + Foreign repr asm f x -> [|| Foreign $$(liftTypeR repr) $$(liftForeign asm) $$(liftOpenFun f) $$(liftE x) ||] + Const tp c -> [|| Const $$(liftScalarType tp) $$(liftElt (TupRsingle tp) c) ||] Undef tp -> [|| Undef $$(liftScalarType tp) ||] Pair a b -> [|| Pair $$(liftE a) $$(liftE b) ||] Nil -> [|| Nil ||] @@ -1789,113 +1311,11 @@ liftOpenExp pexp = ShapeSize shr ix -> [|| ShapeSize $$(liftShapeR shr) $$(liftE ix) ||] Coerce t1 t2 e -> [|| Coerce $$(liftScalarType t1) $$(liftScalarType t2) $$(liftE e) ||] -liftExpVar :: ExpVar env t -> Q (TExp (ExpVar env t)) -liftExpVar (Var tp ix) = [|| Var $$(liftScalarType tp) $$(liftIdx ix) ||] +liftELeftHandSide :: ELeftHandSide t env env' -> Q (TExp (ELeftHandSide t env env')) +liftELeftHandSide = liftLeftHandSide liftScalarType -liftArrayVar :: ArrayVar aenv a -> Q (TExp (ArrayVar aenv a)) -liftArrayVar (Var repr ix) = [|| Var $$(liftArrayR repr) $$(liftIdx ix) ||] - -liftArray :: forall sh e. ArrayR (Array sh e) -> Array sh e -> Q (TExp (Array sh e)) -liftArray (ArrayR shr tp) (Array sh adata) = - [|| Array $$(liftConst (shapeType shr) sh) $$(go tp adata) ||] `sigE` [t| Array $(typeToQType $ shapeType shr) $(typeToQType tp) |] - where - sz :: Int - sz = size shr sh - - sigE :: Q (TExp t) -> Q TH.Type -> Q (TExp t) - sigE e t = TH.unsafeTExpCoerce $ TH.sigE (TH.unTypeQ e) t - - typeToQType :: TupleType t -> Q TH.Type - typeToQType TupRunit = [t| () |] - typeToQType (TupRpair t1 t2) = [t| ($(typeToQType t1), $(typeToQType t2)) |] - typeToQType (TupRsingle t) = scalarTypeToQType t - - scalarTypeToQType :: ScalarType t -> Q TH.Type - scalarTypeToQType (SingleScalarType t) = singleTypeToQType t - scalarTypeToQType (VectorScalarType t) = vectorTypeToQType t - - singleTypeToQType :: SingleType t -> Q TH.Type - singleTypeToQType (NumSingleType (IntegralNumType t)) = case t of - TypeInt -> [t| Int |] - TypeInt8 -> [t| Int8 |] - TypeInt16 -> [t| Int16 |] - TypeInt32 -> [t| Int32 |] - TypeInt64 -> [t| Int64 |] - TypeWord -> [t| Word |] - TypeWord8 -> [t| Word8 |] - TypeWord16 -> [t| Word16 |] - TypeWord32 -> [t| Word32 |] - TypeWord64 -> [t| Word64 |] - singleTypeToQType (NumSingleType (FloatingNumType t)) = case t of - TypeHalf -> [t| Half |] - TypeFloat -> [t| Float |] - TypeDouble -> [t| Double |] - singleTypeToQType (NonNumSingleType TypeBool) = [t| Bool |] - singleTypeToQType (NonNumSingleType TypeChar) = [t| Char |] - - vectorTypeToQType :: VectorType (Vec n a) -> Q TH.Type - vectorTypeToQType (VectorType _ stp) = [t| Vec $(undefined) $(singleTypeToQType stp) |] - - -- TODO: make sure that the resulting array is 16-byte aligned... - arr :: forall 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 :: TupleType e' -> ArrayData e' -> Q (TExp (ArrayData e')) - go TupRunit () = [|| () ||] - go (TupRpair t1 t2) (a1, a2) = [|| ($$(go t1 a1), $$(go t2 a2)) ||] - go (TupRsingle stp) a = goScalar stp a - - goScalar :: ScalarType e' -> ArrayData e' -> Q (TExp (ArrayData e')) - goScalar (SingleScalarType stp) a = goSingle stp a - goScalar (VectorScalarType (VectorType _ stp)) a = goVector stp a - - goSingle :: SingleType e' -> ArrayData e' -> Q (TExp (ArrayData e')) - goSingle (NumSingleType (IntegralNumType itp)) = case itp of - TypeInt -> arr - TypeInt8 -> arr - TypeInt16 -> arr - TypeInt32 -> arr - TypeInt64 -> arr - TypeWord -> arr - TypeWord8 -> arr - TypeWord16 -> arr - TypeWord32 -> arr - TypeWord64 -> arr - goSingle (NumSingleType (FloatingNumType ftp)) = case ftp of - TypeHalf -> arr - TypeFloat -> arr - TypeDouble -> arr - goSingle (NonNumSingleType TypeChar) = arr - goSingle (NonNumSingleType TypeBool) = arr - - -- This function has the same implementation as goSingle, but different types. - -- We could convince the type system to have this written as a single function, - -- as ArrayData uses a type family to create a structure of arrays, containing - -- scalars, where the scalars are again handled by a type family (ScalarDataRepr) - goVector :: SingleType e' -> ArrayData (Vec n e') -> Q (TExp (ArrayData (Vec n e'))) - goVector (NumSingleType (IntegralNumType itp)) = case itp of - TypeInt -> arr - TypeInt8 -> arr - TypeInt16 -> arr - TypeInt32 -> arr - TypeInt64 -> arr - TypeWord -> arr - TypeWord8 -> arr - TypeWord16 -> arr - TypeWord32 -> arr - TypeWord64 -> arr - goVector (NumSingleType (FloatingNumType ftp)) = case ftp of - TypeHalf -> arr - TypeFloat -> arr - TypeDouble -> arr - goVector (NonNumSingleType TypeChar) = arr - goVector (NonNumSingleType TypeBool) = arr +liftExpVar :: ExpVar env t -> Q (TExp (ExpVar env t)) +liftExpVar = liftVar liftScalarType liftBoundary :: forall aenv sh e. @@ -1905,14 +1325,9 @@ liftBoundary liftBoundary _ Clamp = [|| Clamp ||] liftBoundary _ Mirror = [|| Mirror ||] liftBoundary _ Wrap = [|| Wrap ||] -liftBoundary (ArrayR _ tp) (Constant v) = [|| Constant $$(liftConst tp v) ||] +liftBoundary (ArrayR _ tp) (Constant v) = [|| Constant $$(liftElt tp v) ||] liftBoundary _ (Function f) = [|| Function $$(liftOpenFun 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) ||] @@ -1985,199 +1400,62 @@ liftPrimFun PrimBoolToInt = [|| PrimBoolToInt ||] liftPrimFun (PrimFromIntegral ta tb) = [|| PrimFromIntegral $$(liftIntegralType ta) $$(liftNumType tb) ||] liftPrimFun (PrimToFloating ta tb) = [|| PrimToFloating $$(liftNumType ta) $$(liftFloatingType tb) ||] -liftTupleType :: TupleType t -> Q (TExp (TupleType t)) -liftTupleType TupRunit = [|| TupRunit ||] -liftTupleType (TupRsingle t) = [|| TupRsingle $$(liftScalarType t) ||] -liftTupleType (TupRpair ta tb) = [|| TupRpair $$(liftTupleType ta) $$(liftTupleType tb) ||] - -liftConst :: TupleType t -> t -> Q (TExp t) -liftConst TupRunit () = [|| () ||] -liftConst (TupRsingle t) x = [|| $$(liftScalar t x) ||] -liftConst (TupRpair 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 t -> t -> Q (TExp t) -liftVector VectorType{} x = liftVec x - -liftVecR :: VecR n single tuple -> Q (TExp (VecR n single tuple)) -liftVecR (VecRnil tp) = [|| VecRnil $$(liftSingleType tp) ||] -liftVecR (VecRsucc vec) = [|| VecRsucc $$(liftVecR vec) ||] - --- O(n) at runtime to copy from the Addr# to the ByteArray#. We should be able --- to do this without copying, but I don't think the definition of ByteArray# is --- exported (or it is deeply magical). --- -liftVec :: Vec n a -> Q (TExp (Vec n a)) -liftVec (Vec ba#) - = TH.unsafeTExpCoerce - $ [| runST $ \s -> - case newByteArray# $(liftInt# n#) s of { (# s1, mba# #) -> - case copyAddrToByteArray# $(TH.litE (TH.StringPrimL bytes)) mba# 0# $(liftInt# n#) s1 of { s2 -> - case unsafeFreezeByteArray# mba# s2 of { (# s3, ba'# #) -> - (# s3, Vec ba'# #) - }}} - |] - where - bytes :: [Word8] - bytes = go 0# - where - go i# | isTrue# (i# <# n#) = W8# (indexWord8Array# ba# i#) : go (i# +# 1#) - | otherwise = [] - - n# = sizeofByteArray# ba# - --- XXX: Typed TH does not support unlifted types --- -liftInt# :: Int# -> TH.ExpQ -liftInt# i# = TH.litE (TH.IntPrimL (toInteger (I# i#))) - -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 ||] - -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 ||] - -liftFloating :: FloatingType t -> t -> Q (TExp t) -liftFloating TypeHalf{} x = [|| x ||] -liftFloating TypeFloat{} x = [|| x ||] -liftFloating TypeDouble{} x = [|| x ||] - - -liftIntegralType :: IntegralType t -> Q (TExp (IntegralType t)) -liftIntegralType TypeInt{} = [|| TypeInt ||] -liftIntegralType TypeInt8{} = [|| TypeInt8 ||] -liftIntegralType TypeInt16{} = [|| TypeInt16 ||] -liftIntegralType TypeInt32{} = [|| TypeInt32 ||] -liftIntegralType TypeInt64{} = [|| TypeInt64 ||] -liftIntegralType TypeWord{} = [|| TypeWord ||] -liftIntegralType TypeWord8{} = [|| TypeWord8 ||] -liftIntegralType TypeWord16{} = [|| TypeWord16 ||] -liftIntegralType TypeWord32{} = [|| TypeWord32 ||] -liftIntegralType TypeWord64{} = [|| TypeWord64 ||] - -liftFloatingType :: FloatingType t -> Q (TExp (FloatingType t)) -liftFloatingType TypeHalf{} = [|| TypeHalf ||] -liftFloatingType TypeFloat{} = [|| TypeFloat ||] -liftFloatingType TypeDouble{} = [|| TypeDouble ||] - -liftNonNumType :: NonNumType t -> Q (TExp (NonNumType t)) -liftNonNumType TypeBool{} = [|| TypeBool ||] -liftNonNumType TypeChar{} = [|| TypeChar ||] - -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 (VectorType n t) = [|| VectorType n $$(liftSingleType t) ||] - - --- Debugging --- ========= showPreAccOp :: forall acc aenv arrs. PreOpenAcc acc aenv arrs -> String -showPreAccOp Alet{} = "Alet" -showPreAccOp (Avar (Var _ ix)) = "Avar a" ++ show (idxToInt ix) -showPreAccOp (Use repr a) = "Use " ++ showShortendArr repr a -showPreAccOp Apply{} = "Apply" -showPreAccOp Aforeign{} = "Aforeign" -showPreAccOp Acond{} = "Acond" -showPreAccOp Awhile{} = "Awhile" -showPreAccOp Apair{} = "Apair" -showPreAccOp Anil = "Anil" -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" - - -showShortendArr :: ArrayR (Array sh e) -> Array sh e -> String -showShortendArr repr@(ArrayR _ tp) arr - | length l > cutoff = "[" ++ elements ++ ", ..]" - | otherwise = "[" ++ elements ++ "]" - where - l = toList repr arr - cutoff = 5 - elements = intercalate ", " $ map (showElement tp) $ take cutoff l - - -showPreExpOp :: forall aenv env t. OpenExp aenv env t -> String -showPreExpOp Let{} = "Let" -showPreExpOp (Evar (Var _ ix)) = "Var x" ++ show (idxToInt ix) -showPreExpOp (Const tp c) = "Const " ++ showElement (TupRsingle tp) c -showPreExpOp Undef{} = "Undef" -showPreExpOp Foreign{} = "Foreign" -showPreExpOp Pair{} = "Pair" -showPreExpOp Nil{} = "Nil" -showPreExpOp VecPack{} = "VecPack" -showPreExpOp VecUnpack{} = "VecUnpack" -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 Coerce{} = "Coerce" +showPreAccOp Alet{} = "Alet" +showPreAccOp (Avar (Var _ ix)) = "Avar a" ++ show (idxToInt ix) +showPreAccOp (Use aR a) = "Use " ++ showArrayShort 5 (showsElt (arrayRtype aR)) aR a +showPreAccOp Apply{} = "Apply" +showPreAccOp Aforeign{} = "Aforeign" +showPreAccOp Acond{} = "Acond" +showPreAccOp Awhile{} = "Awhile" +showPreAccOp Apair{} = "Apair" +showPreAccOp Anil = "Anil" +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" + + +showExpOp :: forall aenv env t. OpenExp aenv env t -> String +showExpOp Let{} = "Let" +showExpOp (Evar (Var _ ix)) = "Var x" ++ show (idxToInt ix) +showExpOp (Const tp c) = "Const " ++ showElt (TupRsingle tp) c +showExpOp Undef{} = "Undef" +showExpOp Foreign{} = "Foreign" +showExpOp Pair{} = "Pair" +showExpOp Nil{} = "Nil" +showExpOp VecPack{} = "VecPack" +showExpOp VecUnpack{} = "VecUnpack" +showExpOp IndexSlice{} = "IndexSlice" +showExpOp IndexFull{} = "IndexFull" +showExpOp ToIndex{} = "ToIndex" +showExpOp FromIndex{} = "FromIndex" +showExpOp Cond{} = "Cond" +showExpOp While{} = "While" +showExpOp PrimConst{} = "PrimConst" +showExpOp PrimApp{} = "PrimApp" +showExpOp Index{} = "Index" +showExpOp LinearIndex{} = "LinearIndex" +showExpOp Shape{} = "Shape" +showExpOp ShapeSize{} = "ShapeSize" +showExpOp Coerce{} = "Coerce" diff --git a/src/Data/Array/Accelerate/AST/Environment.hs b/src/Data/Array/Accelerate/AST/Environment.hs new file mode 100644 index 000000000..3942c5a00 --- /dev/null +++ b/src/Data/Array/Accelerate/AST/Environment.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.AST.Environment +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.AST.Environment + where + +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.Error + + +-- Valuation for an environment +-- +data Val env where + Empty :: Val () + Push :: Val env -> t -> Val (env, t) + +-- Push a set of variables into an environment +-- +push :: Val env -> (LeftHandSide s t env env', t) -> Val env' +push env (LeftHandSideWildcard _, _ ) = env +push env (LeftHandSideSingle _ , a ) = env `Push` a +push env (LeftHandSidePair l1 l2, (a, b)) = push env (l1, a) `push` (l2, b) + +-- 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 + + +-- The type of shifting terms from one context into another +-- +-- This is defined as a newtype, as a type synonym containing a forall +-- quantifier may give issues with impredicative polymorphism, which GHC +-- does not support. +-- +newtype env :> env' = Weaken { (>:>) :: forall t'. Idx env t' -> Idx env' t' } -- Weak or Weaken + +weakenId :: env :> env +weakenId = Weaken id + +weakenSucc' :: env :> env' -> env :> (env', t) +weakenSucc' (Weaken f) = Weaken (SuccIdx . f) + +weakenSucc :: (env, t) :> env' -> env :> env' +weakenSucc (Weaken f) = Weaken (f . SuccIdx) + +weakenEmpty :: () :> env' +weakenEmpty = Weaken $ \case { } + +sink :: forall env env' t. env :> env' -> (env, t) :> (env', t) +sink (Weaken f) = Weaken g + where + g :: Idx (env, t) t' -> Idx (env', t) t' + g ZeroIdx = ZeroIdx + g (SuccIdx ix) = SuccIdx $ f ix + +infixr 9 .> +(.>) :: env2 :> env3 -> env1 :> env2 -> env1 :> env3 +(.>) (Weaken f) (Weaken g) = Weaken (f . g) + +sinkWithLHS :: LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> env1 :> env2 -> env1' :> env2' +sinkWithLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k +sinkWithLHS (LeftHandSideSingle _) (LeftHandSideSingle _) k = sink k +sinkWithLHS (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k = sinkWithLHS b1 b2 $ sinkWithLHS a1 a2 k +sinkWithLHS _ _ _ = $internalError "sinkWithLHS" "left hand sides do not match" + +weakenWithLHS :: forall s t env env'. LeftHandSide s t env env' -> env :> env' +weakenWithLHS = go weakenId + where + go :: env2 :> env' -> LeftHandSide s arrs env1 env2 -> env1 :> env' + go k (LeftHandSideWildcard _) = k + go k (LeftHandSideSingle _) = weakenSucc k + go k (LeftHandSidePair l1 l2) = go (go k l2) l1 + diff --git a/src/Data/Array/Accelerate/AST/Idx.hs b/src/Data/Array/Accelerate/AST/Idx.hs new file mode 100644 index 000000000..2026c05a2 --- /dev/null +++ b/src/Data/Array/Accelerate/AST/Idx.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.AST.Idx +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Typed de Bruijn indices +-- + +module Data.Array.Accelerate.AST.Idx + where + +import Language.Haskell.TH + +-- 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 + +data PairIdx p a where + PairIdxLeft :: PairIdx (a, b) a + PairIdxRight :: PairIdx (a, b) b + + +idxToInt :: Idx env t -> Int +idxToInt ZeroIdx = 0 +idxToInt (SuccIdx idx) = 1 + idxToInt idx + +rnfIdx :: Idx env t -> () +rnfIdx ZeroIdx = () +rnfIdx (SuccIdx ix) = rnfIdx ix + +liftIdx :: Idx env t -> Q (TExp (Idx env t)) +liftIdx ZeroIdx = [|| ZeroIdx ||] +liftIdx (SuccIdx ix) = [|| SuccIdx $$(liftIdx ix) ||] + diff --git a/src/Data/Array/Accelerate/AST/LeftHandSide.hs b/src/Data/Array/Accelerate/AST/LeftHandSide.hs new file mode 100644 index 000000000..3ef297d18 --- /dev/null +++ b/src/Data/Array/Accelerate/AST/LeftHandSide.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.AST.LeftHandSide +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.AST.LeftHandSide + where + +import Data.Array.Accelerate.Representation.Type + +import Language.Haskell.TH + + +data Exists f where + Exists :: f a -> Exists f + +data LeftHandSide s v env env' where + LeftHandSideSingle + :: s v + -> LeftHandSide s v env (env, v) + + LeftHandSideWildcard + :: TupR s v + -> LeftHandSide s v env env + + LeftHandSidePair + :: LeftHandSide s v1 env env' + -> LeftHandSide s v2 env' env'' + -> LeftHandSide s (v1, v2) env env'' + +pattern LeftHandSideUnit + :: () -- required + => (env' ~ env, v ~ ()) -- provided + => LeftHandSide s v env env' +pattern LeftHandSideUnit = LeftHandSideWildcard TupRunit + +lhsToTupR :: LeftHandSide s arrs aenv aenv' -> TupR s arrs +lhsToTupR (LeftHandSideSingle s) = TupRsingle s +lhsToTupR (LeftHandSideWildcard r) = r +lhsToTupR (LeftHandSidePair as bs) = TupRpair (lhsToTupR as) (lhsToTupR bs) + +rnfLeftHandSide :: (forall b. s b -> ()) -> LeftHandSide s arrs env env' -> () +rnfLeftHandSide f (LeftHandSideWildcard r) = rnfTupR f r +rnfLeftHandSide f (LeftHandSideSingle s) = f s +rnfLeftHandSide f (LeftHandSidePair as bs) = rnfLeftHandSide f as `seq` rnfLeftHandSide f bs + +liftLeftHandSide :: (forall u. s u -> Q (TExp (s u))) -> LeftHandSide s v env env' -> Q (TExp (LeftHandSide s v env env')) +liftLeftHandSide f (LeftHandSideSingle s) = [|| LeftHandSideSingle $$(f s) ||] +liftLeftHandSide f (LeftHandSideWildcard r) = [|| LeftHandSideWildcard $$(liftTupR f r) ||] +liftLeftHandSide f (LeftHandSidePair as bs) = [|| LeftHandSidePair $$(liftLeftHandSide f as) $$(liftLeftHandSide f bs) ||] + diff --git a/src/Data/Array/Accelerate/AST/Var.hs b/src/Data/Array/Accelerate/AST/Var.hs new file mode 100644 index 000000000..fc7a07661 --- /dev/null +++ b/src/Data/Array/Accelerate/AST/Var.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.AST.Var +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.AST.Var + where + +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.AST.Idx + +import Language.Haskell.TH + + +data Var s env t = Var (s t) (Idx env t) +type Vars s env = TupR (Var s env) + +varsType :: Vars s env t -> TupR s t +varsType TupRunit = TupRunit +varsType (TupRsingle (Var t _)) = TupRsingle t +varsType (TupRpair a b) = TupRpair (varsType a) (varsType b) + + +rnfVar :: (forall b. s b -> ()) -> Var s env t -> () +rnfVar f (Var t idx) = f t `seq` rnfIdx idx + +rnfVars :: (forall b. s b -> ()) -> Vars s env t -> () +rnfVars f = rnfTupR (rnfVar f) + +liftVar :: (forall b. s b -> Q (TExp (s b))) -> Var s env t -> Q (TExp (Var s env t)) +liftVar f (Var s idx) = [|| Var $$(f s) $$(liftIdx idx) ||] + +liftVars :: (forall b. s b -> Q (TExp (s b))) -> Vars s env t -> Q (TExp (Vars s env t)) +liftVars f = liftTupR (liftVar f) + diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index f1eb6b5e1..48dbb0164 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -36,9 +36,17 @@ module Data.Array.Accelerate.Analysis.Hash ( ) where import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.AST.LeftHandSide import Data.Array.Accelerate.Analysis.Hash.TH -import Data.Array.Accelerate.Array.Representation +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Slice +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type +import Data.Primitive.Vec import Crypto.Hash import Data.ByteString.Builder @@ -91,11 +99,11 @@ defaultHashOptions = HashOptions True {-# INLINEABLE hashPreOpenAcc #-} -hashPreOpenAcc :: HasArraysRepr acc => EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash +hashPreOpenAcc :: HasArraysR acc => EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash hashPreOpenAcc = hashPreOpenAccWith defaultHashOptions {-# INLINEABLE hashPreOpenAccWith #-} -hashPreOpenAccWith :: HasArraysRepr acc => HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash +hashPreOpenAccWith :: HasArraysR acc => HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv a -> Hash hashPreOpenAccWith options encodeAcc = hashlazy . toLazyByteString @@ -123,7 +131,7 @@ type EncodeAcc acc = forall aenv a. HashOptions -> acc aenv a -> Builder {-# INLINEABLE encodePreOpenAcc #-} encodePreOpenAcc - :: forall acc aenv arrs. HasArraysRepr acc + :: forall acc aenv arrs. HasArraysR acc => HashOptions -> EncodeAcc acc -> PreOpenAcc acc aenv arrs @@ -149,7 +157,7 @@ encodePreOpenAcc options encodeAcc pacc = deepE :: forall env' aenv' e. OpenExp env' aenv' e -> Builder deepE e | perfect options = travE e - | otherwise = encodeTupleType $ expType e + | otherwise = encodeTypeR $ expType e in case pacc of Alet lhs bnd body -> intHost $(hashQ "Alet") <> encodeLeftHandSide encodeArrayType lhs <> travA bnd <> travA body @@ -183,8 +191,8 @@ encodePreOpenAcc options encodeAcc pacc = Scanr' f e a -> intHost $(hashQ "Scanr'") <> travF f <> travE e <> travA a Scanr1 f a -> intHost $(hashQ "Scanr1") <> travF f <> travA a Permute f1 a1 f2 a2 -> intHost $(hashQ "Permute") <> travF f1 <> travA a1 <> travF f2 <> travA a2 - Stencil s _ f b a -> intHost $(hashQ "Stencil") <> travF f <> encodeBoundary (stencilElt s) b <> travA a - Stencil2 s1 s2 _ f b1 a1 b2 a2 -> intHost $(hashQ "Stencil2") <> travF f <> encodeBoundary (stencilElt s1) b1 <> travA a1 <> encodeBoundary (stencilElt s2) b2 <> travA a2 + Stencil s _ f b a -> intHost $(hashQ "Stencil") <> travF f <> encodeBoundary (stencilEltR s) b <> travA a + Stencil2 s1 s2 _ f b1 a1 b2 a2 -> intHost $(hashQ "Stencil2") <> travF f <> encodeBoundary (stencilEltR s1) b1 <> travA a1 <> encodeBoundary (stencilEltR s2) b2 <> travA a2 {-- {-# INLINEABLE encodePreOpenSeq #-} @@ -249,7 +257,7 @@ encodeLeftHandSide f (LeftHandSidePair r1 r2) = intHost $(hashQ "LeftHandSidePai encodeLeftHandSide f (LeftHandSideSingle s) = intHost $(hashQ "LeftHandSideArray") <> f s encodeArrayType :: ArrayR a -> Builder -encodeArrayType (ArrayR shr tp) = encodeShapeR shr <> encodeTupleType tp +encodeArrayType (ArrayR shr tp) = encodeShapeR shr <> encodeTypeR tp encodeArraysType :: ArraysR arrs -> Builder encodeArraysType = encodeTupR encodeArrayType @@ -274,7 +282,7 @@ encodePreOpenAfun options travA afun = encodeBoundary - :: TupleType e + :: TypeR e -> Boundary aenv (Array sh e) -> Builder encodeBoundary _ Wrap = intHost $(hashQ "Wrap") @@ -340,7 +348,7 @@ encodeOpenFun (Body b) = intHost $(hashQ "Body") <> encodeOpenExp b encodeOpenFun (Lam lhs l) = intHost $(hashQ "Lam") <> encodeLeftHandSide encodeScalarType lhs <> encodeOpenFun l -encodeConst :: TupleType t -> t -> Builder +encodeConst :: TypeR t -> t -> Builder encodeConst TupRunit () = intHost $(hashQ "nil") encodeConst (TupRsingle t) c = encodeScalarConst t c encodeConst (TupRpair ta tb) (a,b) = intHost $(hashQ "pair") <> encodeConst ta a <> encodeConst tb b @@ -458,13 +466,13 @@ encodePrimFun PrimChr = intHost $(hashQ "PrimChr") encodePrimFun PrimBoolToInt = intHost $(hashQ "PrimBoolToInt") -encodeTupleType :: TupleType t -> Builder -encodeTupleType TupRunit = intHost $(hashQ "TupRunit") -encodeTupleType (TupRsingle t) = intHost $(hashQ "TupRsingle") <> encodeScalarType t -encodeTupleType (TupRpair a b) = intHost $(hashQ "TupRpair") <> encodeTupleType a <> intHost (depthTypeR a) - <> encodeTupleType b <> intHost (depthTypeR b) +encodeTypeR :: TypeR t -> Builder +encodeTypeR TupRunit = intHost $(hashQ "TupRunit") +encodeTypeR (TupRsingle t) = intHost $(hashQ "TupRsingle") <> encodeScalarType t +encodeTypeR (TupRpair a b) = intHost $(hashQ "TupRpair") <> encodeTypeR a <> intHost (depthTypeR a) + <> encodeTypeR b <> intHost (depthTypeR b) -depthTypeR :: TupleType t -> Int +depthTypeR :: TypeR t -> Int depthTypeR TupRunit = 0 depthTypeR TupRsingle{} = 1 depthTypeR (TupRpair a b) = depthTypeR a + depthTypeR b diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index d88c27b2f..5a6ddde59 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -29,13 +29,26 @@ module Data.Array.Accelerate.Analysis.Match ( matchPrimFun, matchPrimFun', -- auxiliary - matchIdx, matchVar, matchVars, matchArrayR, matchArraysR, matchTupleType, matchShapeR, + matchIdx, matchVar, matchVars, matchArrayR, matchArraysR, matchTypeR, matchShapeR, matchShapeType, matchIntegralType, matchFloatingType, matchNumType, matchScalarType, matchLeftHandSide, matchALeftHandSide, matchELeftHandSide, matchSingleType, matchTupR ) where --- standard library +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Analysis.Hash +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Slice +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type +import Data.Primitive.Vec +import qualified Data.Array.Accelerate.Sugar.Shape as Sugar + import Data.Maybe import Data.Typeable import Unsafe.Coerce ( unsafeCoerce ) @@ -43,13 +56,6 @@ 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 -import Data.Array.Accelerate.Type -import qualified Data.Array.Accelerate.Array.Sugar as Sugar - -- The type of matching array computations -- @@ -61,7 +67,7 @@ type MatchAcc acc = forall aenv s t. acc aenv s -> acc aenv t -> Maybe (s :~: t) -- {-# INLINEABLE matchPreOpenAcc #-} matchPreOpenAcc - :: forall acc aenv s t. HasArraysRepr acc + :: forall acc aenv s t. HasArraysR acc => MatchAcc acc -> PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t @@ -123,7 +129,7 @@ matchPreOpenAcc matchAcc = match = Just Refl match (Unit t1 e1) (Unit t2 e2) - | Just Refl <- matchTupleType t1 t2 + | Just Refl <- matchTypeR t1 t2 , Just Refl <- matchExp e1 e2 = Just Refl @@ -241,15 +247,15 @@ matchPreOpenAcc matchAcc = match match (Stencil s1 _ f1 b1 a1) (Stencil _ _ f2 b2 a2) | Just Refl <- matchFun f1 f2 , Just Refl <- matchAcc a1 a2 - , matchBoundary (stencilElt s1) b1 b2 + , matchBoundary (stencilEltR s1) b1 b2 = Just Refl match (Stencil2 s1 s2 _ 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 (stencilElt s1) b1 b1' - , matchBoundary (stencilElt s2) b2 b2' + , matchBoundary (stencilEltR s1) b1 b1' + , matchBoundary (stencilEltR s2) b2 b2' = Just Refl -- match (Collect s1) (Collect s2) @@ -309,7 +315,7 @@ matchLeftHandSide _ _ _ = Nothing -- Match stencil boundaries -- matchBoundary - :: TupleType t + :: TypeR t -> Boundary aenv (Array sh t) -> Boundary aenv (Array sh t) -> Bool @@ -437,7 +443,7 @@ matchArraysR = matchTupR matchArrayR matchArrayR :: ArrayR s -> ArrayR t -> Maybe (s :~: t) matchArrayR (ArrayR shr1 tp1) (ArrayR shr2 tp2) | Just Refl <- matchShapeR shr1 shr2 - , Just Refl <- matchTupleType tp1 tp2 = Just Refl + , Just Refl <- matchTypeR tp1 tp2 = Just Refl matchArrayR _ _ = Nothing @@ -544,7 +550,7 @@ matchOpenExp (PrimApp f1 x1) (PrimApp f2 x2) = Just Refl matchOpenExp (Index a1 x1) (Index a2 x2) - | Just Refl <- matchVar a1 a2 -- should only be array indices + | Just Refl <- matchVar a1 a2 , Just Refl <- matchOpenExp x1 x2 = Just Refl @@ -554,7 +560,7 @@ matchOpenExp (LinearIndex a1 x1) (LinearIndex a2 x2) = Just Refl matchOpenExp (Shape a1) (Shape a2) - | Just Refl <- matchVar a1 a2 -- should only be array indices + | Just Refl <- matchVar a1 a2 = Just Refl matchOpenExp (ShapeSize _ sh1) (ShapeSize _ sh2) @@ -582,7 +588,7 @@ matchOpenFun _ _ = Nothing -- Matching constants -- -matchConst :: TupleType a -> a -> a -> Bool +matchConst :: TypeR a -> a -> a -> Bool matchConst TupRunit () () = True matchConst (TupRsingle ty) a b = evalEq ty (a,b) matchConst (TupRpair ta tb) (a1,b1) (a2,b2) = matchConst ta a1 a2 && matchConst tb b1 b2 @@ -617,10 +623,10 @@ matchVar (Var _ v1) (Var _ v2) = matchIdx v1 v2 {-# INLINEABLE matchVars #-} matchVars :: Vars s env t1 -> Vars s env t2 -> Maybe (t1 :~: t2) -matchVars VarsNil VarsNil = Just Refl -matchVars (VarsSingle v1) (VarsSingle v2) +matchVars TupRunit TupRunit = Just Refl +matchVars (TupRsingle v1) (TupRsingle v2) | Just Refl <- matchVar v1 v2 = Just Refl -matchVars (VarsPair v w) (VarsPair x y) +matchVars (TupRpair v w) (TupRpair x y) | Just Refl <- matchVars v x , Just Refl <- matchVars w y = Just Refl matchVars _ _ = Nothing @@ -820,9 +826,9 @@ matchPrimFun' _ _ -- Match reified types -- -{-# INLINEABLE matchTupleType #-} -matchTupleType :: TupleType s -> TupleType t -> Maybe (s :~: t) -matchTupleType = matchTupR matchScalarType +{-# INLINEABLE matchTypeR #-} +matchTypeR :: TypeR s -> TypeR t -> Maybe (s :~: t) +matchTypeR = matchTupR matchScalarType -- Match shapes (dimensionality) @@ -849,7 +855,8 @@ matchShapeType matchShapeR :: forall s t. ShapeR s -> ShapeR t -> Maybe (s :~: t) matchShapeR ShapeRz ShapeRz = Just Refl matchShapeR (ShapeRsnoc shr1) (ShapeRsnoc shr2) - | Just Refl <- matchShapeR shr1 shr2 = Just Refl + | Just Refl <- matchShapeR shr1 shr2 + = Just Refl matchShapeR _ _ = Nothing diff --git a/src/Data/Array/Accelerate/Analysis/Shape.hs b/src/Data/Array/Accelerate/Analysis/Shape.hs index 416e77389..a620511d5 100644 --- a/src/Data/Array/Accelerate/Analysis/Shape.hs +++ b/src/Data/Array/Accelerate/Analysis/Shape.hs @@ -23,19 +23,22 @@ module Data.Array.Accelerate.Analysis.Shape ( ) where import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Array.Representation +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type --- |Reify the dimensionality of the result type of an array computation + +-- | Reify the dimensionality of the result type of an array computation -- -accDim :: forall acc aenv sh e. HasArraysRepr acc => acc aenv (Array sh e) -> Int -accDim = rank . arrayRshape . arrayRepr +accDim :: forall acc aenv sh e. HasArraysR acc => acc aenv (Array sh e) -> Int +accDim = rank . arrayRshape . arrayR --- |Reify dimensionality of a scalar expression yielding a shape +-- | Reify dimensionality of a scalar expression yielding a shape -- expDim :: forall env aenv sh. OpenExp env aenv sh -> Int expDim = ndim . expType --- Count the number of components to a tuple type +-- | Count the number of components to a tuple type -- ndim :: TupR s a -> Int ndim TupRunit = 0 diff --git a/src/Data/Array/Accelerate/Analysis/Stencil.hs b/src/Data/Array/Accelerate/Analysis/Stencil.hs index cc9f05c13..5e230d251 100644 --- a/src/Data/Array/Accelerate/Analysis/Stencil.hs +++ b/src/Data/Array/Accelerate/Analysis/Stencil.hs @@ -16,14 +16,14 @@ module Data.Array.Accelerate.Analysis.Stencil ( positionsR ) where -import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Array.Representation +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Stencil --- |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. +-- | 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. -- positionsR :: StencilR sh e pat -> [sh] positionsR StencilRunit3{} = map ((), ) [ -1, 0, 1 ] @@ -36,7 +36,7 @@ positionsR (StencilRtup3 c b a) = concat , map (innermost shr (, 0)) $ positionsR b , map (innermost shr (, 1)) $ positionsR a ] where - shr = stencilShape a + shr = stencilShapeR a positionsR (StencilRtup5 e d c b a) = concat [ map (innermost shr (, -2)) $ positionsR e @@ -45,7 +45,7 @@ positionsR (StencilRtup5 e d c b a) = concat , map (innermost shr (, 1)) $ positionsR b , map (innermost shr (, 2)) $ positionsR a ] where - shr = stencilShape a + shr = stencilShapeR a positionsR (StencilRtup7 g f e d c b a) = concat [ map (innermost shr (, -3)) $ positionsR g @@ -56,7 +56,7 @@ positionsR (StencilRtup7 g f e d c b a) = concat , map (innermost shr (, 2)) $ positionsR b , map (innermost shr (, 3)) $ positionsR a ] where - shr = stencilShape a + shr = stencilShapeR a positionsR (StencilRtup9 i h g f e d c b a) = concat [ map (innermost shr (, -4)) $ positionsR i @@ -69,7 +69,7 @@ positionsR (StencilRtup9 i h g f e d c b a) = concat , map (innermost shr (, 3)) $ positionsR b , map (innermost shr (, 4)) $ positionsR a ] where - shr = stencilShape a + shr = stencilShapeR a -- Inject a dimension component inner-most diff --git a/src/Data/Array/Accelerate/Analysis/Type.hs b/src/Data/Array/Accelerate/Analysis/Type.hs index 677dc71dc..bf7435197 100644 --- a/src/Data/Array/Accelerate/Analysis/Type.hs +++ b/src/Data/Array/Accelerate/Analysis/Type.hs @@ -35,25 +35,24 @@ module Data.Array.Accelerate.Analysis.Type ( ) where --- friends import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Array.Representation +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type --- standard library import qualified Foreign.Storable as F -- |Determine the type of an expressions -- ------------------------------------- -accType :: forall acc aenv sh e. HasArraysRepr acc => acc aenv (Array sh e) -> TupleType e -accType = arrayRtype . arrayRepr +accType :: forall acc aenv sh e. HasArraysR acc => acc aenv (Array sh e) -> TypeR e +accType = arrayRtype . arrayR --- |Size of a tuple type, in bytes +-- | Size of a tuple type, in bytes -- -sizeOf :: TupleType a -> Int +sizeOf :: TypeR a -> Int sizeOf TupRunit = 0 sizeOf (TupRpair a b) = sizeOf a + sizeOf b sizeOf (TupRsingle t) = sizeOfScalarType t diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 398ab2c67..edb009693 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -1,17 +1,11 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Data @@ -31,8 +25,13 @@ module Data.Array.Accelerate.Array.Data ( -- * Array operations and representations - ArrayData, MutableArrayData, runArrayData, GArrayData, rnfArrayData, ScalarData, ScalarDataRepr, - unsafeIndexArrayData, ptrOfArrayData, touchArrayData, newArrayData, unsafeReadArrayData, unsafeWriteArrayData, + ArrayData, MutableArrayData, GArrayData, ScalarArrayData, ScalarArrayDataR, + runArrayData, + newArrayData, + indexArrayData, readArrayData, writeArrayData, + unsafeArrayDataPtr, + touchArrayData, + rnfArrayData, -- * Type macros HTYPE_INT, HTYPE_WORD, HTYPE_CLONG, HTYPE_CULONG, HTYPE_CCHAR, @@ -41,24 +40,30 @@ module Data.Array.Accelerate.Array.Data ( registerForeignPtrAllocator, -- * Utilities for type classes - ScalarDict(..), scalarDict, singleDict, IsScalarData + ScalarArrayDict(..), scalarArrayDict, + SingleArrayDict(..), singleArrayDict, + + -- * TemplateHaskell + liftArrayData, ) where -- friends import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Error -import Data.Array.Accelerate.Orphans () -- Prim Half import Data.Array.Accelerate.Type +import Data.Primitive.Vec 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 Control.DeepSeq +import Control.Monad ( (<=<) ) import Data.Bits import Data.IORef import Data.Primitive ( sizeOf# ) @@ -72,44 +77,8 @@ import Prelude hiding ( map import GHC.Base import GHC.ForeignPtr import GHC.Ptr -import Data.Primitive.Types ( Prim ) - - --- 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_CLONG = $( - case finiteBitSize (undefined::CLong) of - 32 -> [t| Int32 |] - 64 -> [t| Int64 |] - _ -> error "I don't know what architecture I am" ) |] ) - -$( runQ [d| type HTYPE_CULONG = $( - 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 @@ -118,158 +87,219 @@ type ArrayData e = MutableArrayData e -- type MutableArrayData e = GArrayData e --- Underlying array representation. +-- | Underlying array representation. -- -- In previous versions this was abstracted over by the mutable/immutable array -- representation, but this is now fixed to our UniqueArray type. -- +-- NOTE: We use a standard (non-strict) pair to enable lazy device-host data transfers +-- type family GArrayData a where GArrayData () = () - GArrayData (a, b) = (GArrayData a, GArrayData b) -- XXX: fields of tuple are non-strict, which enables lazy device-host copying - GArrayData a = ScalarData a - -type ScalarData a = UniqueArray (ScalarDataRepr a) - --- Mapping from scalar type to the type as represented in memory in an array. --- Booleans are stored as Word8, other types are represented as itself. -type family ScalarDataRepr tp where - ScalarDataRepr Int = Int - ScalarDataRepr Int8 = Int8 - ScalarDataRepr Int16 = Int16 - ScalarDataRepr Int32 = Int32 - ScalarDataRepr Int64 = Int64 - ScalarDataRepr Word = Word - ScalarDataRepr Word8 = Word8 - ScalarDataRepr Word16 = Word16 - ScalarDataRepr Word32 = Word32 - ScalarDataRepr Word64 = Word64 - ScalarDataRepr Half = Half - ScalarDataRepr Float = Float - ScalarDataRepr Double = Double - ScalarDataRepr Bool = Word8 - ScalarDataRepr Char = Char - ScalarDataRepr (Vec n tp) = ScalarDataRepr tp - --- Utilities for working with the type families & type class instances -data ScalarDict e where - ScalarDict :: IsScalarData e => ScalarDict e - -type IsScalarData e = (Storable (ScalarDataRepr e), Prim (ScalarDataRepr e), ArrayData e ~ ScalarData e) - -{-# INLINE scalarDict #-} -scalarDict :: ScalarType e -> (Int, ScalarDict e) -scalarDict (SingleScalarType tp) - | (dict, _, _) <- singleDict tp = (1, dict) -scalarDict (VectorScalarType (VectorType n tp)) - | (ScalarDict, _, _) <- singleDict tp = (n, ScalarDict) - -{-# INLINE singleDict #-} -singleDict :: SingleType e -> (ScalarDict e, e -> ScalarDataRepr e, ScalarDataRepr e -> e) -singleDict (NonNumSingleType TypeBool) = (ScalarDict, fromBool, toBool) -singleDict (NonNumSingleType TypeChar) = (ScalarDict, id, id) -singleDict (NumSingleType (IntegralNumType tp)) = case tp of - TypeInt -> (ScalarDict, id, id) - TypeInt8 -> (ScalarDict, id, id) - TypeInt16 -> (ScalarDict, id, id) - TypeInt32 -> (ScalarDict, id, id) - TypeInt64 -> (ScalarDict, id, id) - TypeWord -> (ScalarDict, id, id) - TypeWord8 -> (ScalarDict, id, id) - TypeWord16 -> (ScalarDict, id, id) - TypeWord32 -> (ScalarDict, id, id) - TypeWord64 -> (ScalarDict, id, id) -singleDict (NumSingleType (FloatingNumType tp)) = case tp of - TypeHalf -> (ScalarDict, id, id) - TypeFloat -> (ScalarDict, id, id) - TypeDouble -> (ScalarDict, id, id) + GArrayData (a, b) = (GArrayData a, GArrayData b) + GArrayData a = ScalarArrayData a + +type ScalarArrayData a = UniqueArray (ScalarArrayDataR a) + +-- | Mapping from scalar type to the type as represented in memory in an +-- array. Booleans are stored as Word8, other types are represented as +-- itself. +-- +type family ScalarArrayDataR t where + ScalarArrayDataR Int = Int + ScalarArrayDataR Int8 = Int8 + ScalarArrayDataR Int16 = Int16 + ScalarArrayDataR Int32 = Int32 + ScalarArrayDataR Int64 = Int64 + ScalarArrayDataR Word = Word + ScalarArrayDataR Word8 = Word8 + ScalarArrayDataR Word16 = Word16 + ScalarArrayDataR Word32 = Word32 + ScalarArrayDataR Word64 = Word64 + ScalarArrayDataR Half = Half + ScalarArrayDataR Float = Float + ScalarArrayDataR Double = Double + -- ScalarArrayDataR Bool = Word8 + ScalarArrayDataR Char = Char + ScalarArrayDataR (Vec n t) = ScalarArrayDataR t + + +data ScalarArrayDict a where + ScalarArrayDict :: ( GArrayData a ~ ScalarArrayData a ) + => ScalarArrayDict a + +data SingleArrayDict a where + SingleArrayDict :: ( GArrayData a ~ ScalarArrayData a, ScalarArrayDataR a ~ a ) + => SingleArrayDict a + +scalarArrayDict :: ScalarType a -> ScalarArrayDict a +scalarArrayDict = scalar + where + scalar :: ScalarType a -> ScalarArrayDict a + scalar (SingleScalarType t) = single t + scalar (VectorScalarType t) = vector t + + single :: SingleType a -> ScalarArrayDict a + single (NumSingleType t) = num t + single (NonNumSingleType t) = nonnum t + + vector :: VectorType a -> ScalarArrayDict a + vector (VectorType _ s) + | ScalarArrayDict <- single s + = ScalarArrayDict + + nonnum :: NonNumType a -> ScalarArrayDict a + nonnum TypeChar = ScalarArrayDict + nonnum TypeBool = undefined + + num :: NumType a -> ScalarArrayDict a + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + integral :: IntegralType a -> ScalarArrayDict a + integral TypeInt = ScalarArrayDict + integral TypeInt8 = ScalarArrayDict + integral TypeInt16 = ScalarArrayDict + integral TypeInt32 = ScalarArrayDict + integral TypeInt64 = ScalarArrayDict + integral TypeWord = ScalarArrayDict + integral TypeWord8 = ScalarArrayDict + integral TypeWord16 = ScalarArrayDict + integral TypeWord32 = ScalarArrayDict + integral TypeWord64 = ScalarArrayDict + + floating :: FloatingType a -> ScalarArrayDict a + floating TypeHalf = ScalarArrayDict + floating TypeFloat = ScalarArrayDict + floating TypeDouble = ScalarArrayDict + + +singleArrayDict :: SingleType a -> SingleArrayDict a +singleArrayDict = single + where + single :: SingleType a -> SingleArrayDict a + single (NumSingleType t) = num t + single (NonNumSingleType t) = nonnum t + + nonnum :: NonNumType a -> SingleArrayDict a + nonnum TypeChar = SingleArrayDict + nonnum TypeBool = undefined + + num :: NumType a -> SingleArrayDict a + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + integral :: IntegralType a -> SingleArrayDict a + integral TypeInt = SingleArrayDict + integral TypeInt8 = SingleArrayDict + integral TypeInt16 = SingleArrayDict + integral TypeInt32 = SingleArrayDict + integral TypeInt64 = SingleArrayDict + integral TypeWord = SingleArrayDict + integral TypeWord8 = SingleArrayDict + integral TypeWord16 = SingleArrayDict + integral TypeWord32 = SingleArrayDict + integral TypeWord64 = SingleArrayDict + + floating :: FloatingType a -> SingleArrayDict a + floating TypeHalf = SingleArrayDict + floating TypeFloat = SingleArrayDict + floating TypeDouble = SingleArrayDict + -- Array operations -- ---------------- --- Reads an element from an array -unsafeIndexArrayData :: TupleType e -> ArrayData e -> Int -> e -unsafeIndexArrayData TupRunit () !_ = () -unsafeIndexArrayData (TupRpair t1 t2) (a1, a2) !ix = (unsafeIndexArrayData t1 a1 ix, unsafeIndexArrayData t2 a2 ix) -unsafeIndexArrayData (TupRsingle (SingleScalarType tp)) arr ix - | (ScalarDict, _, to) <- singleDict tp = to $! unsafeIndexArray arr ix --- VectorScalarType is handled in unsafeReadArrayData -unsafeIndexArrayData !tp !arr !ix = unsafePerformIO $! unsafeReadArrayData tp arr ix - -ptrOfArrayData :: ScalarType e -> ArrayData e -> Ptr (ScalarDataRepr e) -ptrOfArrayData tp arr - | (_, ScalarDict) <- scalarDict tp = unsafeUniqueArrayPtr arr - -touchArrayData :: TupleType e -> ArrayData e -> IO () -touchArrayData TupRunit () = return () -touchArrayData (TupRpair t1 t2) (a1, a2) = touchArrayData t1 a1 >> touchArrayData t2 a2 -touchArrayData (TupRsingle tp) arr - | (_, ScalarDict) <- scalarDict tp = touchUniqueArray arr - -newArrayData :: TupleType e -> Int -> IO (MutableArrayData e) +newArrayData :: TupR ScalarType e -> Int -> IO (MutableArrayData e) newArrayData TupRunit !_ = return () newArrayData (TupRpair t1 t2) !size = (,) <$> newArrayData t1 size <*> newArrayData t2 size -newArrayData (TupRsingle tp) !size - | (n, ScalarDict) <- scalarDict tp = newArrayData' (n * size) - -unsafeReadArrayData :: forall e. TupleType e -> MutableArrayData e -> Int -> IO e -unsafeReadArrayData TupRunit () !_ = return () -unsafeReadArrayData (TupRpair t1 t2) (a1, a2) !ix = (,) <$> unsafeReadArrayData t1 a1 ix <*> unsafeReadArrayData t2 a2 ix -unsafeReadArrayData (TupRsingle (SingleScalarType tp)) arr !ix - | (ScalarDict, _, to) <- singleDict tp = to <$> unsafeReadArray arr ix -unsafeReadArrayData (TupRsingle (VectorScalarType (VectorType (I# w#) tp))) arr (I# ix#) - | (ScalarDict, _, _) <- singleDict tp = - let - !bytes# = w# *# sizeOf# (undefined :: ScalarDataRepr e) - !addr# = unPtr# (unsafeUniqueArrayPtr arr) `plusAddr#` (ix# *# bytes#) - in - IO $ \s -> - case newByteArray# bytes# s of { (# s1, mba# #) -> - case copyAddrToByteArray# addr# mba# 0# bytes# s1 of { s2 -> - case unsafeFreezeByteArray# mba# s2 of { (# s3, ba# #) -> - (# s3, Vec ba# #) - }}} - -unsafeWriteArrayData :: forall e. TupleType e -> MutableArrayData e -> Int -> e -> IO () -unsafeWriteArrayData TupRunit () !_ () = return () -unsafeWriteArrayData (TupRpair t1 t2) (a1, a2) !ix (v1, v2) - = unsafeWriteArrayData t1 a1 ix v1 - >> unsafeWriteArrayData t2 a2 ix v2 -unsafeWriteArrayData (TupRsingle (SingleScalarType tp)) arr !ix !val - | (ScalarDict, from, _) <- singleDict tp = unsafeWriteArray arr ix (from val) -unsafeWriteArrayData (TupRsingle (VectorScalarType (VectorType (I# w#) tp))) arr (I# ix#) (Vec ba# :: Vec n t) - | (ScalarDict, _, _) <- singleDict tp = - let - !bytes# = w# *# sizeOf# (undefined :: ScalarDataRepr e) - !addr# = unPtr# (unsafeUniqueArrayPtr arr) `plusAddr#` (ix# *# bytes#) - in - IO $ \s -> case copyByteArrayToAddr# ba# 0# addr# bytes# s of - s1 -> (# s1, () #) - -rnfArrayData :: TupleType e -> ArrayData e -> () -rnfArrayData TupRunit () = () -rnfArrayData (TupRpair t1 t2) (a1, a2) = rnfArrayData t1 a1 `seq` rnfArrayData t2 a2 -rnfArrayData (TupRsingle tp) arr = rnf $ ptrOfArrayData tp arr +newArrayData (TupRsingle t) !size + | SingleScalarType s <- t + , SingleDict <- singleDict s + , SingleArrayDict <- singleArrayDict s + = allocateArray size + -- + | VectorScalarType v <- t + , VectorType w s <- v + , SingleDict <- singleDict s + , SingleArrayDict <- singleArrayDict s + = allocateArray (w * size) + +indexArrayData :: TupR ScalarType e -> ArrayData e -> Int -> e +indexArrayData tR arr ix = unsafePerformIO $ readArrayData tR arr ix + +readArrayData :: forall e. TupR ScalarType e -> MutableArrayData e -> Int -> IO e +readArrayData TupRunit () !_ = return () +readArrayData (TupRpair t1 t2) (a1, a2) !ix = (,) <$> readArrayData t1 a1 ix <*> readArrayData t2 a2 ix +readArrayData (TupRsingle t) arr !ix + | SingleScalarType s <- t + , SingleDict <- singleDict s + , SingleArrayDict <- singleArrayDict s + = unsafeReadArray arr ix + -- + | VectorScalarType v <- t + , VectorType w s <- v + , I# w# <- w + , I# ix# <- ix + , SingleDict <- singleDict s + , SingleArrayDict <- singleArrayDict s + = let + !bytes# = w# *# sizeOf# (undefined :: ScalarArrayDataR e) + !addr# = unPtr# (unsafeUniqueArrayPtr arr) `plusAddr#` (ix# *# bytes#) + in + IO $ \s0 -> + case newByteArray# bytes# s0 of { (# s1, mba# #) -> + case copyAddrToByteArray# addr# mba# 0# bytes# s1 of { s2 -> + case unsafeFreezeByteArray# mba# s2 of { (# s3, ba# #) -> + (# s3, Vec ba# #) + }}} + +writeArrayData :: forall e. TupR ScalarType e -> MutableArrayData e -> Int -> e -> IO () +writeArrayData TupRunit () !_ () = return () +writeArrayData (TupRpair t1 t2) (a1, a2) !ix (v1, v2) = writeArrayData t1 a1 ix v1 >> writeArrayData t2 a2 ix v2 +writeArrayData (TupRsingle t) arr !ix !val + | SingleScalarType s <- t + , SingleDict <- singleDict s + , SingleArrayDict <- singleArrayDict s + = unsafeWriteArray arr ix val + -- + | VectorScalarType v <- t + , VectorType w s <- v + , Vec ba# <- val + , I# w# <- w + , I# ix# <- ix + , SingleDict <- singleDict s + , SingleArrayDict <- singleArrayDict s + = let + !bytes# = w# *# sizeOf# (undefined :: ScalarArrayDataR e) + !addr# = unPtr# (unsafeUniqueArrayPtr arr) `plusAddr#` (ix# *# bytes#) + in + IO $ \s0 -> case copyByteArrayToAddr# ba# 0# addr# bytes# s0 of + s1 -> (# s1, () #) + + +unsafeArrayDataPtr :: ScalarType e -> ArrayData e -> Ptr (ScalarArrayDataR e) +unsafeArrayDataPtr t arr + | ScalarArrayDict <- scalarArrayDict t + = unsafeUniqueArrayPtr arr + +touchArrayData :: TupR ScalarType e -> ArrayData e -> IO () +touchArrayData TupRunit () = return () +touchArrayData (TupRpair t1 t2) (a1, a2) = touchArrayData t1 a1 >> touchArrayData t2 a2 +touchArrayData (TupRsingle t) arr + | ScalarArrayDict <- scalarArrayDict t + = touchUniqueArray arr --- Auxiliary functions --- ------------------- +rnfArrayData :: TupR ScalarType e -> ArrayData e -> () +rnfArrayData TupRunit () = () +rnfArrayData (TupRpair t1 t2) (a1, a2) = rnfArrayData t1 a1 `seq` rnfArrayData t2 a2 `seq` () +rnfArrayData (TupRsingle t) arr = rnf (unsafeArrayDataPtr t arr) -{-# INLINE unPtr# #-} unPtr# :: Ptr a -> Addr# unPtr# (Ptr addr#) = addr# -{-# 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) @@ -277,30 +307,6 @@ 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. -- @@ -309,9 +315,8 @@ unsafeWriteArray !ua !i !e = -- 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 +allocateArray :: forall e. Storable e => Int -> IO (UniqueArray e) +allocateArray !size = $internalCheck "newArrayData" "size must be >= 0" (size >= 0) $ newUniqueArray <=< unsafeInterleaveIO $ do let bytes = size * sizeOf (undefined :: e) @@ -345,9 +350,85 @@ __mallocForeignPtrBytes = unsafePerformIO $! newIORef mallocPlainForeignPtrBytes -- 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 64# s of (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (PlainPtr mbarr#) #) + +liftArrayData :: Int -> TypeR e -> ArrayData e -> Q (TExp (ArrayData e)) +liftArrayData n = tuple + where + tuple :: TypeR e -> ArrayData e -> Q (TExp (ArrayData e)) + tuple TupRunit () = [|| () ||] + tuple (TupRpair t1 t2) (a1, a2) = [|| ($$(tuple t1 a1), $$(tuple t2 a2)) ||] + tuple (TupRsingle s) adata = scalar s adata + + scalar :: ScalarType e -> ArrayData e -> Q (TExp (ArrayData e)) + scalar (SingleScalarType t) = single t + scalar (VectorScalarType t) = vector t + + vector :: forall n e. VectorType (Vec n e) -> ArrayData (Vec n e) -> Q (TExp (ArrayData (Vec n e))) + vector (VectorType w t) + | SingleArrayDict <- singleArrayDict t + = liftArrayData (w * n) (TupRsingle (SingleScalarType t)) + + single :: SingleType e -> ArrayData e -> Q (TExp (ArrayData e)) + single (NumSingleType t) = num t + single (NonNumSingleType t) = nonnum t + + num :: NumType e -> ArrayData e -> Q (TExp (ArrayData e)) + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + nonnum :: NonNumType e -> ArrayData e -> Q (TExp (ArrayData e)) + nonnum = undefined + + integral :: IntegralType e -> ArrayData e -> Q (TExp (ArrayData e)) + integral TypeInt = liftUniqueArray n + integral TypeInt8 = liftUniqueArray n + integral TypeInt16 = liftUniqueArray n + integral TypeInt32 = liftUniqueArray n + integral TypeInt64 = liftUniqueArray n + integral TypeWord = liftUniqueArray n + integral TypeWord8 = liftUniqueArray n + integral TypeWord16 = liftUniqueArray n + integral TypeWord32 = liftUniqueArray n + integral TypeWord64 = liftUniqueArray n + + floating :: FloatingType e -> ArrayData e -> Q (TExp (ArrayData e)) + floating TypeHalf = liftUniqueArray n + floating TypeFloat = liftUniqueArray n + floating TypeDouble = liftUniqueArray n + +-- 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_CLONG = $( + case finiteBitSize (undefined::CLong) of + 32 -> [t| Int32 |] + 64 -> [t| Int64 |] + _ -> error "I don't know what architecture I am" ) |] + +runQ [d| type HTYPE_CULONG = $( + 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 = $( + if isSigned (undefined::CChar) + then [t| Int8 |] + else [t| Word8 |] ) |] + diff --git a/src/Data/Array/Accelerate/Array/Remote/Class.hs b/src/Data/Array/Accelerate/Array/Remote/Class.hs index a09236399..522e51b5a 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Class.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Class.hs @@ -32,13 +32,11 @@ module Data.Array.Accelerate.Array.Remote.Class ( ) where import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Type (SingleType) +import Data.Array.Accelerate.Type import Control.Applicative import Control.Monad.Catch -import Data.Int import Data.Kind -import Data.Word import Prelude @@ -56,10 +54,10 @@ class (Applicative m, Monad m, MonadCatch m, MonadMask m) => RemoteMemory m wher mallocRemote :: Int -> m (Maybe (RemotePtr m Word8)) -- | Copy the given number of elements from the host array into remote memory. - pokeRemote :: SingleType e -> Int -> RemotePtr m (ScalarDataRepr e) -> ArrayData e -> m () + pokeRemote :: SingleType e -> Int -> RemotePtr m (ScalarArrayDataR e) -> ArrayData e -> m () -- | Copy the given number of elements from remote memory to the host array. - peekRemote :: SingleType e -> Int -> RemotePtr m (ScalarDataRepr e) -> MutableArrayData e -> m () + peekRemote :: SingleType e -> Int -> RemotePtr m (ScalarArrayDataR e) -> MutableArrayData e -> m () -- | Cast a remote pointer. castRemotePtr :: RemotePtr m a -> RemotePtr m b diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs index f4b251226..c5b884cd2 100644 --- a/src/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/src/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -37,6 +37,17 @@ module Data.Array.Accelerate.Array.Remote.LRU ( ) where +import Data.Array.Accelerate.Analysis.Match ( matchSingleType, (:~:)(..) ) +import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Remote.Class +import Data.Array.Accelerate.Array.Remote.Table ( StableArray, makeWeakArrayData ) +import Data.Array.Accelerate.Array.Unique ( touchUniqueArray ) +import Data.Array.Accelerate.Error ( internalError ) +import Data.Array.Accelerate.Type +import qualified Data.Array.Accelerate.Array.Remote.Table as Basic +import qualified Data.Array.Accelerate.Debug as D + import Control.Concurrent.MVar ( MVar, newMVar, withMVar, takeMVar, putMVar, mkWeakMVar ) import Control.Monad ( filterM ) import Control.Monad.Catch @@ -51,17 +62,6 @@ import System.Mem.Weak ( Weak, deRefWea import Prelude hiding ( lookup ) import qualified Data.HashTable.IO as HT -import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) -import Data.Array.Accelerate.Analysis.Match ( matchSingleType, (:~:)(..) ) -import Data.Array.Accelerate.Array.Data ( ArrayData, ScalarData, ScalarDataRepr, ScalarDict(..), singleDict ) -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 -import Data.Array.Accelerate.Array.Unique ( touchUniqueArray ) - -- We build cached memory tables on top of a basic memory table. -- @@ -86,14 +86,14 @@ data Status = Clean -- Array in remote memory matches array in host memory. type Timestamp = Integer data Used task where - Used :: ArrayData e ~ ScalarData e + Used :: ArrayData e ~ ScalarArrayData e => !Timestamp -> !Status -> {-# UNPACK #-} !Int -- Use count -> ![task] -- Asynchronous tasks using the array -> {-# UNPACK #-} !Int -- Number of elements -> !(SingleType e) - -> {-# UNPACK #-} !(Weak (ScalarData e)) + -> {-# UNPACK #-} !(Weak (ScalarArrayData e)) -> Used task -- | A Task represents a process executing asynchronously that can be polled for @@ -140,9 +140,9 @@ withRemote => MemoryTable (RemotePtr m) task -> SingleType a -> ArrayData a - -> (RemotePtr m (ScalarDataRepr a) -> m (task, c)) + -> (RemotePtr m (ScalarArrayDataR a) -> m (task, c)) -> m (Maybe c) -withRemote (MemoryTable !mt !ref _) !tp !arr run | (ScalarDict, _, _) <- singleDict tp = do +withRemote (MemoryTable !mt !ref _) !tp !arr run | SingleArrayDict <- singleArrayDict tp = do key <- Basic.makeStableArray tp arr mp <- withMVar' ref $ \utbl -> do mu <- liftIO . HT.mutate utbl key $ \case @@ -174,7 +174,7 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run | (ScalarDict, _, _) <- singleD tasks' <- cleanUses tasks return (Used ts status (count - 1) (task : tasks') n tp' weak_arr) - copyBack :: UT task -> Used task -> m (RemotePtr m (ScalarDataRepr a)) + copyBack :: UT task -> Used task -> m (RemotePtr m (ScalarArrayDataR a)) copyBack utbl (Used ts _ count tasks n tp' weak_arr) | Just Refl <- matchSingleType tp tp' = do message "withRemote/reuploading-evicted-array" @@ -187,7 +187,7 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run | (ScalarDict, _, _) <- singleD -- because the `permute` operation from the PTX backend requires nested -- calls to `withRemote` in order to copy the defaults array. -- - go :: ArrayData a ~ ScalarData a => StableArray -> RemotePtr m (ScalarDataRepr a) -> m c + go :: ArrayData a ~ ScalarArrayData a => StableArray -> RemotePtr m (ScalarArrayDataR a) -> m c go key ptr = do message ("withRemote/using: " ++ show key) (task, c) <- run ptr @@ -224,7 +224,7 @@ malloc :: forall e m task. (RemoteMemory m, MonadIO m, Task task) -> Bool -- ^ True if host array is frozen. -> Int -- ^ Number of elements -> m Bool -- ^ Was the array allocated successfully? -malloc (MemoryTable mt ref weak_utbl) !tp !ad !frozen !n | (ScalarDict, _, _) <- singleDict tp = do -- Required for ArrayData e ~ ScalarData e +malloc (MemoryTable mt ref weak_utbl) !tp !ad !frozen !n | SingleArrayDict <- singleArrayDict tp = do -- Required for ArrayData e ~ ScalarArrayData e ts <- liftIO $ getCPUTime key <- Basic.makeStableArray tp ad -- @@ -243,18 +243,18 @@ malloc (MemoryTable mt ref weak_utbl) !tp !ad !frozen !n | (ScalarDict, _, _) <- return False mallocWithUsage - :: forall e m task. (RemoteMemory m, MonadIO m, Task task, ArrayData e ~ ScalarData e) + :: forall e m task. (RemoteMemory m, MonadIO m, Task task, ArrayData e ~ ScalarArrayData e) => Basic.MemoryTable (RemotePtr m) -> UT task -> SingleType e -> ArrayData e -> Used task - -> m (RemotePtr m (ScalarDataRepr e)) + -> m (RemotePtr m (ScalarArrayDataR e)) mallocWithUsage !mt !utbl !tp !ad !usage@(Used _ _ _ _ n _ _) = malloc' where - malloc' :: m (RemotePtr m (ScalarDataRepr e)) + malloc' :: m (RemotePtr m (ScalarArrayDataR e)) malloc' = do - mp <- Basic.malloc @e @m mt tp ad n :: m (Maybe (RemotePtr m (ScalarDataRepr e))) + mp <- Basic.malloc @e @m mt tp ad n :: m (Maybe (RemotePtr m (ScalarArrayDataR e))) case mp of Nothing -> do success <- evictLRU utbl mt @@ -356,9 +356,9 @@ insertUnmanaged => MemoryTable (RemotePtr m) task -> SingleType e -> ArrayData e - -> RemotePtr m (ScalarDataRepr e) + -> RemotePtr m (ScalarArrayDataR e) -> m () -insertUnmanaged (MemoryTable mt ref weak_utbl) !tp !arr !ptr | (ScalarDict, _, _) <- singleDict tp = do -- Gives evidence that ArrayData e ~ ScalarData e +insertUnmanaged (MemoryTable mt ref weak_utbl) !tp !arr !ptr | SingleArrayDict <- singleArrayDict tp = do -- Gives evidence that ArrayData e ~ ScalarArrayData e key <- Basic.makeStableArray tp arr () <- Basic.insertUnmanaged mt tp arr ptr liftIO diff --git a/src/Data/Array/Accelerate/Array/Remote/Table.hs b/src/Data/Array/Accelerate/Array/Remote/Table.hs index 7f9fb0dda..2a170c2fb 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Table.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Table.hs @@ -124,9 +124,9 @@ lookup :: forall m a. => MemoryTable (RemotePtr m) -> SingleType a -> ArrayData a - -> IO (Maybe (RemotePtr m (ScalarDataRepr a))) + -> IO (Maybe (RemotePtr m (ScalarArrayDataR a))) lookup (MemoryTable !ref _ _ _) !tp !arr - | (ScalarDict, _, _) <- singleDict tp = do + | SingleArrayDict <- singleArrayDict tp = do sa <- makeStableArray tp arr mw <- withMVar ref (`HT.lookup` sa) case mw of @@ -162,9 +162,11 @@ malloc :: forall a m. (RemoteMemory m, MonadIO m) -> SingleType a -> ArrayData a -> Int - -> m (Maybe (RemotePtr m (ScalarDataRepr a))) + -> m (Maybe (RemotePtr m (ScalarArrayDataR a))) malloc mt@(MemoryTable _ _ !nursery _) !tp !ad !n - | (ScalarDict, _, _) <- singleDict tp = do + | SingleArrayDict <- singleArrayDict tp + , SingleDict <- singleDict tp + = do -- Note: [Allocation sizes] -- -- Instead of allocating the exact number of elements requested, we round up to @@ -175,9 +177,9 @@ malloc mt@(MemoryTable _ _ !nursery _) !tp !ad !n chunk <- remoteAllocationSize let -- next highest multiple of f from x multiple x f = (x + (f-1)) `quot` f - bytes = chunk * multiple (n * sizeOf (undefined::(ScalarDataRepr a))) chunk + bytes = chunk * multiple (n * sizeOf (undefined::(ScalarArrayDataR a))) chunk -- - message $ printf "malloc %d bytes (%d x %d bytes, type=%s, pagesize=%d)" bytes n (sizeOf (undefined:: (ScalarDataRepr a))) (show tp) chunk + message $ printf "malloc %d bytes (%d x %d bytes, type=%s, pagesize=%d)" bytes n (sizeOf (undefined:: (ScalarArrayDataR a))) (show tp) chunk -- mp <- fmap (castRemotePtr @m) @@ -261,10 +263,10 @@ insert => MemoryTable (RemotePtr m) -> SingleType a -> ArrayData a - -> RemotePtr m (ScalarDataRepr a) + -> RemotePtr m (ScalarArrayDataR a) -> Int -> m () -insert mt@(MemoryTable !ref _ _ _) !tp !arr !ptr !bytes | (ScalarDict, _, _) <- singleDict tp = do +insert mt@(MemoryTable !ref _ _ _) !tp !arr !ptr !bytes | SingleArrayDict <- singleArrayDict tp = do key <- makeStableArray tp arr weak <- liftIO $ makeWeakArrayData tp arr () (Just $ freeStable @m mt key) message $ "insert: " ++ show key @@ -283,9 +285,9 @@ insertUnmanaged => MemoryTable (RemotePtr m) -> SingleType a -> ArrayData a - -> RemotePtr m (ScalarDataRepr a) + -> RemotePtr m (ScalarArrayDataR a) -> m () -insertUnmanaged (MemoryTable !ref !weak_ref _ _) tp !arr !ptr | (ScalarDict, _, _) <- singleDict tp = do +insertUnmanaged (MemoryTable !ref !weak_ref _ _) tp !arr !ptr | SingleArrayDict <- singleArrayDict tp = do key <- makeStableArray tp arr weak <- liftIO $ makeWeakArrayData tp arr () (Just $ remoteFinalizer weak_ref key) message $ "insertUnmanaged: " ++ show key @@ -358,7 +360,8 @@ makeStableArray -> ArrayData a -> m StableArray makeStableArray !tp !ad - | (ScalarDict, _, _) <- singleDict tp = return $! StableArray (uniqueArrayId ad) + | SingleArrayDict <- singleArrayDict tp + = return $! StableArray (uniqueArrayId ad) -- Weak arrays @@ -374,7 +377,7 @@ makeWeakArrayData -> c -> Maybe (IO ()) -> IO (Weak c) -makeWeakArrayData !tp !ad !c !mf | (ScalarDict, _, _) <- singleDict tp = do +makeWeakArrayData !tp !ad !c !mf | SingleArrayDict <- singleArrayDict tp = do let !uad = uniqueArrayData ad case mf of Nothing -> return () diff --git a/src/Data/Array/Accelerate/Array/Unique.hs b/src/Data/Array/Accelerate/Array/Unique.hs index bdaa87bab..a54634a20 100644 --- a/src/Data/Array/Accelerate/Array/Unique.hs +++ b/src/Data/Array/Accelerate/Array/Unique.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Unique @@ -9,15 +12,11 @@ -- Portability : non-portable (GHC extensions) -- -module Data.Array.Accelerate.Array.Unique ( +module Data.Array.Accelerate.Array.Unique + where - UniqueArray(..), - newUniqueArray, - withUniqueArrayPtr, - unsafeUniqueArrayPtr, - touchUniqueArray, - -) where +-- friends +import Data.Array.Accelerate.Lifetime -- library import Control.Applicative @@ -25,12 +24,15 @@ import Control.Concurrent.Unique import Control.DeepSeq import Foreign.ForeignPtr import Foreign.ForeignPtr.Unsafe +import Foreign.Marshal.Array import Foreign.Ptr +import Foreign.Storable +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Data.Word +import System.IO.Unsafe import Prelude --- friends -import Data.Array.Accelerate.Lifetime - -- | A uniquely identifiable array. -- @@ -52,8 +54,7 @@ data UniqueArray e = UniqueArray } instance NFData (UniqueArray e) where - rnf (UniqueArray _ ad) = unsafeGetValue ad `seq` () - + rnf = rnfUniqueArray -- | Create a new UniqueArray -- @@ -73,6 +74,30 @@ withUniqueArrayPtr :: UniqueArray a -> (Ptr a -> IO b) -> IO b withUniqueArrayPtr ua go = withLifetime (uniqueArrayData ua) $ \fp -> withForeignPtr fp go +-- | 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 + -- | Extract the pointer backing the unique array. -- @@ -96,3 +121,18 @@ unsafeUniqueArrayPtr = unsafeForeignPtrToPtr . unsafeGetValue . uniqueArrayData touchUniqueArray :: UniqueArray a -> IO () touchUniqueArray = touchLifetime . uniqueArrayData + +rnfUniqueArray :: UniqueArray a -> () +rnfUniqueArray (UniqueArray _ ad) = unsafeGetValue ad `seq` () + +-- TODO: Make sure that the data is correctly aligned... +-- +liftUniqueArray :: forall a. Storable a => Int -> UniqueArray a -> Q (TExp (UniqueArray a)) +liftUniqueArray sz ua = do + bytes <- runIO $ peekArray (sizeOf (undefined::a) * sz) (castPtr (unsafeUniqueArrayPtr ua) :: Ptr Word8) + [|| unsafePerformIO $ do + fp <- newForeignPtr_ $$( unsafeTExpCoerce [| Ptr $(litE (StringPrimL bytes)) |] ) + ua' <- newUniqueArray (castForeignPtr fp) + return ua' + ||] + diff --git a/src/Data/Array/Accelerate/Classes/Bounded.hs b/src/Data/Array/Accelerate/Classes/Bounded.hs index 187cf0150..12b04fdde 100644 --- a/src/Data/Array/Accelerate/Classes/Bounded.hs +++ b/src/Data/Array/Accelerate/Classes/Bounded.hs @@ -22,9 +22,9 @@ module Data.Array.Accelerate.Classes.Bounded ( ) where import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Type import Prelude ( ($), (<$>), Num(..), show, concat, map, mapM ) diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 79c309211..7577c2fe4 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -26,7 +26,8 @@ module Data.Array.Accelerate.Classes.Eq ( ) where -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type diff --git a/src/Data/Array/Accelerate/Classes/Num.hs b/src/Data/Array/Accelerate/Classes/Num.hs index b98a82ab3..b7570f75d 100644 --- a/src/Data/Array/Accelerate/Classes/Num.hs +++ b/src/Data/Array/Accelerate/Classes/Num.hs @@ -20,7 +20,7 @@ module Data.Array.Accelerate.Classes.Num ( ) where -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index cf97f496e..344b54362 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -27,9 +27,11 @@ module Data.Array.Accelerate.Classes.Ord ( ) where import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape import Data.Array.Accelerate.Type -- We must hide (==), as that operator is used for the literals 0, 1 and 2 in the pattern synonyms for Ordering. @@ -109,17 +111,17 @@ instance Ord sh => Ord (sh :. Int) where x <= y = indexHead x <= indexHead y && indexTail x <= indexTail y x >= y = indexHead x >= indexHead y && indexTail x >= indexTail y x < y = indexHead x < indexHead y - && case matchTupleType (eltType @sh) (eltType @Z) of + && case matchTypeR (eltR @sh) (eltR @Z) of Just Refl -> constant True Nothing -> indexTail x < indexTail y x > y = indexHead x > indexHead y - && case matchTupleType (eltType @sh) (eltType @Z) of + && case matchTypeR (eltR @sh) (eltR @Z) of Just Refl -> constant True Nothing -> indexTail x > indexTail y instance Elt Ordering where - type EltRepr Ordering = Int8 - eltType = TupRsingle scalarType + type EltR Ordering = Int8 + eltR = TupRsingle scalarType fromElt = P.fromIntegral . P.fromEnum toElt = P.toEnum . P.fromIntegral diff --git a/src/Data/Array/Accelerate/Classes/Rational.hs b/src/Data/Array/Accelerate/Classes/Rational.hs index 3baadf364..c5ee9db30 100644 --- a/src/Data/Array/Accelerate/Classes/Rational.hs +++ b/src/Data/Array/Accelerate/Classes/Rational.hs @@ -20,6 +20,7 @@ import Data.Array.Accelerate.Data.Bits import Data.Array.Accelerate.Language import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Eq diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs b/src/Data/Array/Accelerate/Classes/RealFloat.hs index 9bf70d470..e898b385d 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs @@ -25,8 +25,8 @@ module Data.Array.Accelerate.Classes.RealFloat ( ) where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Language ( cond, while ) import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Type @@ -407,8 +407,3 @@ ieee754_f64_decode2 i = (T4 1 0 0 0) (T4 sign hi lo ie) -cond :: Exp Bool -> Exp a -> Exp a -> Exp a -cond (Exp c) (Exp x) (Exp y) = Exp $ SmartExp $ Cond c x y - -while :: forall e. Elt e => (Exp e -> Exp Bool) -> (Exp e -> Exp e) -> Exp e -> Exp e -while c f (Exp e) = Exp $ SmartExp $ While (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs b/src/Data/Array/Accelerate/Classes/RealFrac.hs index d2048e923..52c0f330b 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs @@ -23,11 +23,12 @@ module Data.Array.Accelerate.Classes.RealFrac ( ) where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Language ( (^), cond, even ) import Data.Array.Accelerate.Lift ( unlift ) import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Eq @@ -198,7 +199,6 @@ defaultFloor x | otherwise = let (n, r) = properFraction x in cond (r < 0) (n-1) n --- mkRound :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b defaultRound :: forall a b. (RealFrac a, Integral b, FromIntegral Int64 b) => Exp a -> Exp b defaultRound x | Just IsFloatingDict <- isFloating @a @@ -222,9 +222,9 @@ data IsFloatingDict a where data IsIntegralDict a where IsIntegralDict :: IsIntegral a => IsIntegralDict a -isFloating :: forall a. Elt a => Maybe (IsFloatingDict (EltRepr a)) +isFloating :: forall a. Elt a => Maybe (IsFloatingDict (EltR a)) isFloating - | TupRsingle t <- eltType @a + | TupRsingle t <- eltR @a , SingleScalarType s <- t , NumSingleType n <- s , FloatingNumType f <- n @@ -236,9 +236,9 @@ isFloating | otherwise = Nothing -isIntegral :: forall a. Elt a => Maybe (IsIntegralDict (EltRepr a)) +isIntegral :: forall a. Elt a => Maybe (IsIntegralDict (EltR a)) isIntegral - | TupRsingle t <- eltType @a + | TupRsingle t <- eltR @a , SingleScalarType s <- t , NumSingleType n <- s , IntegralNumType i <- n diff --git a/src/Data/Array/Accelerate/Data/Bits.hs b/src/Data/Array/Accelerate/Data/Bits.hs index 1a27d04d0..a2ad1b3b6 100644 --- a/src/Data/Array/Accelerate/Data/Bits.hs +++ b/src/Data/Array/Accelerate/Data/Bits.hs @@ -25,9 +25,9 @@ module Data.Array.Accelerate.Data.Bits ( ) where import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Language import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Eq @@ -681,42 +681,42 @@ instance FiniteBits CUChar where -- Default implementations -- ----------------------- -bitDefault :: (IsIntegral (EltRepr t), Bits t) => Exp Int -> Exp t +bitDefault :: (IsIntegral (EltR t), Bits t) => Exp Int -> Exp t bitDefault x = constInt 1 `shiftL` x -testBitDefault :: (IsIntegral (EltRepr t), Bits t) => Exp t -> Exp Int -> Exp Bool +testBitDefault :: (IsIntegral (EltR t), Bits t) => Exp t -> Exp Int -> Exp Bool testBitDefault x i = (x .&. bit i) /= constInt 0 -shiftDefault :: (FiniteBits t, IsIntegral (EltRepr t), B.Bits t) => Exp t -> Exp Int -> Exp t +shiftDefault :: (FiniteBits t, IsIntegral (EltR 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 (EltRepr t)) => Exp t -> Exp Int -> Exp t +shiftLDefault :: (FiniteBits t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t shiftLDefault x i = cond (i >= finiteBitSize x) (constInt 0) $ mkBShiftL x i -shiftRDefault :: forall t. (B.Bits t, FiniteBits t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +shiftRDefault :: forall t. (B.Bits t, FiniteBits t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t shiftRDefault | B.isSigned (undefined::t) = shiftRADefault | otherwise = shiftRLDefault -- Shift the argument right (signed) -shiftRADefault :: (FiniteBits t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +shiftRADefault :: (FiniteBits t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t shiftRADefault x i = cond (i >= finiteBitSize x) (cond (mkLt x (constInt 0)) (constInt (-1)) (constInt 0)) $ mkBShiftR x i -- Shift the argument right (unsigned) -shiftRLDefault :: (FiniteBits t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +shiftRLDefault :: (FiniteBits t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t shiftRLDefault x i = cond (i >= finiteBitSize x) (constInt 0) $ mkBShiftR x i -rotateDefault :: forall t. (FiniteBits t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +rotateDefault :: forall t. (FiniteBits t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t rotateDefault = - case integralType :: IntegralType (EltRepr t) of + case integralType :: IntegralType (EltR t) of TypeInt{} -> rotateDefault' (undefined::Word) TypeInt8{} -> rotateDefault' (undefined::Word8) TypeInt16{} -> rotateDefault' (undefined::Word16) @@ -729,7 +729,7 @@ rotateDefault = TypeWord64{} -> rotateDefault' (undefined::Word64) rotateDefault' - :: forall i w. (Elt w, FiniteBits i, IsIntegral (EltRepr i), IsIntegral (EltRepr w), IsIntegral (EltRepr i), IsIntegral (EltRepr w), BitSizeEq (EltRepr i) (EltRepr w), BitSizeEq (EltRepr w) (EltRepr i)) + :: forall i w. (Elt w, FiniteBits i, IsIntegral (EltR i), IsIntegral (EltR w), IsIntegral (EltR i), IsIntegral (EltR w), BitSizeEq (EltR i) (EltR w), BitSizeEq (EltR w) (EltR i)) => w {- dummy -} -> Exp i -> Exp Int @@ -745,12 +745,12 @@ rotateDefault' _ x i i' = i `mkBAnd` (wsib - 1) wsib = finiteBitSize x -rotateLDefault :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +rotateLDefault :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t rotateLDefault x i = cond (i == 0) x $ mkBRotateL x i -rotateRDefault :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +rotateRDefault :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t rotateRDefault x i = cond (i == 0) x $ mkBRotateR x i @@ -758,7 +758,7 @@ rotateRDefault x i isSignedDefault :: forall b. B.Bits b => Exp b -> Exp Bool isSignedDefault _ = constant (B.isSigned (undefined::b)) -constInt :: IsIntegral (EltRepr e) => EltRepr e -> Exp e +constInt :: IsIntegral (EltR e) => EltR e -> Exp e constInt = mkExp . Const (SingleScalarType (NumSingleType (IntegralNumType integralType))) {-- diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index 702d940c6..3ad23ce6f 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -45,19 +45,23 @@ module Data.Array.Accelerate.Data.Complex ( ) where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Classes import Data.Array.Accelerate.Data.Functor import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Vec import Data.Array.Accelerate.Type +import Data.Primitive.Vec import Data.Complex ( Complex(..) ) import Prelude (($)) import qualified Data.Complex as C import qualified Prelude as P + infix 6 ::+ pattern (::+) :: Elt a => Exp a -> Exp a -> Exp (Complex a) pattern r ::+ i <- (deconstructComplex -> (r, i)) @@ -69,85 +73,104 @@ pattern r ::+ i <- (deconstructComplex -> (r, i)) -- This matches the standard C-style layout, but we can use this representation only at -- specific types (not for any type 'a') as we can only have vectors of primitive type. -- For other types, we use a structure-of-arrays representation. This is handled by the --- ComplexRepr. We use the GADT ComplexR and function complexR to reconstruct +-- ComplexR. We use the GADT ComplexR and function complexR to reconstruct -- information on how the elements are represented. -- instance Elt a => Elt (Complex a) where - type EltRepr (Complex a) = ComplexRepr (EltRepr a) - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = case complexR tp of - ComplexRvec s -> TupRsingle $ VectorScalarType $ VectorType 2 s - ComplexRtup -> TupRunit `TupRpair` tp `TupRpair` tp + type EltR (Complex a) = ComplexR (EltR a) + eltR = case complexR tp of + ComplexVec s -> TupRsingle $ VectorScalarType $ VectorType 2 s + ComplexTup -> TupRunit `TupRpair` tp `TupRpair` tp where - tp = eltType @a - toElt = case complexR $ eltType @a of - ComplexRvec _ -> \(Vec2 r i) -> toElt r :+ toElt i - ComplexRtup -> \(((), r), i) -> toElt r :+ toElt i - fromElt (r :+ i) = case complexR $ eltType @a of - ComplexRvec _ -> Vec2 (fromElt r) (fromElt i) - ComplexRtup -> (((), fromElt r), fromElt i) - -type family ComplexRepr a where - ComplexRepr Half = Vec2 Half - ComplexRepr Float = Vec2 Float - ComplexRepr Double = Vec2 Double - ComplexRepr Int = Vec2 Int - ComplexRepr Int8 = Vec2 Int8 - ComplexRepr Int16 = Vec2 Int16 - ComplexRepr Int32 = Vec2 Int32 - ComplexRepr Int64 = Vec2 Int64 - ComplexRepr Word = Vec2 Word - ComplexRepr Word8 = Vec2 Word8 - ComplexRepr Word16 = Vec2 Word16 - ComplexRepr Word32 = Vec2 Word32 - ComplexRepr Word64 = Vec2 Word64 - ComplexRepr a = Tup2 a a - -data ComplexR a c where - ComplexRvec :: VecElt a => SingleType a -> ComplexR a (Vec2 a) - ComplexRtup :: ComplexR a (Tup2 a a) - -complexR :: TupleType a -> ComplexR a (ComplexRepr a) -complexR (TupRsingle (SingleScalarType (NumSingleType (FloatingNumType TypeHalf )))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (FloatingNumType TypeFloat )))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (FloatingNumType TypeDouble)))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt )))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt8 )))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt16 )))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt32 )))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt64 )))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord )))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord8 )))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord16)))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord32)))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeWord64)))) = ComplexRvec singleType -complexR (TupRsingle (SingleScalarType (NonNumSingleType TypeChar))) = ComplexRtup -complexR (TupRsingle (SingleScalarType (NonNumSingleType TypeBool))) = ComplexRtup -complexR (TupRsingle (VectorScalarType (_))) = ComplexRtup -complexR TupRunit = ComplexRtup -complexR TupRpair{} = ComplexRtup + tp = eltR @a + toElt = case complexR $ eltR @a of + ComplexVec _ -> \(Vec2 r i) -> toElt r :+ toElt i + ComplexTup -> \(((), r), i) -> toElt r :+ toElt i + fromElt (r :+ i) = case complexR $ eltR @a of + ComplexVec _ -> Vec2 (fromElt r) (fromElt i) + ComplexTup -> (((), fromElt r), fromElt i) + +type family ComplexR a where + ComplexR Half = Vec2 Half + ComplexR Float = Vec2 Float + ComplexR Double = Vec2 Double + ComplexR Int = Vec2 Int + ComplexR Int8 = Vec2 Int8 + ComplexR Int16 = Vec2 Int16 + ComplexR Int32 = Vec2 Int32 + ComplexR Int64 = Vec2 Int64 + ComplexR Word = Vec2 Word + ComplexR Word8 = Vec2 Word8 + ComplexR Word16 = Vec2 Word16 + ComplexR Word32 = Vec2 Word32 + ComplexR Word64 = Vec2 Word64 + ComplexR a = (((), a), a) + +data ComplexType a c where + ComplexVec :: VecElt a => SingleType a -> ComplexType a (Vec2 a) + ComplexTup :: ComplexType a (((), a), a) + +complexR :: TypeR a -> ComplexType a (ComplexR a) +complexR = tuple + where + tuple :: TypeR a -> ComplexType a (ComplexR a) + tuple TupRunit = ComplexTup + tuple TupRpair{} = ComplexTup + tuple (TupRsingle s) = scalar s + + scalar :: ScalarType a -> ComplexType a (ComplexR a) + scalar (SingleScalarType t) = single t + scalar VectorScalarType{} = ComplexTup + + single :: SingleType a -> ComplexType a (ComplexR a) + single (NumSingleType t) = num t + single (NonNumSingleType t) = nonnum t + + nonnum :: NonNumType a -> ComplexType a (ComplexR a) + nonnum TypeChar = ComplexTup + nonnum TypeBool = ComplexTup + + num :: NumType a -> ComplexType a (ComplexR a) + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + integral :: IntegralType a -> ComplexType a (ComplexR a) + integral TypeInt = ComplexVec singleType + integral TypeInt8 = ComplexVec singleType + integral TypeInt16 = ComplexVec singleType + integral TypeInt32 = ComplexVec singleType + integral TypeInt64 = ComplexVec singleType + integral TypeWord = ComplexVec singleType + integral TypeWord8 = ComplexVec singleType + integral TypeWord16 = ComplexVec singleType + integral TypeWord32 = ComplexVec singleType + integral TypeWord64 = ComplexVec singleType + + floating :: FloatingType a -> ComplexType a (ComplexR a) + floating TypeHalf = ComplexVec singleType + floating TypeFloat = ComplexVec singleType + floating TypeDouble = ComplexVec singleType + constructComplex :: forall a. Elt a => Exp a -> Exp a -> Exp (Complex a) -constructComplex r i = case complexR $ eltType @a of - ComplexRvec _ -> +constructComplex r i = case complexR (eltR @a) of + ComplexVec _ -> let - r', i' :: Exp (EltRepr a) - r' = coerce @a @(EltRepr a) r + r', i' :: Exp (EltR a) + r' = coerce @a @(EltR a) r i' = coerce i - v :: Exp (Vec2 (EltRepr a)) + v :: Exp (Vec2 (EltR a)) v = V2 r' i' in - coerce @(Vec2 (EltRepr a)) @(Complex a) $ v - ComplexRtup -> coerce $ T2 r i + coerce @(Vec2 (EltR a)) @(Complex a) $ v + ComplexTup -> coerce $ T2 r i deconstructComplex :: forall a. Elt a => Exp (Complex a) -> (Exp a, Exp a) -deconstructComplex c = case complexR $ eltType @a of - ComplexRvec _ -> let V2 r i = coerce @(Complex a) @(Vec2 (EltRepr a)) c in (coerce r, coerce i) - ComplexRtup -> let T2 r i = coerce c in (r, i) +deconstructComplex c = case complexR (eltR @a) of + ComplexVec _ -> let V2 r i = coerce @(Complex a) @(Vec2 (EltR a)) c in (coerce r, coerce i) + ComplexTup -> let T2 r i = coerce c in (r, i) -coerce :: EltRepr a ~ EltRepr b => Exp a -> Exp b +coerce :: EltR a ~ EltR b => Exp a -> Exp b coerce (Exp e) = Exp e instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Complex a) where diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index a427ac858..02e575d92 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -30,7 +30,9 @@ module Data.Array.Accelerate.Data.Either ( ) where import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Sugar hiding ( (!), shape, ignore, toIndex ) +import Data.Array.Accelerate.Sugar.Array ( Array, Vector ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape ( Shape, Slice, Z(..), (:.), empty ) import Data.Array.Accelerate.Language hiding ( chr ) import Data.Array.Accelerate.Prelude hiding ( filter ) import Data.Array.Accelerate.Interpreter @@ -151,15 +153,12 @@ tag x = t where T3 t _ _ = asTuple x instance (Elt a, Elt b) => Elt (Either a b) where - type EltRepr (Either a b) = Tup3 Word8 (EltRepr a) (EltRepr b) - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = eltType @(Word8,a,b) + type EltR (Either a b) = EltR (Word8,a,b) + eltR = eltR @(Word8,a,b) toElt ((((),0),a),_) = Left (toElt a) toElt (_ ,b) = Right (toElt b) - fromElt (Left a) = ((((),0), fromElt a ), evalUndef $ eltType @b) - fromElt (Right b) = ((((),1), evalUndef $ eltType @a), fromElt b) + fromElt (Left a) = ((((),0), fromElt a ), evalUndef $ eltR @b) + fromElt (Right b) = ((((),1), evalUndef $ eltR @a), fromElt 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) diff --git a/src/Data/Array/Accelerate/Data/Functor.hs b/src/Data/Array/Accelerate/Data/Functor.hs index d6703f2ef..b78c69a82 100644 --- a/src/Data/Array/Accelerate/Data/Functor.hs +++ b/src/Data/Array/Accelerate/Data/Functor.hs @@ -26,7 +26,7 @@ module Data.Array.Accelerate.Data.Functor ( ) where -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Lift import Data.Array.Accelerate.Smart diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index 8ebf345c9..fbd4b643c 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -29,12 +29,15 @@ module Data.Array.Accelerate.Data.Maybe ( ) where +import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Sugar hiding ( (!), shape, ignore, toIndex ) +import Data.Array.Accelerate.Interpreter import Data.Array.Accelerate.Language hiding ( chr ) import Data.Array.Accelerate.Prelude hiding ( filter ) -import Data.Array.Accelerate.Interpreter import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Array ( Array, Vector ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape ( Shape, Slice, Z(..), (:.), empty ) import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Eq @@ -154,14 +157,11 @@ tag (Exp x) = Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxLeft x instance Elt a => Elt (Maybe a) where - type EltRepr (Maybe a) = Tup2 Word8 (EltRepr a) - {-# INLINE eltType #-} - {-# INLINE [1] toElt #-} - {-# INLINE [1] fromElt #-} - eltType = eltType @(Word8,a) + type EltR (Maybe a) = EltR (Word8, a) + eltR = eltR @(Word8,a) toElt (((),0),_) = Nothing toElt (_ ,x) = Just (toElt x) - fromElt Nothing = (((),0), evalUndef $ eltType @a) + fromElt Nothing = (((),0), evalUndef $ eltR @a) fromElt (Just a) = (((),1), fromElt a) instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Maybe a) where diff --git a/src/Data/Array/Accelerate/Data/Monoid.hs b/src/Data/Array/Accelerate/Data/Monoid.hs index ffbda1328..7c95fd3a3 100644 --- a/src/Data/Array/Accelerate/Data/Monoid.hs +++ b/src/Data/Array/Accelerate/Data/Monoid.hs @@ -35,7 +35,6 @@ module Data.Array.Accelerate.Data.Monoid ( ) 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 @@ -43,6 +42,8 @@ import Data.Array.Accelerate.Classes.Ord import Data.Array.Accelerate.Language import Data.Array.Accelerate.Lift import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Type #if __GLASGOW_HASKELL__ >= 800 import Data.Array.Accelerate.Data.Semigroup () diff --git a/src/Data/Array/Accelerate/Data/Ratio.hs b/src/Data/Array/Accelerate/Data/Ratio.hs index a7fbe7e88..d78ad9d59 100644 --- a/src/Data/Array/Accelerate/Data/Ratio.hs +++ b/src/Data/Array/Accelerate/Data/Ratio.hs @@ -29,11 +29,11 @@ module Data.Array.Accelerate.Data.Ratio ( ) where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Language -import Data.Array.Accelerate.Orphans () import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Enum diff --git a/src/Data/Array/Accelerate/Data/Semigroup.hs b/src/Data/Array/Accelerate/Data/Semigroup.hs index c603f5e87..79e6a2d22 100644 --- a/src/Data/Array/Accelerate/Data/Semigroup.hs +++ b/src/Data/Array/Accelerate/Data/Semigroup.hs @@ -36,7 +36,6 @@ module Data.Array.Accelerate.Data.Semigroup ( ) 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 @@ -44,6 +43,7 @@ import Data.Array.Accelerate.Classes.Ord import Data.Array.Accelerate.Lift import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt import Data.Function import Data.Monoid ( Monoid(..) ) diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index f833b4659..8931fe6fa 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -24,20 +24,9 @@ -- 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. +-- 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. -- module Data.Array.Accelerate.Interpreter ( @@ -53,7 +42,29 @@ module Data.Array.Accelerate.Interpreter ( ) where --- standard libraries +import Data.Array.Accelerate.AST hiding ( Boundary(..) ) +import Data.Array.Accelerate.AST.Environment +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Slice +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Representation.Vec +import Data.Array.Accelerate.Trafo +import Data.Array.Accelerate.Trafo.Delayed ( DelayedOpenAfun, DelayedOpenAcc ) +import Data.Array.Accelerate.Trafo.Sharing ( AfunctionR, AfunctionRepr(..), afunctionRepr ) +import Data.Array.Accelerate.Type +import Data.Primitive.Vec +import qualified Data.Array.Accelerate.AST as AST +import qualified Data.Array.Accelerate.Debug as D +import qualified Data.Array.Accelerate.Smart as Smart +import qualified Data.Array.Accelerate.Sugar.Array as Sugar +import qualified Data.Array.Accelerate.Trafo.Delayed as AST + import Control.DeepSeq import Control.Exception import Control.Monad @@ -67,20 +78,6 @@ import Text.Printf ( printf ) import Unsafe.Coerce import Prelude hiding ( (!!), sum ) --- friends -import Data.Array.Accelerate.AST hiding ( Boundary(..) ) -import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) -import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Representation -import Data.Array.Accelerate.Error -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.Sugar as Sugar -import qualified Data.Array.Accelerate.Smart as Smart -import qualified Data.Array.Accelerate.Trafo as AST -import qualified Data.Array.Accelerate.Debug as D - -- Program execution -- ----------------- @@ -114,7 +111,10 @@ runN f = go return acc !go = eval (afunctionRepr @f) afun Empty -- - eval :: AfunctionRepr g (AfunctionR g) (AreprFunctionR g) -> DelayedOpenAfun aenv (AreprFunctionR g) -> Val aenv -> AfunctionR g + eval :: AfunctionRepr g (AfunctionR g) (ArraysFunctionR g) + -> DelayedOpenAfun aenv (ArraysFunctionR g) + -> Val aenv + -> AfunctionR g eval (AfunctionReprLam reprF) (Alam lhs f) aenv = \a -> eval reprF f $ aenv `push` (lhs, Sugar.fromArr a) eval AfunctionReprBody (Abody b) aenv = unsafePerformIO $ phase "execute" D.elapsed (Sugar.toArr . snd <$> evaluate (evalOpenAcc b aenv)) eval _ _aenv _ = error "Two men say they're Jesus; one of them must be wrong" @@ -177,13 +177,13 @@ evalOpenAcc (AST.Manifest pacc) aenv = manifest :: forall a'. DelayedOpenAcc aenv a' -> WithReprs a' manifest acc = let (repr, a') = evalOpenAcc acc aenv - in rnfArrays repr a' `seq` (repr, a') + in rnfArraysR repr a' `seq` (repr, a') delayed :: DelayedOpenAcc aenv (Array sh e) -> Delayed (Array sh e) delayed AST.Delayed{..} = Delayed reprD (evalE extentD) (evalF indexD) (evalF linearIndexD) - delayed a' = Delayed repr (shape a) ((repr, a) !) ((arrayRtype repr, a) !!) + delayed a' = Delayed aR (shape a) (indexArray aR a) (linearIndexArray (arrayRtype aR) a) where - (TupRsingle repr, a) = manifest a' + (TupRsingle aR, a) = manifest a' evalE :: Exp aenv t -> t evalE exp = evalExp exp aenv @@ -254,7 +254,7 @@ evalOpenAcc (AST.Manifest pacc) aenv = -- Array primitives -- ---------------- -unitOp :: TupleType e -> e -> WithReprs (Scalar e) +unitOp :: TypeR e -> e -> WithReprs (Scalar e) unitOp tp e = fromFunction' (ArrayR ShapeRz tp) () (const e) @@ -339,7 +339,7 @@ sliceOp slice (TupRsingle repr@(ArrayR _ tp), arr) slix in $indexCheck "slice" i sz $ (sl', \ix -> (f' ix, i)) -mapOp :: TupleType b +mapOp :: TypeR b -> (a -> b) -> Delayed (Array sh a) -> WithReprs (Array sh b) @@ -348,7 +348,7 @@ mapOp tp f (Delayed (ArrayR shr _) sh xs _) zipWithOp - :: TupleType c + :: TypeR c -> (a -> b -> c) -> Delayed (Array sh a) -> Delayed (Array sh b) @@ -425,11 +425,11 @@ scanl1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) (adata, _) = runArrayData @e $ do aout <- newArrayData tp (size shr sh) - let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh (sz, 0)) (ain (sz, 0)) + let write (sz, 0) = writeArrayData tp aout (toIndex shr sh (sz, 0)) (ain (sz, 0)) write (sz, i) = do - x <- unsafeReadArrayData tp aout (toIndex shr sh (sz, i-1)) + x <- readArrayData tp aout (toIndex shr sh (sz, i-1)) let y = ain (sz, i) - unsafeWriteArrayData tp aout (toIndex shr sh (sz, i)) (f x y) + writeArrayData tp aout (toIndex shr sh (sz, i)) (f x y) iter shr sh write (>>) (return ()) return (aout, undefined) @@ -451,11 +451,11 @@ scanlOp f z (Delayed (ArrayR shr tp) (sh, n) ain _) (adata, _) = runArrayData @e $ do aout <- newArrayData tp (size shr sh') - let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh' (sz, 0)) z + let write (sz, 0) = writeArrayData tp aout (toIndex shr sh' (sz, 0)) z write (sz, i) = do - x <- unsafeReadArrayData tp aout (toIndex shr sh' (sz, i-1)) + x <- readArrayData tp aout (toIndex shr sh' (sz, i-1)) let y = ain (sz, i-1) - unsafeWriteArrayData tp aout (toIndex shr sh' (sz, i)) (f x y) + writeArrayData tp aout (toIndex shr sh' (sz, i)) (f x y) iter shr sh' write (>>) (return ()) return (aout, undefined) @@ -477,14 +477,14 @@ scanl'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) asum <- newArrayData tp (size shr' sh) let write (sz, 0) - | n == 0 = unsafeWriteArrayData tp asum (toIndex shr' sh sz) z - | otherwise = unsafeWriteArrayData tp aout (toIndex shr (sh, n) (sz, 0)) z + | n == 0 = writeArrayData tp asum (toIndex shr' sh sz) z + | otherwise = writeArrayData tp aout (toIndex shr (sh, n) (sz, 0)) z write (sz, i) = do - x <- unsafeReadArrayData tp aout (toIndex shr (sh, n) (sz, i-1)) + x <- readArrayData tp aout (toIndex shr (sh, n) (sz, i-1)) let y = ain (sz, i-1) if i == n - then unsafeWriteArrayData tp asum (toIndex shr' sh sz) (f x y) - else unsafeWriteArrayData tp aout (toIndex shr (sh, n) (sz, i)) (f x y) + then writeArrayData tp asum (toIndex shr' sh sz) (f x y) + else writeArrayData tp aout (toIndex shr (sh, n) (sz, i)) (f x y) iter shr (sh, n+1) write (>>) (return ()) return ((aout, asum), undefined) @@ -506,11 +506,11 @@ scanrOp f z (Delayed (ArrayR shr tp) (sz, n) ain _) (adata, _) = runArrayData @e $ do aout <- newArrayData tp (size shr sh') - let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh' (sz, n)) z + let write (sz, 0) = writeArrayData tp aout (toIndex shr sh' (sz, n)) z write (sz, i) = do let x = ain (sz, n-i) - y <- unsafeReadArrayData tp aout (toIndex shr sh' (sz, n-i+1)) - unsafeWriteArrayData tp aout (toIndex shr sh' (sz, n-i)) (f x y) + y <- readArrayData tp aout (toIndex shr sh' (sz, n-i+1)) + writeArrayData tp aout (toIndex shr sh' (sz, n-i)) (f x y) iter shr sh' write (>>) (return ()) return (aout, undefined) @@ -530,11 +530,11 @@ scanr1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) (adata, _) = runArrayData @e $ do aout <- newArrayData tp (size shr sh) - let write (sz, 0) = unsafeWriteArrayData tp aout (toIndex shr sh (sz, n-1)) (ain (sz, n-1)) + let write (sz, 0) = writeArrayData tp aout (toIndex shr sh (sz, n-1)) (ain (sz, n-1)) write (sz, i) = do let x = ain (sz, n-i-1) - y <- unsafeReadArrayData tp aout (toIndex shr sh (sz, n-i)) - unsafeWriteArrayData tp aout (toIndex shr sh (sz, n-i-1)) (f x y) + y <- readArrayData tp aout (toIndex shr sh (sz, n-i)) + writeArrayData tp aout (toIndex shr sh (sz, n-i-1)) (f x y) iter shr sh write (>>) (return ()) return (aout, undefined) @@ -556,15 +556,15 @@ scanr'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) asum <- newArrayData tp (size shr' sh) let write (sz, 0) - | n == 0 = unsafeWriteArrayData tp asum (toIndex shr' sh sz) z - | otherwise = unsafeWriteArrayData tp aout (toIndex shr (sh, n) (sz, n-1)) z + | n == 0 = writeArrayData tp asum (toIndex shr' sh sz) z + | otherwise = writeArrayData tp aout (toIndex shr (sh, n) (sz, n-1)) z write (sz, i) = do let x = ain (sz, n-i) - y <- unsafeReadArrayData tp aout (toIndex shr (sh, n) (sz, n-i)) + y <- readArrayData tp aout (toIndex shr (sh, n) (sz, n-i)) if i == n - then unsafeWriteArrayData tp asum (toIndex shr' sh sz) (f x y) - else unsafeWriteArrayData tp aout (toIndex shr (sh, n) (sz, n-i-1)) (f x y) + then writeArrayData tp asum (toIndex shr' sh sz) (f x y) + else writeArrayData tp aout (toIndex shr (sh, n) (sz, n-i-1)) (f x y) iter shr (sh, n+1) write (>>) (return ()) return ((aout, asum), undefined) @@ -592,8 +592,8 @@ permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR init i | i >= n' = return () | otherwise = do - x <- unsafeReadArrayData tp adef i - unsafeWriteArrayData tp aout i x + x <- readArrayData tp adef i + writeArrayData tp aout i x init (i+1) -- project each element onto the destination array and update @@ -602,10 +602,10 @@ permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR i = toIndex shr sh src j = toIndex shr' sh' dst in - unless (shapeEq shr' dst ignore') $ do + unless (eq shr' dst ignore') $ do let x = ain i - y <- unsafeReadArrayData tp aout j - unsafeWriteArrayData tp aout j (f x y) + y <- readArrayData tp aout j + writeArrayData tp aout j (f x y) init 0 iter shr sh update (>>) (return ()) @@ -624,7 +624,7 @@ backpermuteOp shr sh' p (Delayed (ArrayR _ tp) _ arr _) stencilOp :: StencilR sh a stencil - -> TupleType b + -> TypeR b -> (stencil -> b) -> Boundary (Array sh a) -> Delayed (Array sh a) @@ -633,13 +633,13 @@ stencilOp stencil tp f bnd arr@(Delayed _ sh _ _) = fromFunction' (ArrayR shr tp) sh $ f . stencilAccess stencil (bounded shr bnd arr) where - shr = stencilShape stencil + shr = stencilShapeR stencil stencil2Op :: StencilR sh a stencil1 -> StencilR sh b stencil2 - -> TupleType c + -> TypeR c -> (stencil1 -> stencil2 -> c) -> Boundary (Array sh a) -> Delayed (Array sh a) @@ -651,14 +651,14 @@ stencil2Op s1 s2 tp stencil bnd1 arr1@(Delayed _ sh1 _ _) bnd2 arr2@(Delayed _ s where f ix = stencil (stencilAccess s1 (bounded shr bnd1 arr1) ix) (stencilAccess s2 (bounded shr bnd2 arr2) ix) - shr = stencilShape s1 + shr = stencilShapeR s1 stencilAccess :: StencilR sh e stencil -> (sh -> e) -> sh -> stencil -stencilAccess stencil = goR (stencilShape stencil) stencil +stencilAccess stencil = goR (stencilShapeR stencil) stencil where -- Base cases, nothing interesting to do here since we know the lower -- dimension is Z. @@ -915,8 +915,8 @@ evalOpenExp pexp env aenv = Pair e1 e2 -> let !x1 = evalE e1 !x2 = evalE e2 in (x1, x2) - VecPack vecR e -> vecPack vecR $! evalE e - VecUnpack vecR e -> vecUnpack vecR $! evalE e + VecPack vecR e -> pack vecR $! evalE e + VecUnpack vecR e -> unpack vecR $! evalE e IndexSlice slice slix sh -> restrict slice (evalE slix) (evalE sh) where @@ -968,7 +968,7 @@ evalOpenExp pexp env aenv = -- Constant values -- --------------- -evalUndef :: TupleType a -> a +evalUndef :: TypeR a -> a evalUndef TupRunit = () evalUndef (TupRsingle tp) = evalUndefScalar tp evalUndef (TupRpair t1 t2) = (evalUndef t1, evalUndef t2) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 011608f13..1d5a6fe6f 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -27,12 +27,6 @@ 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, @@ -109,14 +103,19 @@ module Data.Array.Accelerate.Language ( ) where --- friends -import Data.Array.Accelerate.Array.Sugar hiding ( (!), (!!), ignore, shape, reshape, size, toIndex, fromIndex, intersect, union ) +import Data.Array.Accelerate.AST ( PrimFun(..) ) import Data.Array.Accelerate.Pattern -import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Representation.Array ( ArrayR(..) ) +import Data.Array.Accelerate.Representation.Shape ( ShapeR(..) ) +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Smart hiding ( arraysR ) +import Data.Array.Accelerate.Sugar.Array ( Arrays(..), Array, Scalar, Segments, arrayR ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Foreign +import Data.Array.Accelerate.Sugar.Shape ( Shape(..), Slice(..), (:.) ) import Data.Array.Accelerate.Type -import qualified Data.Array.Accelerate.Array.Sugar as Sugar -import qualified Data.Array.Accelerate.Array.Representation as Repr -import Data.Array.Accelerate.AST ( PrimFun(..) ) +import qualified Data.Array.Accelerate.Representation.Array as R +import qualified Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Classes.Eq import Data.Array.Accelerate.Classes.Fractional @@ -124,7 +123,6 @@ import Data.Array.Accelerate.Classes.Integral import Data.Array.Accelerate.Classes.Num import Data.Array.Accelerate.Classes.Ord --- standard libraries import Prelude ( ($), (.) ) -- $setup @@ -168,9 +166,9 @@ import Prelude ( ($), (.) ) -- >>> let tup = use (vec, mat) :: Acc (Vector Int, Matrix Int) -- use :: forall arrays. Arrays arrays => arrays -> Acc arrays -use = Acc . use' (arrays @arrays) . fromArr +use = Acc . use' (arraysR @arrays) . fromArr where - use' :: ArraysR a -> a -> SmartAcc a + use' :: R.ArraysR a -> a -> SmartAcc a use' TupRunit () = SmartAcc $ Anil use' (TupRsingle repr@ArrayR{}) a = SmartAcc $ Use repr a use' (TupRpair r1 r2) (a1, a2) = SmartAcc $ use' r1 a1 `Apair` use' r2 a2 @@ -179,7 +177,7 @@ use = Acc . use' (arrays @arrays) . fromArr -- scalar values). -- unit :: forall e. Elt e => Exp e -> Acc (Scalar e) -unit (Exp e) = Acc $ SmartAcc $ Unit (eltType @e) e +unit (Exp e) = Acc $ SmartAcc $ Unit (eltR @e) e -- | Replicate an array across one or more dimensions as specified by the -- /generalised/ array index provided as the first argument. @@ -421,7 +419,7 @@ map :: forall sh a b. => (Exp a -> Exp b) -> Acc (Array sh a) -> Acc (Array sh b) -map = Acc $$ applyAcc (Map (eltType @a) (eltType @b)) +map = Acc $$ applyAcc (Map (eltR @a) (eltR @b)) -- | 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 @@ -455,7 +453,7 @@ zipWith :: forall sh a b c. -> Acc (Array sh a) -> Acc (Array sh b) -> Acc (Array sh c) -zipWith = Acc $$$ applyAcc (ZipWith (eltType @a) (eltType @b) (eltType @c)) +zipWith = Acc $$$ applyAcc (ZipWith (eltR @a) (eltR @b) (eltR @c)) -- Reductions -- ---------- @@ -527,7 +525,7 @@ fold :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array sh a) -fold = Acc $$$ applyAcc (Fold $ eltType @a) +fold = Acc $$$ applyAcc (Fold $ eltR @a) -- | Variant of 'fold' that requires the innermost dimension of the array to be -- non-empty and doesn't need an default value. @@ -544,7 +542,7 @@ fold1 :: forall sh a. => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array sh a) -fold1 = Acc $$ applyAcc (Fold1 $ eltType @a) +fold1 = Acc $$ applyAcc (Fold1 $ eltR @a) -- | Segmented reduction along the innermost dimension of an array. The -- segment descriptor specifies the starting index (offset) along the @@ -561,13 +559,13 @@ fold1 = Acc $$ applyAcc (Fold1 $ eltType @a) -- foldSeg' :: forall sh a i. - (Shape sh, Elt a, Elt i, IsIntegral i, i ~ EltRepr i) + (Shape sh, Elt a, Elt i, IsIntegral i, i ~ EltR i) => (Exp a -> Exp a -> Exp a) -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Segments i) -> Acc (Array (sh:.Int) a) -foldSeg' = Acc $$$$ applyAcc (FoldSeg (integralType @i) (eltType @a)) +foldSeg' = Acc $$$$ applyAcc (FoldSeg (integralType @i) (eltR @a)) -- | Variant of 'foldSeg'' that requires /all/ segments of the reduced -- array to be non-empty, and doesn't need a default value. The segment @@ -578,12 +576,12 @@ foldSeg' = Acc $$$$ applyAcc (FoldSeg (integralType @i) (eltType @a)) -- fold1Seg' :: forall sh a i. - (Shape sh, Elt a, Elt i, IsIntegral i, i ~ EltRepr i) + (Shape sh, Elt a, Elt i, IsIntegral i, i ~ EltR i) => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Segments i) -> Acc (Array (sh:.Int) a) -fold1Seg' = Acc $$$ applyAcc (Fold1Seg (integralType @i) (eltType @a)) +fold1Seg' = Acc $$$ applyAcc (Fold1Seg (integralType @i) (eltR @a)) -- Scan functions -- -------------- @@ -611,7 +609,7 @@ scanl :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanl = Acc $$$ applyAcc (Scanl $ eltType @a) +scanl = Acc $$$ applyAcc (Scanl $ eltR @a) -- | Variant of 'scanl', where the last element (final reduction result) along -- each dimension is returned separately. Denotationally we have: @@ -645,7 +643,7 @@ scanl' :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a, Array sh a) -scanl' = Acc . mkPairToTuple $$$ applyAcc (Scanl' $ eltType @a) +scanl' = Acc . mkPairToTuple $$$ applyAcc (Scanl' $ eltR @a) -- | 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 @@ -664,7 +662,7 @@ scanl1 :: forall sh a. => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanl1 = Acc $$ applyAcc (Scanl1 $ eltType @a) +scanl1 = Acc $$ applyAcc (Scanl1 $ eltR @a) -- | Right-to-left variant of 'scanl'. -- @@ -674,7 +672,7 @@ scanr :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanr = Acc $$$ applyAcc (Scanr $ eltType @a) +scanr = Acc $$$ applyAcc (Scanr $ eltR @a) -- | Right-to-left variant of 'scanl''. -- @@ -684,7 +682,7 @@ scanr' :: forall sh a. -> Exp a -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a, Array sh a) -scanr' = Acc . mkPairToTuple $$$ applyAcc (Scanr' $ eltType @a) +scanr' = Acc . mkPairToTuple $$$ applyAcc (Scanr' $ eltR @a) -- | Right-to-left variant of 'scanl1'. -- @@ -693,7 +691,7 @@ scanr1 :: forall sh a. => (Exp a -> Exp a -> Exp a) -> Acc (Array (sh:.Int) a) -> Acc (Array (sh:.Int) a) -scanr1 = Acc $$ applyAcc (Scanr1 $ eltType @a) +scanr1 = Acc $$ applyAcc (Scanr1 $ eltR @a) -- Permutations -- ------------ @@ -964,7 +962,7 @@ stencil stencil f (Boundary b) (Acc a) = Acc $ SmartAcc $ Stencil (stencilR @sh @a @stencil) - (eltType @b) + (eltR @b) (unExp . f . stencilPrj @sh @a @stencil) b a @@ -986,7 +984,7 @@ stencil2 f (Boundary b1) (Acc a1) (Boundary b2) (Acc a2) = Acc $ SmartAcc $ Stencil2 (stencilR @sh @a @stencil1) (stencilR @sh @b @stencil2) - (eltType @c) + (eltR @c) (\x y -> unExp $ f (stencilPrj @sh @a @stencil1 x) (stencilPrj @sh @b @stencil2 y)) b1 a1 @@ -1070,7 +1068,7 @@ function -> Boundary (Array sh e) function f = Boundary $ Function (f') where - f' :: SmartExp (EltRepr sh) -> SmartExp (EltRepr e) + f' :: SmartExp (EltR sh) -> SmartExp (EltR e) f' = unExp . f . Exp @@ -1198,11 +1196,11 @@ collect = Acc . Collect -- foreignAcc :: forall as bs asm. (Arrays as, Arrays bs, Foreign asm) - => asm (ArrRepr as -> ArrRepr bs) + => asm (ArraysR as -> ArraysR bs) -> (Acc as -> Acc bs) -> Acc as -> Acc bs -foreignAcc asm f (Acc as) = Acc $ SmartAcc $ Aforeign (arrays @bs) asm (unAccFunction f) as +foreignAcc asm f (Acc as) = Acc $ SmartAcc $ Aforeign (arraysR @bs) asm (unAccFunction f) as -- | Call a foreign scalar expression. -- @@ -1216,11 +1214,11 @@ foreignAcc asm f (Acc as) = Acc $ SmartAcc $ Aforeign (arrays @bs) asm (unAccFun -- foreignExp :: forall x y asm. (Elt x, Elt y, Foreign asm) - => asm (EltRepr x -> EltRepr y) + => asm (EltR x -> EltR y) -> (Exp x -> Exp y) -> Exp x -> Exp y -foreignExp a f (Exp x) = mkExp $ Foreign (eltType @y) a (unExpFunction f) x +foreignExp a f (Exp x) = mkExp $ Foreign (eltR @y) a (unExpFunction f) x -- Composition of array computations @@ -1240,7 +1238,7 @@ foreignExp a f (Exp x) = mkExp $ Foreign (eltType @y) a (unExpFunction f) x -- infixl 1 >-> (>->) :: forall a b c. (Arrays a, Arrays b, Arrays c) => (Acc a -> Acc b) -> (Acc b -> Acc c) -> (Acc a -> Acc c) -(>->) = Acc $$$ applyAcc $ Pipe (arrays @a) (arrays @b) (arrays @c) +(>->) = Acc $$$ applyAcc $ Pipe (arraysR @a) (arraysR @b) (arraysR @c) -- Flow control constructs @@ -1267,7 +1265,7 @@ awhile :: forall a. Arrays a -> (Acc a -> Acc a) -- ^ function to apply -> Acc a -- ^ initial value -> Acc a -awhile = Acc $$$ applyAcc $ Awhile $ arrays @a +awhile = Acc $$$ applyAcc $ Awhile $ arraysR @a -- Shapes and indices @@ -1291,27 +1289,27 @@ fromIndex (Exp sh) (Exp e) = mkExp $ FromIndex (shapeR @sh) sh e -- | Intersection of two shapes -- intersect :: forall sh. Shape sh => Exp sh -> Exp sh -> Exp sh -intersect (Exp x) (Exp y) = Exp $ intersect' (shapeR @sh) x y - -intersect' :: Repr.ShapeR sh -> SmartExp sh -> SmartExp sh -> SmartExp sh -intersect' Repr.ShapeRz _ _ = SmartExp Nil -intersect' (Repr.ShapeRsnoc shr) (unPair -> (xs, x)) (unPair -> (ys, y)) - = SmartExp - $ intersect' shr xs ys `Pair` - SmartExp (PrimApp (PrimMin singleType) $ SmartExp $ Pair x y) +intersect (Exp shx) (Exp shy) = Exp $ intersect' (shapeR @sh) shx shy + where + intersect' :: ShapeR t -> SmartExp t -> SmartExp t -> SmartExp t + intersect' ShapeRz _ _ = SmartExp Nil + intersect' (ShapeRsnoc shR) (unPair -> (xs, x)) (unPair -> (ys, y)) + = SmartExp + $ intersect' shR xs ys `Pair` + SmartExp (PrimApp (PrimMin singleType) $ SmartExp $ Pair x y) -- | Union of two shapes -- union :: forall sh. Shape sh => Exp sh -> Exp sh -> Exp sh -union (Exp x) (Exp y) = Exp $ union' (shapeR @sh) x y - -union' :: Repr.ShapeR sh -> SmartExp sh -> SmartExp sh -> SmartExp sh -union' Repr.ShapeRz _ _ = SmartExp Nil -union' (Repr.ShapeRsnoc shr) (unPair -> (xs, x)) (unPair -> (ys, y)) - = SmartExp - $ union' shr xs ys `Pair` - SmartExp (PrimApp (PrimMax singleType) $ SmartExp $ Pair x y) +union (Exp shx) (Exp shy) = Exp $ union' (shapeR @sh) shx shy + where + union' :: ShapeR t -> SmartExp t -> SmartExp t -> SmartExp t + union' ShapeRz _ _ = SmartExp Nil + union' (ShapeRsnoc shR) (unPair -> (xs, x)) (unPair -> (ys, y)) + = SmartExp + $ union' shR xs ys `Pair` + SmartExp (PrimApp (PrimMax singleType) $ SmartExp $ Pair x y) -- Flow-control @@ -1338,9 +1336,9 @@ while :: forall e. Elt e -> Exp e -- ^ initial value -> Exp e #if __GLASGOW_HASKELL__ < 804 -while c f (Exp e) = mkExp $ While @SmartAcc @SmartExp @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e +while c f (Exp e) = mkExp $ While @SmartAcc @SmartExp @(EltR e) (eltR @e) (unExp . c . Exp) (unExp . f . Exp) e #else -while c f (Exp e) = mkExp $ While @(EltRepr e) (eltType @e) (unExp . c . Exp) (unExp . f . Exp) e +while c f (Exp e) = mkExp $ While @(EltR e) (eltR @e) (unExp . c . Exp) (unExp . f . Exp) e #endif @@ -1364,7 +1362,7 @@ while c f (Exp e) = mkExp $ While @(EltRepr e) (eltType @e) -- infixl 9 ! (!) :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Exp sh -> Exp e -Acc a ! Exp ix = mkExp $ Index (eltType @e) a ix +Acc a ! Exp ix = mkExp $ Index (eltR @e) a ix -- | Extract the value from an array at the specified linear index. -- Multidimensional arrays in Accelerate are stored in row-major order with @@ -1384,7 +1382,7 @@ Acc a ! Exp ix = mkExp $ Index (eltType @e) a ix -- infixl 9 !! (!!) :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Exp Int -> Exp e -Acc a !! Exp ix = mkExp $ LinearIndex (eltType @e) a ix +Acc a !! Exp ix = mkExp $ LinearIndex (eltR @e) a ix -- | Extract the shape (extent) of an array. -- @@ -1507,7 +1505,7 @@ boolToInt = mkBoolToInt -- same bit size. -- bitcast - :: (Elt a, Elt b, IsScalar (EltRepr a), IsScalar (EltRepr b), BitSizeEq (EltRepr a) (EltRepr b)) + :: (Elt a, Elt b, IsScalar (EltR a), IsScalar (EltR b), BitSizeEq (EltR a) (EltR b)) => Exp a -> Exp b bitcast = mkBitcast @@ -1519,5 +1517,5 @@ bitcast = mkBitcast -- | Magic index identifying elements that are ignored in a forward permutation. -- ignore :: Shape sh => Exp sh -ignore = constant Sugar.ignore +ignore = constant S.ignore diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 5a5cdfca6..153d1c63f 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -38,9 +38,12 @@ module Data.Array.Accelerate.Lift ( ) where -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Array +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape import Data.Array.Accelerate.Type import Language.Haskell.TH hiding ( Exp ) @@ -181,8 +184,8 @@ instance (Shape sh, Elt (Any sh)) => Lift Exp (Any sh) where -- --------------------------- {-# INLINE expConst #-} -expConst :: forall e. Elt e => IsScalar (EltRepr e) => e -> Exp e -expConst = Exp . SmartExp . Const (scalarType @(EltRepr e)) . fromElt +expConst :: forall e. Elt e => IsScalar (EltR e) => e -> Exp e +expConst = Exp . SmartExp . Const (scalarType @(EltR e)) . fromElt instance Lift Exp Int where type Plain Int = Int @@ -319,7 +322,7 @@ instance (Shape sh, Elt e) => Lift Acc (Array sh e) where -- Lift and Unlift instances for tuples -- -$(runQ $ do +runQ $ do let mkInstances :: Name -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] mkInstances con cst smart prj nil pair n = do @@ -356,5 +359,4 @@ $(runQ $ do as <- mapM mkAccInstances [2..16] es <- mapM mkExpInstances [2..16] return $ concat (as ++ es) - ) diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 52026b41f..71b1d9011 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -12,9 +12,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ <= 800 -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif -- | -- Module : Data.Array.Accelerate.Pattern -- Copyright : [2018..2019] The Accelerate Team @@ -40,10 +37,15 @@ module Data.Array.Accelerate.Pattern ( ) where -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Array.Representation ( VecR(..) ) +import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Representation.Vec +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape +import Data.Array.Accelerate.Sugar.Array +import Data.Array.Accelerate.Sugar.Vec import Data.Array.Accelerate.Type +import Data.Primitive.Vec import Language.Haskell.TH hiding ( Exp ) import Language.Haskell.TH.Extra @@ -96,10 +98,10 @@ newtype VecPattern a = VecPattern a -- (unremarkable) boilerplate for us, but since the implementation is a little -- tricky it is debatable whether or not this is a good idea... -- -$(runQ $ do +runQ $ do let -- Generate instance declarations for IsPattern of the form: - -- instance (Elt x, EltRepr x ~ (((), EltRepr a), EltRepr b), Elt a, Elt b,) => IsPattern Exp x (Exp a, Exp b) + -- instance (Elt x, EltR x ~ (((), EltR a), EltR b), Elt a, Elt b,) => IsPattern Exp x (Exp a, Exp b) mkIsPattern :: Name -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] mkIsPattern con cst repr smart prj nil pair n = do a <- newName "a" @@ -108,7 +110,7 @@ $(runQ $ do xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] -- Last argument to `IsPattern`, eg (Exp, a, Exp b) in the example b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs - -- Representation as snoc-list of pairs, eg (((), EltRepr a), EltRepr b) + -- Representation as snoc-list of pairs, eg (((), EltR a), EltR b) snoc = foldl (\sn t -> [t| ($sn, $(appT repr $ varT t)) |]) [t| () |] xs -- Constraints for the type class, consisting of Elt constraints on all type variables, -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`. @@ -133,7 +135,7 @@ $(runQ $ do mkVecPattern n = do a <- newName "a" let - v = foldr appE [| VecRnil (singleType @(EltRepr $(varT a))) |] (replicate n [| VecRsucc |]) + v = foldr appE [| VecRnil (singleType @(EltR $(varT a))) |] (replicate n [| VecRsucc |]) r = tupT (replicate n [t| Exp $(varT a) |]) t = tupT (replicate n (varT a)) -- @@ -144,14 +146,14 @@ $(runQ $ do destruct (Exp x) = VecPattern (destruct (Exp (SmartExp (VecUnpack $v x)) :: Exp $t)) |] - mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [t| EltRepr |] [| SmartExp |] [| Prj |] [| Nil |] [| Pair |] - mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [t| ArrRepr |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] + mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [t| EltR |] [| SmartExp |] [| Prj |] [| Nil |] [| Pair |] + mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [t| ArraysR |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] -- es <- mapM mkExpPattern [0..16] as <- mapM mkAccPattern [0..16] vs <- mapM mkVecPattern [2,3,4,8,16] return $ concat (es ++ as ++ vs) - ) + -- | Specialised pattern synonyms for tuples, which may be more convenient to -- use than 'Data.Array.Accelerate.Lift.lift' and @@ -173,7 +175,7 @@ $(runQ $ do -- > let ix = Ix 2 3 -- :: Exp DIM2 -- > let I2 y x = ix -- y :: Exp Int, x :: Exp Int -- -$(runQ $ do +runQ $ do let mkT :: Int -> Q [Dec] mkT n = @@ -226,5 +228,4 @@ $(runQ $ do is <- mapM mkI [0..9] vs <- mapM mkV [2,3,4,8,16] return $ concat (ts ++ is ++ vs) - ) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 5cb57836e..16b56d2bd 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -117,22 +117,14 @@ module Data.Array.Accelerate.Prelude ( ) where --- avoid clashes with Prelude functions --- -import Control.Lens ( Lens', (&), (^.), (.~), (+~), (-~), lens, over ) -import GHC.Base ( Constraint ) -import Prelude ( (.), ($), Maybe(..), const, id, flip ) -#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.Pattern import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Array ( Arrays, Array, Scalar, Vector, Segments, fromList ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape ( Shape, Slice, Z(..), (:.)(..), All(..), DIM1, DIM2, empty ) import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Eq @@ -143,6 +135,11 @@ import Data.Array.Accelerate.Classes.Ord import Data.Array.Accelerate.Data.Bits +import Control.Lens ( Lens', (&), (^.), (.~), (+~), (-~), lens, over ) +import GHC.Base ( Constraint ) +import Prelude ( (.), ($), Maybe(..), const, id, flip ) + + -- $setup -- >>> :seti -XFlexibleContexts -- >>> import Data.Array.Accelerate @@ -707,7 +704,7 @@ fold1All f arr = fold1 f (flatten arr) -- 40, 170, 0, 138] -- foldSeg - :: forall sh e i. (Shape sh, Elt e, Elt i, i ~ EltRepr i, IsIntegral i) + :: forall sh e i. (Shape sh, Elt e, Elt i, i ~ EltR i, IsIntegral i) => (Exp e -> Exp e -> Exp e) -> Exp e -> Acc (Array (sh:.Int) e) @@ -734,7 +731,7 @@ foldSeg f z arr seg = foldSeg' f z arr (scanl plus zero seg) -- descriptor species the length of each of the logical sub-arrays. -- fold1Seg - :: forall sh e i. (Shape sh, Elt e, Elt i, i ~ EltRepr i, IsIntegral i) + :: forall sh e i. (Shape sh, Elt e, Elt i, i ~ EltR i, IsIntegral i) => (Exp e -> Exp e -> Exp e) -> Acc (Array (sh:.Int) e) -> Acc (Segments i) @@ -744,7 +741,7 @@ fold1Seg f arr seg = fold1Seg' f arr (scanl plus zero seg) plus :: Exp i -> Exp i -> Exp i zero :: Exp i (plus, zero) = - case integralType @(EltRepr i) of + case integralType @(EltR i) of TypeInt{} -> ((+), 0) TypeInt8{} -> ((+), 0) TypeInt16{} -> ((+), 0) diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index b5b32a97b..a1f19b938 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -34,7 +34,16 @@ module Data.Array.Accelerate.Pretty ( ) where --- libraries +import Data.Array.Accelerate.Smart ( Acc, Exp ) +import Data.Array.Accelerate.AST hiding ( Acc, Exp ) +import Data.Array.Accelerate.Sugar.Array +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Pretty.Print hiding ( Keyword(..) ) +import Data.Array.Accelerate.Trafo.Delayed +import Data.Array.Accelerate.Trafo.Sharing +import Data.Array.Accelerate.Pretty.Graphviz + import Data.Maybe import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String @@ -46,15 +55,6 @@ import qualified Data.Text.Lazy as T import qualified System.Console.ANSI as Term import qualified System.Console.Terminal.Size as Term --- friends -import Data.Array.Accelerate.Smart ( Acc, Exp ) -import Data.Array.Accelerate.AST hiding ( Acc, Exp, Val(..) ) -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.Pretty.Print hiding ( Keyword(..) ) -import Data.Array.Accelerate.Trafo -import Data.Array.Accelerate.Pretty.Graphviz - #if ACCELERATE_DEBUG import Control.DeepSeq import Data.Array.Accelerate.Debug.Flags diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 3533a6472..33fb03d79 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -29,7 +29,22 @@ module Data.Array.Accelerate.Pretty.Graphviz ( ) where --- standard libraries +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Pretty.Graphviz.Monad +import Data.Array.Accelerate.Pretty.Graphviz.Type +import Data.Array.Accelerate.Pretty.Print hiding ( Keyword(..) ) +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Sugar.Foreign +import Data.Array.Accelerate.Trafo.Delayed +import Data.Array.Accelerate.Trafo.Substitution + import Control.Applicative hiding ( Const, empty ) import Control.Arrow ( (&&&) ) import Control.Monad.State ( modify, gets, state ) @@ -43,16 +58,6 @@ import Prelude hiding ( exp ) import qualified Data.HashSet as Set import qualified Data.Sequence as Seq --- friends -import Data.Array.Accelerate.AST hiding ( Val(..), prj ) -import Data.Array.Accelerate.Array.Representation -import Data.Array.Accelerate.Array.Sugar ( strForeign ) -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.Pretty.Graphviz.Monad -import Data.Array.Accelerate.Pretty.Graphviz.Type -import Data.Array.Accelerate.Pretty.Print hiding ( Keyword(..) ) -import Data.Array.Accelerate.Trafo.Base - -- Configuration options -- --------------------- @@ -250,9 +255,9 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = Permute f dfts p xs -> "permute" .$ [ ppF f, ppA dfts, ppF p, ppA xs ] Backpermute _ sh p xs -> "backpermute" .$ [ ppE sh, ppF p, ppA xs ] Stencil s _ sten bndy xs - -> "stencil" .$ [ ppF sten, ppB (stencilElt s) bndy, ppA xs ] + -> "stencil" .$ [ ppF sten, ppB (stencilEltR s) bndy, ppA xs ] Stencil2 s1 s2 _ sten bndy1 acc1 bndy2 acc2 - -> "stencil2" .$ [ ppF sten, ppB (stencilElt s1) bndy1, ppA acc1, ppB (stencilElt s2) bndy2, ppA acc2 ] + -> "stencil2" .$ [ ppF sten, ppB (stencilEltR s1) bndy1, ppA acc1, ppB (stencilEltR s2) bndy2, ppA acc2 ] Aforeign _ ff _afun xs -> "aforeign" .$ [ return (PDoc (pretty (strForeign ff)) []), {- ppAf afun, -} ppA xs ] -- Collect{} -> error "Collect" @@ -307,14 +312,14 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = ppA (Delayed _ sh f _) | Shape a <- sh -- identical shape , Just b <- isIdentityIndexing f -- function is `\ix -> b ! ix` - , Just Refl <- match a b -- function thus is `\ix -> a ! ix` + , Just Refl <- matchVar a b -- function thus is `\ix -> a ! ix` = ppA $ Manifest $ Avar a ppA (Delayed _ sh f _) = do PDoc d v <- "Delayed" `fmt` [ ppE sh, ppF f ] return $ PDoc (parens d) v ppB :: forall sh e. - TupleType e + TypeR e -> Boundary aenv (Array sh e) -> Dot PDoc ppB _ Clamp = return (PDoc "clamp" []) diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index fee90733b..51cae25cb 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -51,17 +51,23 @@ module Data.Array.Accelerate.Pretty.Print ( ) where +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Sugar.Foreign +import Data.Array.Accelerate.Type + import Data.Char import Data.String import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal import Prelude hiding ( exp ) -import Data.Array.Accelerate.AST hiding ( Val(..), prj ) -import Data.Array.Accelerate.Array.Sugar ( strForeign ) -import Data.Array.Accelerate.Array.Representation -import Data.Array.Accelerate.Type - -- Implementation -- -------------- @@ -172,9 +178,9 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = Scanr1 f a -> "scanr1" .$ [ ppF f, ppA a ] Permute f d p s -> "permute" .$ [ ppF f, ppA d, ppF p, ppA s ] Backpermute _ sh f a -> "backpermute" .$ [ ppE sh, ppF f, ppA a ] - Stencil s _ f b a -> "stencil" .$ [ ppF f, ppB (stencilElt s) b, ppA a ] + Stencil s _ f b a -> "stencil" .$ [ ppF f, ppB (stencilEltR s) b, ppA a ] Stencil2 s1 s2 _ f b1 a1 b2 a2 - -> "stencil2" .$ [ ppF f, ppB (stencilElt s1) b1, ppA a1, ppB (stencilElt s2) b2, ppA a2 ] + -> "stencil2" .$ [ ppF f, ppB (stencilEltR s1) b1, ppA a1, ppB (stencilEltR s2) b2, ppA a2 ] where infixr 0 .$ f .$ xs @@ -194,7 +200,7 @@ prettyPreOpenAcc ctx prettyAcc extractAcc aenv pacc = ppF = parens . prettyOpenFun Empty aenv ppB :: forall sh e. - TupleType e + TypeR e -> Boundary aenv (Array sh e) -> Adoc ppB _ Clamp = "clamp" @@ -289,9 +295,9 @@ prettyLhs requiresParens x env0 lhs = case collect lhs of _ -> (env1, parensIf requiresParens (pretty 'T' <> pretty (length tup) <+> sep tup)) where ppPair :: LeftHandSide s arrs' env env'' -> (Val env'', Adoc) - ppPair (LeftHandSideWildcard TupRunit) = (env0, "()") - ppPair (LeftHandSideWildcard _) = (env0, "_") - ppPair (LeftHandSideSingle _) = (env0 `Push` v, v) + ppPair LeftHandSideUnit = (env0, "()") + ppPair LeftHandSideWildcard{} = (env0, "_") + ppPair LeftHandSideSingle{} = (env0 `Push` v, v) where v = pretty x <> pretty (sizeEnv env0) ppPair (LeftHandSidePair a b) = (env2, tupled [doc1, doc2]) @@ -307,7 +313,7 @@ prettyLhs requiresParens x env0 lhs = case collect lhs of collect _ = Nothing prettyArray :: ArrayR (Array sh e) -> Array sh e -> Adoc -prettyArray repr = parens . fromString . showArray repr +prettyArray aR@(ArrayR _ eR) = parens . fromString . showArray (showsElt eR) aR -- Scalar expressions @@ -424,7 +430,7 @@ prettyOpenExp ctx env aenv exp = $ sep [ opName op, x app, y app, z app ] withTypeRep :: ScalarType t -> Adoc -> Adoc - withTypeRep tp op = op <> enclose langle rangle (pretty (showScalarType tp)) + withTypeRep t op = op <> enclose langle rangle (pretty (show t)) prettyArrayVar :: forall aenv a. @@ -525,9 +531,9 @@ prettyAtuple prettyAcc extractAcc aenv0 acc = case collect acc of collect _ = Nothing -} -prettyConst :: TupleType e -> e -> Adoc +prettyConst :: TypeR e -> e -> Adoc prettyConst tp x = - let y = showElement tp x + let y = showElt tp x in parensIf (any isSpace y) (pretty y) prettyPrimConst :: PrimConst a -> Adoc diff --git a/src/Data/Array/Accelerate/Representation/Array.hs b/src/Data/Array/Accelerate/Representation/Array.hs new file mode 100644 index 000000000..10bea97e6 --- /dev/null +++ b/src/Data/Array/Accelerate/Representation/Array.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Representation.Array +-- Copyright : [2008..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Representation.Array + where + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Shape hiding ( zip ) +import Data.Array.Accelerate.Representation.Type + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import System.IO.Unsafe +import Text.Show ( showListWith ) +import Prelude hiding ( (!!) ) +import qualified Data.Vector.Unboxed as U + + +-- | Array data type, where the type arguments regard the representation +-- types of the shape and elements. +-- +data Array sh e where + Array :: sh -- extent of dimensions = shape + -> ArrayData e -- array payload + -> Array sh 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 = Vector + +type Scalar = Array DIM0 -- ^ A singleton array with one element +type Vector = Array DIM1 -- ^ A one-dimensional array +type Matrix = Array DIM2 -- ^ A two-dimensional array + +-- | Type witnesses shape and data layout of an array +-- +data ArrayR a where + ArrayR :: { arrayRshape :: ShapeR sh + , arrayRtype :: TypeR e + } + -> ArrayR (Array sh e) + +instance Show (ArrayR a) where + show (ArrayR shR eR) = "Array DIM" ++ show (rank shR) ++ " " ++ show eR + +type ArraysR = TupR ArrayR + +instance Show (TupR ArrayR e) where + show TupRunit = "()" + show (TupRsingle aR) = show aR + show (TupRpair aR1 aR2) = "(" ++ show aR1 ++ "," ++ show aR2 ++ ")" + +showArraysR :: ArraysR a -> ShowS +showArraysR = shows + +arraysRarray :: ShapeR sh -> TypeR e -> ArraysR (Array sh e) +arraysRarray shR eR = TupRsingle (ArrayR shR eR) + +arraysRpair :: ArrayR a -> ArrayR b -> ArraysR (((), a), b) +arraysRpair a b = TupRunit `TupRpair` TupRsingle a `TupRpair` TupRsingle b + +-- | Creates a new, uninitialized Accelerate array. +-- +allocateArray :: ArrayR (Array sh e) -> sh -> IO (Array sh e) +allocateArray (ArrayR shR eR) sh = do + adata <- newArrayData eR (size shR sh) + return $! Array sh adata + +-- | Create an array from its representation function, applied at each +-- index of the array. +-- +fromFunction :: ArrayR (Array sh e) -> sh -> (sh -> e) -> Array sh e +fromFunction repr sh f = unsafePerformIO $! fromFunctionM repr sh (return . f) + +-- | Create an array using a monadic function applied at each index. +-- +-- @since 1.2.0.0 +-- +fromFunctionM :: ArrayR (Array sh e) -> sh -> (sh -> IO e) -> IO (Array sh e) +fromFunctionM (ArrayR shR eR) sh f = do + let !n = size shR sh + arr <- newArrayData eR n + -- + let write !i + | i >= n = return () + | otherwise = do + v <- f (fromIndex shR sh i) + writeArrayData eR arr i v + write (i+1) + -- + write 0 + return $! arr `seq` Array sh arr + + +-- | Convert a list into an Accelerate 'Array' in dense row-major order. +-- +fromList :: forall sh e. ArrayR (Array sh e) -> sh -> [e] -> Array sh e +fromList (ArrayR shR eR) sh xs = adata `seq` Array 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 shR sh + (adata, _) = runArrayData @e $ do + arr <- newArrayData eR n + let go !i _ | i >= n = return () + go !i (v:vs) = writeArrayData eR arr i 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 :: ArrayR (Array sh e) -> Array sh e -> [e] +toList (ArrayR shR eR) (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 = size shR sh + go !i | i >= n = [] + | otherwise = indexArrayData eR adata i : go (i+1) + +concatVectors :: forall e. TypeR e -> [Vector e] -> Vector e +concatVectors tR vs = adata `seq` Array ((), len) adata + where + offsets = scanl (+) 0 (map (size dim1 . shape) vs) + len = last offsets + (adata, _) = runArrayData @e $ do + arr <- newArrayData tR len + sequence_ [ writeArrayData tR arr (i + k) (indexArrayData tR ad i) + | (Array ((), n) ad, k) <- vs `zip` offsets + , i <- [0 .. n - 1] ] + return (arr, undefined) + +shape :: Array sh e -> sh +shape (Array sh _) = sh + +reshape :: ShapeR sh -> sh -> ShapeR sh' -> Array sh' e -> Array sh e +reshape shR sh shR' (Array sh' adata) + = $boundsCheck "reshape" "shape mismatch" (size shR sh == size shR' sh') + $ Array sh adata + +(!) :: (ArrayR (Array sh e), Array sh e) -> sh -> e +(!) = uncurry indexArray + +(!!) :: (TypeR e, Array sh e) -> Int -> e +(!!) = uncurry linearIndexArray + +indexArray :: ArrayR (Array sh e) -> Array sh e -> sh -> e +indexArray (ArrayR shR adR) (Array sh adata) ix = indexArrayData adR adata (toIndex shR sh ix) + +linearIndexArray :: TypeR e -> Array sh e -> Int -> e +linearIndexArray adR (Array _ adata) = indexArrayData adR adata + +showArray :: (e -> ShowS) -> ArrayR (Array sh e) -> Array sh e -> String +showArray f arrR@(ArrayR shR _) arr@(Array sh _) = case shR of + ShapeRz -> "Scalar Z " ++ list + ShapeRsnoc ShapeRz -> "Vector (" ++ shapeString ++ ") " ++ list + ShapeRsnoc (ShapeRsnoc ShapeRz) -> "Matrix (" ++ shapeString ++ ") " ++ showMatrix f arrR arr + _ -> "Array (" ++ shapeString ++ ") " ++ list + where + shapeString = showShape shR sh + list = showListWith f (toList arrR arr) "" + +showArrayShort :: Int -> (e -> ShowS) -> ArrayR (Array sh e) -> Array sh e -> String +showArrayShort n f arrR arr = '[' : go 0 (toList arrR arr) + where + go _ [] = "]" + go i (x:xs) + | i >= n = " ..]" + | otherwise = ',' : f x (go (i+1) xs) + +-- 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. +-- +showMatrix :: (e -> ShowS) -> ArrayR (Array DIM2 e) -> Array DIM2 e -> String +showMatrix f (ArrayR _ arrR) arr@(Array sh _) + | rows * cols == 0 = "[]" + | otherwise = "\n [" ++ ppMat 0 0 + where + (((), rows), cols) = sh + lengths = U.generate (rows*cols) (\i -> length (f (linearIndexArray arrR arr i) "")) + widths = U.generate cols (\c -> U.maximum (U.generate rows (\r -> lengths U.! (r*cols+c)))) + -- + 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) ' ' ++ f (linearIndexArray arrR 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 + +reduceRank :: ArrayR (Array (sh, Int) e) -> ArrayR (Array sh e) +reduceRank (ArrayR (ShapeRsnoc shR) aeR) = ArrayR shR aeR + +rnfArray :: ArrayR a -> a -> () +rnfArray (ArrayR shR adR) (Array sh ad) = rnfShape shR sh `seq` rnfArrayData adR ad + +rnfArrayR :: ArrayR arr -> () +rnfArrayR (ArrayR shR tR) = rnfShapeR shR `seq` rnfTupR rnfScalarType tR + +rnfArraysR :: ArraysR arrs -> arrs -> () +rnfArraysR TupRunit () = () +rnfArraysR (TupRsingle arrR) arr = rnfArray arrR arr +rnfArraysR (TupRpair aR1 aR2) (a1,a2) = rnfArraysR aR1 a1 `seq` rnfArraysR aR2 a2 + +liftArrayR :: ArrayR a -> Q (TExp (ArrayR a)) +liftArrayR (ArrayR shR tR) = [|| ArrayR $$(liftShapeR shR) $$(liftTypeR tR) ||] + +liftArraysR :: ArraysR arrs -> Q (TExp (ArraysR arrs)) +liftArraysR TupRunit = [|| TupRunit ||] +liftArraysR (TupRsingle repr) = [|| TupRsingle $$(liftArrayR repr) ||] +liftArraysR (TupRpair a b) = [|| TupRpair $$(liftArraysR a) $$(liftArraysR b) ||] + +liftArray :: forall sh e. ArrayR (Array sh e) -> Array sh e -> Q (TExp (Array sh e)) +liftArray (ArrayR shR adR) (Array sh adata) = + [|| Array $$(liftElt (shapeType shR) sh) $$(liftArrayData sz adR adata) ||] `at` [t| Array $(liftTypeQ (shapeType shR)) $(liftTypeQ adR) |] + where + sz :: Int + sz = size shR sh + + at :: Q (TExp t) -> Q Type -> Q (TExp t) + at e t = unsafeTExpCoerce $ sigE (unTypeQ e) t + diff --git a/src/Data/Array/Accelerate/Representation/Elt.hs b/src/Data/Array/Accelerate/Representation/Elt.hs new file mode 100644 index 000000000..d3f14524f --- /dev/null +++ b/src/Data/Array/Accelerate/Representation/Elt.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Representation.Elt +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Representation.Elt + where + +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type +import Data.Primitive.Vec + +import Data.List ( intercalate ) +import Language.Haskell.TH + + +showElt :: TypeR e -> e -> String +showElt t v = showsElt t v "" + +showsElt :: TypeR e -> e -> ShowS +showsElt = tuple + where + tuple :: TypeR e -> e -> ShowS + tuple TupRunit () = showString "()" + tuple (TupRpair t1 t2) (e1, e2) = showString "(" . tuple t1 e1 . showString ", " . tuple t2 e2 . showString ")" + tuple (TupRsingle tp) val = scalar tp val + + scalar :: ScalarType e -> e -> ShowS + scalar (SingleScalarType t) e = showString $ single t e + scalar (VectorScalarType t) e = showString $ vector t e + + single :: SingleType e -> e -> String + single (NumSingleType t) e = num t e + single (NonNumSingleType t) e = nonnum t e + + num :: NumType e -> e -> String + num (IntegralNumType t) e = integral t e + num (FloatingNumType t) e = floating t e + + integral :: IntegralType e -> e -> String + integral TypeInt{} e = show e + integral TypeInt8{} e = show e + integral TypeInt16{} e = show e + integral TypeInt32{} e = show e + integral TypeInt64{} e = show e + integral TypeWord{} e = show e + integral TypeWord8{} e = show e + integral TypeWord16{} e = show e + integral TypeWord32{} e = show e + integral TypeWord64{} e = show e + + floating :: FloatingType e -> e -> String + floating TypeHalf{} e = show e + floating TypeFloat{} e = show e + floating TypeDouble{} e = show e + + nonnum :: NonNumType e -> e -> String + nonnum TypeChar e = show e + nonnum TypeBool e = show e + + vector :: VectorType (Vec n a) -> Vec n a -> String + vector (VectorType _ s) vec + | SingleDict <- singleDict s + = "<" ++ intercalate ", " (single s <$> listOfVec vec) ++ ">" + +liftElt :: TypeR t -> t -> Q (TExp t) +liftElt TupRunit () = [|| () ||] +liftElt (TupRsingle t) x = [|| $$(liftScalar t x) ||] +liftElt (TupRpair ta tb) (a,b) = [|| ($$(liftElt ta a), $$(liftElt tb b)) ||] + + diff --git a/src/Data/Array/Accelerate/Representation/Shape.hs b/src/Data/Array/Accelerate/Representation/Shape.hs new file mode 100644 index 000000000..feb6b99b3 --- /dev/null +++ b/src/Data/Array/Accelerate/Representation/Shape.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Representation.Shape +-- Copyright : [2008..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Representation.Shape + where + +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Representation.Type + +import Language.Haskell.TH +import Prelude hiding ( zip ) + +import GHC.Base ( quotInt, remInt ) + + +-- | Shape and index representations as nested pairs +-- +data ShapeR sh where + ShapeRz :: ShapeR () + ShapeRsnoc :: ShapeR sh -> ShapeR (sh, Int) + +-- | Nicely format a shape as a string +-- +showShape :: ShapeR sh -> sh -> String +showShape shr = foldr (\sh str -> str ++ " :. " ++ show sh) "Z" . shapeToList shr + +-- Synonyms for common shape types +-- +type DIM0 = () +type DIM1 = ((), Int) +type DIM2 = (((), Int), Int) + +dim0 :: ShapeR DIM0 +dim0 = ShapeRz + +dim1 :: ShapeR DIM1 +dim1 = ShapeRsnoc dim0 + +dim2 :: ShapeR DIM2 +dim2 = ShapeRsnoc dim1 + +-- | Number of dimensions of a /shape/ or /index/ (>= 0) +-- +rank :: ShapeR sh -> Int +rank ShapeRz = 0 +rank (ShapeRsnoc shr) = rank shr + 1 + +-- | Total number of elements in an array of the given shape +-- +size :: ShapeR sh -> sh -> Int +size ShapeRz () = 1 +size (ShapeRsnoc shr) (sh, sz) + | sz <= 0 = 0 + | otherwise = size shr sh * sz + +-- | The empty shape +-- +empty :: ShapeR sh -> sh +empty ShapeRz = () +empty (ShapeRsnoc shr) = (empty shr, 0) + +-- | Magic value identifying elements ignored in 'Data.Array.Accelerate.permute' +-- +ignore :: ShapeR sh -> sh +ignore ShapeRz = () +ignore (ShapeRsnoc shr) = (ignore shr, -1) + +-- | Yield the intersection of two shapes +-- +intersect :: ShapeR sh -> sh -> sh -> sh +intersect = zip min + +-- | Yield the union of two shapes +-- +union :: ShapeR sh -> sh -> sh -> sh +union = zip max + +zip :: (Int -> Int -> Int) -> ShapeR sh -> sh -> sh -> sh +zip _ ShapeRz () () = () +zip f (ShapeRsnoc shr) (as, a) (bs, b) = (zip f shr as bs, f a b) + +eq :: ShapeR sh -> sh -> sh -> Bool +eq ShapeRz () () = True +eq (ShapeRsnoc shr) (sh, i) (sh', i') = i == i' && eq shr 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 :: ShapeR sh -> sh -> sh -> Int +toIndex ShapeRz () () = 0 +toIndex (ShapeRsnoc shr) (sh, sz) (ix, i) + = $indexCheck "toIndex" i sz + $ toIndex shr sh ix * sz + i + +-- | Inverse of 'toIndex' +-- +fromIndex :: ShapeR sh -> sh -> Int -> sh +fromIndex ShapeRz () _ = () +fromIndex (ShapeRsnoc shr) (sh, sz) i + = (fromIndex shr 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 = case shr of -- Check if rank of shr is 0 + ShapeRz -> $indexCheck "fromIndex" i sz i + _ -> i `remInt` sz + +-- | 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 +-- +iter :: ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a -> a +iter ShapeRz () f _ _ = f () +iter (ShapeRsnoc shr) (sh, sz) f c r = iter shr sh (\ix -> iter' (ix,0)) c r + where + iter' (ix,i) | i >= sz = r + | otherwise = f (ix,i) `c` iter' (ix,i+1) + +-- | Variant of 'iter' without an initial value +-- +iter1 :: ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a +iter1 ShapeRz () f _ = f () +iter1 (ShapeRsnoc _ ) (_, 0) _ _ = $boundsError "iter1" "empty iteration space" +iter1 (ShapeRsnoc shr) (sh, sz) f c = iter1 shr 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) + +-- Operations to facilitate conversion with IArray + +-- | Convert a minpoint-maxpoint index into a shape +-- +rangeToShape :: ShapeR sh -> (sh, sh) -> sh +rangeToShape ShapeRz ((), ()) = () +rangeToShape (ShapeRsnoc shr) ((sh1, sz1), (sh2, sz2)) = (rangeToShape shr (sh1, sh2), sz2 - sz1 + 1) + +-- | Converse of 'rangeToShape' +-- +shapeToRange :: ShapeR sh -> sh -> (sh, sh) +shapeToRange ShapeRz () = ((), ()) +shapeToRange (ShapeRsnoc shr) (sh, sz) = let (low, high) = shapeToRange shr sh in ((low, 0), (high, sz - 1)) + +-- | Convert a shape or index into its list of dimensions +-- +shapeToList :: ShapeR sh -> sh -> [Int] +shapeToList ShapeRz () = [] +shapeToList (ShapeRsnoc shr) (sh,sz) = sz : shapeToList shr sh + +-- | Convert a list of dimensions into a shape +-- +listToShape :: ShapeR sh -> [Int] -> sh +listToShape shr ds = + case listToShape' shr ds of + Just sh -> sh + Nothing -> error "listToShape: unable to convert list to a shape at the specified type" + +-- | Attempt to convert a list of dimensions into a shape +-- +listToShape' :: ShapeR sh -> [Int] -> Maybe sh +listToShape' ShapeRz [] = Just () +listToShape' (ShapeRsnoc shr) (x:xs) = (, x) <$> listToShape' shr xs +listToShape' _ _ = Nothing + +shapeType :: ShapeR sh -> TypeR sh +shapeType ShapeRz = TupRunit +shapeType (ShapeRsnoc shr) = + shapeType shr + `TupRpair` + TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt))) + +rnfShape :: ShapeR sh -> sh -> () +rnfShape ShapeRz () = () +rnfShape (ShapeRsnoc shr) (sh, s) = s `seq` rnfShape shr sh + +rnfShapeR :: ShapeR sh -> () +rnfShapeR ShapeRz = () +rnfShapeR (ShapeRsnoc shr) = rnfShapeR shr + +liftShapeR :: ShapeR sh -> Q (TExp (ShapeR sh)) +liftShapeR ShapeRz = [|| ShapeRz ||] +liftShapeR (ShapeRsnoc sh) = [|| ShapeRsnoc $$(liftShapeR sh) ||] + diff --git a/src/Data/Array/Accelerate/Representation/Slice.hs b/src/Data/Array/Accelerate/Representation/Slice.hs new file mode 100644 index 000000000..0cad1dc1b --- /dev/null +++ b/src/Data/Array/Accelerate/Representation/Slice.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Representation.Slice +-- Copyright : [2008..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Representation.Slice + where + +import Data.Array.Accelerate.Representation.Shape + +import Language.Haskell.TH + + +-- | 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 + sliceIndex :: 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 @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 @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 + +sliceShapeR :: SliceIndex slix sl co dim -> ShapeR sl +sliceShapeR SliceNil = ShapeRz +sliceShapeR (SliceAll sl) = ShapeRsnoc $ sliceShapeR sl +sliceShapeR (SliceFixed sl) = sliceShapeR sl + +sliceDomainR :: SliceIndex slix sl co dim -> ShapeR dim +sliceDomainR SliceNil = ShapeRz +sliceDomainR (SliceAll sl) = ShapeRsnoc $ sliceDomainR sl +sliceDomainR (SliceFixed sl) = ShapeRsnoc $ sliceDomainR sl + +-- | Enumerate all slices within a given bound. The innermost dimension changes +-- most rapidly. +-- +-- See 'Data.Array.Accelerate.Sugar.Slice.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]] + +rnfSliceIndex :: SliceIndex ix slice co sh -> () +rnfSliceIndex SliceNil = () +rnfSliceIndex (SliceAll sh) = rnfSliceIndex sh +rnfSliceIndex (SliceFixed sh) = rnfSliceIndex sh + +liftSliceIndex :: SliceIndex ix slice co sh -> Q (TExp (SliceIndex ix slice co sh)) +liftSliceIndex SliceNil = [|| SliceNil ||] +liftSliceIndex (SliceAll rest) = [|| SliceAll $$(liftSliceIndex rest) ||] +liftSliceIndex (SliceFixed rest) = [|| SliceFixed $$(liftSliceIndex rest) ||] + diff --git a/src/Data/Array/Accelerate/Representation/Stencil.hs b/src/Data/Array/Accelerate/Representation/Stencil.hs new file mode 100644 index 000000000..1ab243807 --- /dev/null +++ b/src/Data/Array/Accelerate/Representation/Stencil.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Representation.Stencil +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Representation.Stencil ( + + -- ** Stencil patterns + StencilR(..), + stencilArrayR, + stencilR, stencilEltR, stencilShapeR, stencilHalo, + rnfStencilR, + liftStencilR, + +) where + +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Type + +import Language.Haskell.TH + + +-- | GADT reifying the 'Stencil' class +-- +data StencilR sh e pat where + StencilRunit3 :: TypeR e -> StencilR DIM1 e (Tup3 e e e) + StencilRunit5 :: TypeR e -> StencilR DIM1 e (Tup5 e e e e e) + StencilRunit7 :: TypeR e -> StencilR DIM1 e (Tup7 e e e e e e e) + StencilRunit9 :: TypeR e -> StencilR DIM1 e (Tup9 e e e e e e e e e) + + StencilRtup3 :: StencilR sh e pat1 + -> StencilR sh e pat2 + -> StencilR sh e pat3 + -> StencilR (sh, Int) e (Tup3 pat1 pat2 pat3) + + StencilRtup5 :: StencilR sh e pat1 + -> StencilR sh e pat2 + -> StencilR sh e pat3 + -> StencilR sh e pat4 + -> StencilR sh e pat5 + -> StencilR (sh, Int) e (Tup5 pat1 pat2 pat3 pat4 pat5) + + StencilRtup7 :: 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 (Tup7 pat1 pat2 pat3 pat4 pat5 pat6 pat7) + + StencilRtup9 :: 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 (Tup9 pat1 pat2 pat3 pat4 pat5 pat6 pat7 pat8 pat9) + +stencilEltR :: StencilR sh e pat -> TypeR e +stencilEltR (StencilRunit3 t) = t +stencilEltR (StencilRunit5 t) = t +stencilEltR (StencilRunit7 t) = t +stencilEltR (StencilRunit9 t) = t +stencilEltR (StencilRtup3 sR _ _) = stencilEltR sR +stencilEltR (StencilRtup5 sR _ _ _ _) = stencilEltR sR +stencilEltR (StencilRtup7 sR _ _ _ _ _ _) = stencilEltR sR +stencilEltR (StencilRtup9 sR _ _ _ _ _ _ _ _) = stencilEltR sR + +stencilShapeR :: StencilR sh e pat -> ShapeR sh +stencilShapeR (StencilRunit3 _) = ShapeRsnoc ShapeRz +stencilShapeR (StencilRunit5 _) = ShapeRsnoc ShapeRz +stencilShapeR (StencilRunit7 _) = ShapeRsnoc ShapeRz +stencilShapeR (StencilRunit9 _) = ShapeRsnoc ShapeRz +stencilShapeR (StencilRtup3 sR _ _) = ShapeRsnoc $ stencilShapeR sR +stencilShapeR (StencilRtup5 sR _ _ _ _) = ShapeRsnoc $ stencilShapeR sR +stencilShapeR (StencilRtup7 sR _ _ _ _ _ _) = ShapeRsnoc $ stencilShapeR sR +stencilShapeR (StencilRtup9 sR _ _ _ _ _ _ _ _) = ShapeRsnoc $ stencilShapeR sR + +stencilR :: StencilR sh e pat -> TypeR pat +stencilR (StencilRunit3 t) = tupR3 t t t +stencilR (StencilRunit5 t) = tupR5 t t t t t +stencilR (StencilRunit7 t) = tupR7 t t t t t t t +stencilR (StencilRunit9 t) = tupR9 t t t t t t t t t +stencilR (StencilRtup3 s1 s2 s3) = tupR3 (stencilR s1) (stencilR s2) (stencilR s3) +stencilR (StencilRtup5 s1 s2 s3 s4 s5) = tupR5 (stencilR s1) (stencilR s2) (stencilR s3) (stencilR s4) (stencilR s5) +stencilR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) = tupR7 (stencilR s1) (stencilR s2) (stencilR s3) (stencilR s4) (stencilR s5) (stencilR s6) (stencilR s7) +stencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) = tupR9 (stencilR s1) (stencilR s2) (stencilR s3) (stencilR s4) (stencilR s5) (stencilR s6) (stencilR s7) (stencilR s8) (stencilR s9) + +stencilArrayR :: StencilR sh e pat -> ArrayR (Array sh e) +stencilArrayR sR = ArrayR (stencilShapeR sR) (stencilEltR sR) + +-- XXX: This is incorrect: stencils are not required to be rectangular +-- +stencilHalo :: StencilR sh e stencil -> (ShapeR sh, sh) +stencilHalo = go' + where + go' :: StencilR sh e stencil -> (ShapeR sh, sh) + go' StencilRunit3{} = (dim1, ((), 1)) + go' StencilRunit5{} = (dim1, ((), 2)) + go' StencilRunit7{} = (dim1, ((), 3)) + go' StencilRunit9{} = (dim1, ((), 4)) + -- + go' (StencilRtup3 a b c ) = (ShapeRsnoc shR, cons shR 1 $ foldl1 (union shR) [a', go b, go c]) + where (shR, a') = go' a + go' (StencilRtup5 a b c d e ) = (ShapeRsnoc shR, cons shR 2 $ foldl1 (union shR) [a', go b, go c, go d, go e]) + where (shR, a') = go' a + go' (StencilRtup7 a b c d e f g ) = (ShapeRsnoc shR, cons shR 3 $ foldl1 (union shR) [a', go b, go c, go d, go e, go f, go g]) + where (shR, a') = go' a + go' (StencilRtup9 a b c d e f g h i) = (ShapeRsnoc shR, cons shR 4 $ foldl1 (union shR) [a', go b, go c, go d, go e, go f, go g, go h, go i]) + where (shR, a') = go' a + + go :: StencilR sh e stencil -> sh + go = snd . go' + + cons :: ShapeR sh -> Int -> sh -> (sh, Int) + cons ShapeRz ix () = ((), ix) + cons (ShapeRsnoc shr) ix (sh, sz) = (cons shr ix sh, sz) + +tupR3 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s (Tup3 t1 t2 t3) +tupR3 t1 t2 t3 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 + +tupR5 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s t4 -> TupR s t5 -> TupR s (Tup5 t1 t2 t3 t4 t5) +tupR5 t1 t2 t3 t4 t5 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 `TupRpair` t4 `TupRpair` t5 + +tupR7 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s t4 -> TupR s t5 -> TupR s t6 -> TupR s t7 -> TupR s (Tup7 t1 t2 t3 t4 t5 t6 t7) +tupR7 t1 t2 t3 t4 t5 t6 t7 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 `TupRpair` t4 `TupRpair` t5 `TupRpair` t6 `TupRpair` t7 + +tupR9 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s t4 -> TupR s t5 -> TupR s t6 -> TupR s t7 -> TupR s t8 -> TupR s t9 -> TupR s (Tup9 t1 t2 t3 t4 t5 t6 t7 t8 t9) +tupR9 t1 t2 t3 t4 t5 t6 t7 t8 t9 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 `TupRpair` t4 `TupRpair` t5 `TupRpair` t6 `TupRpair` t7 `TupRpair` t8 `TupRpair` t9 + +rnfStencilR :: StencilR sh e pat -> () +rnfStencilR (StencilRunit3 t) = rnfTypeR t +rnfStencilR (StencilRunit5 t) = rnfTypeR t +rnfStencilR (StencilRunit7 t) = rnfTypeR t +rnfStencilR (StencilRunit9 t) = rnfTypeR t +rnfStencilR (StencilRtup3 s1 s2 s3) = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 +rnfStencilR (StencilRtup5 s1 s2 s3 s4 s5) = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 +rnfStencilR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 `seq` rnfStencilR s6 `seq` rnfStencilR s7 +rnfStencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) = rnfStencilR s1 `seq` rnfStencilR s2 `seq` rnfStencilR s3 `seq` rnfStencilR s4 `seq` rnfStencilR s5 `seq` rnfStencilR s6 `seq` rnfStencilR s7 `seq` rnfStencilR s8 `seq` rnfStencilR s9 + +liftStencilR :: StencilR sh e pat -> Q (TExp (StencilR sh e pat)) +liftStencilR (StencilRunit3 tp) = [|| StencilRunit3 $$(liftTypeR tp) ||] +liftStencilR (StencilRunit5 tp) = [|| StencilRunit5 $$(liftTypeR tp) ||] +liftStencilR (StencilRunit7 tp) = [|| StencilRunit7 $$(liftTypeR tp) ||] +liftStencilR (StencilRunit9 tp) = [|| StencilRunit9 $$(liftTypeR tp) ||] +liftStencilR (StencilRtup3 s1 s2 s3) = [|| StencilRtup3 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) ||] +liftStencilR (StencilRtup5 s1 s2 s3 s4 s5) = [|| StencilRtup5 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) ||] +liftStencilR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) = [|| StencilRtup7 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) $$(liftStencilR s6) $$(liftStencilR s7) ||] +liftStencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) = [|| StencilRtup9 $$(liftStencilR s1) $$(liftStencilR s2) $$(liftStencilR s3) $$(liftStencilR s4) $$(liftStencilR s5) $$(liftStencilR s6) $$(liftStencilR s7) $$(liftStencilR s8) $$(liftStencilR s9) ||] + diff --git a/src/Data/Array/Accelerate/Representation/Type.hs b/src/Data/Array/Accelerate/Representation/Type.hs new file mode 100644 index 000000000..9e9ae3bd1 --- /dev/null +++ b/src/Data/Array/Accelerate/Representation/Type.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Representation.Type +-- Copyright : [2008..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Representation.Type + where + +import Data.Array.Accelerate.Type +import Data.Primitive.Vec + +import Language.Haskell.TH + + +-- | Both arrays (Acc) and expressions (Exp) are represented as nested +-- pairs consisting of: +-- +-- * unit (void) +-- +-- * pairs: representing compound values (i.e. tuples) where each component +-- will be stored in a separate array. +-- +-- * single array / scalar types +-- in case of expressions: 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. +-- +data TupR s a where + TupRunit :: TupR s () + TupRsingle :: s a -> TupR s a + TupRpair :: TupR s a -> TupR s b -> TupR s (a, b) + +instance Show (TupR ScalarType a) where + show TupRunit = "()" + show (TupRsingle t) = show t + show (TupRpair a b) = "(" ++ show a ++ "," ++ show b ++")" + +type TypeR = TupR ScalarType + +rnfTupR :: (forall b. s b -> ()) -> TupR s a -> () +rnfTupR _ TupRunit = () +rnfTupR f (TupRsingle s) = f s +rnfTupR f (TupRpair a b) = rnfTupR f a `seq` rnfTupR f b + +rnfTypeR :: TypeR t -> () +rnfTypeR = rnfTupR rnfScalarType + +liftTupR :: (forall b. s b -> Q (TExp (s b))) -> TupR s a -> Q (TExp (TupR s a)) +liftTupR _ TupRunit = [|| TupRunit ||] +liftTupR f (TupRsingle s) = [|| TupRsingle $$(f s) ||] +liftTupR f (TupRpair a b) = [|| TupRpair $$(liftTupR f a) $$(liftTupR f b) ||] + +liftTypeR :: TypeR t -> Q (TExp (TypeR t)) +liftTypeR TupRunit = [|| TupRunit ||] +liftTypeR (TupRsingle t) = [|| TupRsingle $$(liftScalarType t) ||] +liftTypeR (TupRpair ta tb) = [|| TupRpair $$(liftTypeR ta) $$(liftTypeR tb) ||] + +liftTypeQ :: TypeR t -> TypeQ +liftTypeQ = tuple + where + tuple :: TypeR t -> TypeQ + tuple TupRunit = [t| () |] + tuple (TupRpair t1 t2) = [t| ($(tuple t1), $(tuple t2)) |] + tuple (TupRsingle t) = scalar t + + scalar :: ScalarType t -> TypeQ + scalar (SingleScalarType t) = single t + scalar (VectorScalarType t) = vector t + + vector :: VectorType (Vec n a) -> TypeQ + vector (VectorType n t) = [t| Vec $(litT (numTyLit (toInteger n))) $(single t) |] + + single :: SingleType t -> TypeQ + single (NumSingleType t) = num t + single (NonNumSingleType t) = nonnum t + + nonnum :: NonNumType t -> TypeQ + nonnum TypeChar = [t| Char |] + nonnum TypeBool = [t| Bool |] + + num :: NumType t -> TypeQ + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + integral :: IntegralType t -> TypeQ + integral TypeInt = [t| Int |] + integral TypeInt8 = [t| Int8 |] + integral TypeInt16 = [t| Int16 |] + integral TypeInt32 = [t| Int32 |] + integral TypeInt64 = [t| Int64 |] + integral TypeWord = [t| Word |] + integral TypeWord8 = [t| Word8 |] + integral TypeWord16 = [t| Word16 |] + integral TypeWord32 = [t| Word32 |] + integral TypeWord64 = [t| Word64 |] + + floating :: FloatingType t -> TypeQ + floating TypeHalf = [t| Half |] + floating TypeFloat = [t| Float |] + floating TypeDouble = [t| Double |] + +runQ $ + let + mkT :: Int -> Q Dec + mkT n = + let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + rhs = foldl (\a b -> [t| ($a, $b) |]) [t| () |] ts + in + tySynD (mkName ("Tup" ++ show n)) (map plainTV xs) rhs + in + mapM mkT [2..16] + diff --git a/src/Data/Array/Accelerate/Representation/Vec.hs b/src/Data/Array/Accelerate/Representation/Vec.hs new file mode 100644 index 000000000..e10f25ce2 --- /dev/null +++ b/src/Data/Array/Accelerate/Representation/Vec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Representation.Vec +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Representation.Vec + where + +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Representation.Type +import Data.Primitive.Vec + +import Control.Monad.ST +import Data.Primitive.ByteArray +import Data.Primitive.Types +import Language.Haskell.TH + +import GHC.Base ( Int(..), Int#, (-#) ) +import GHC.TypeNats + + +-- | Declares the size of a SIMD vector and the type of its elements. This +-- data type is used to denote the relation between a vector type (Vec +-- n single) with its tuple representation (tuple). Conversions between +-- those types are exposed through 'pack' and 'unpack'. +-- +data VecR (n :: Nat) single tuple where + VecRnil :: SingleType s -> VecR 0 s () + VecRsucc :: VecR n s t -> VecR (n + 1) s (t, s) + +vecRvector :: KnownNat n => VecR n s tuple -> VectorType (Vec n s) +vecRvector = uncurry VectorType . go + where + go :: VecR n s tuple -> (Int, SingleType s) + go (VecRnil tp) = (0, tp) + go (VecRsucc vec) | (n, tp) <- go vec = (n + 1, tp) + +vecRtuple :: VecR n s tuple -> TypeR tuple +vecRtuple = snd . go + where + go :: VecR n s tuple -> (SingleType s, TypeR tuple) + go (VecRnil tp) = (tp, TupRunit) + go (VecRsucc vec) | (tp, tuple) <- go vec = (tp, TupRpair tuple (TupRsingle (SingleScalarType tp))) + +pack :: forall n single tuple. KnownNat n => VecR n single tuple -> tuple -> Vec n single +pack vecR tuple + | VectorType n single <- vecRvector vecR + , SingleDict <- singleDict single + = runST $ do + mba <- newByteArray (n * sizeOf (undefined :: single)) + go (n - 1) vecR tuple mba + ByteArray ba# <- unsafeFreezeByteArray mba + return $! Vec ba# + where + go :: Prim single => Int -> VecR n' single tuple' -> tuple' -> MutableByteArray s -> ST s () + go _ (VecRnil _) () _ = return () + go i (VecRsucc r) (xs, x) mba = do + writeByteArray mba i x + go (i - 1) r xs mba + +unpack :: forall n single tuple. KnownNat n => VecR n single tuple -> Vec n single -> tuple +unpack vecR (Vec ba#) + | VectorType n single <- vecRvector vecR + , (I# n#) <- n + , SingleDict <- singleDict single + = go (n# -# 1#) vecR + where + go :: Prim single => Int# -> VecR n' single tuple' -> tuple' + go _ (VecRnil _) = () + go i# (VecRsucc r) = x `seq` xs `seq` (xs, x) + where + xs = go (i# -# 1#) r + x = indexByteArray# ba# i# + +rnfVecR :: VecR n single tuple -> () +rnfVecR (VecRnil tp) = rnfSingleType tp +rnfVecR (VecRsucc vec) = rnfVecR vec + +liftVecR :: VecR n single tuple -> Q (TExp (VecR n single tuple)) +liftVecR (VecRnil tp) = [|| VecRnil $$(liftSingleType tp) ||] +liftVecR (VecRsucc vec) = [|| VecRsucc $$(liftVecR vec) ||] + diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index a3cb01122..4945519ce 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -27,16 +28,26 @@ module Data.Array.Accelerate.Smart ( -- * HOAS AST - Acc(..), SmartAcc(..), PreSmartAcc(..), PairIdx(..), Exp(..), SmartExp(..), PreSmartExp(..), - Boundary(..), PreBoundary(..), Stencil(..), Level, + -- ** Array computations + Acc(..), SmartAcc(..), PreSmartAcc(..), + Level, - -- * Smart constructors for literals + -- ** Scalar expressions + Exp(..), SmartExp(..), PreSmartExp(..), + Stencil(..), + Boundary(..), PreBoundary(..), + + -- ** Extracting type information + HasArraysR(..), + HasTypeR(..), + + -- ** Smart constructors for literals constant, undef, - -- * Smart destructors for shapes + -- ** Smart destructors for shapes indexHead, indexTail, - -- * Smart constructors for constants + -- ** Smart constructors for constants mkMinBound, mkMaxBound, mkPi, mkSin, mkCos, mkTan, mkAsin, mkAcos, mkAtan, @@ -47,39 +58,53 @@ module Data.Array.Accelerate.Smart ( mkTruncate, mkRound, mkFloor, mkCeiling, mkAtan2, - -- * Smart constructors for primitive functions + -- ** 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 + -- ** Smart constructors for type coercion functions mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkCoerce, Coerce, - -- * Auxiliary functions + -- ** Auxiliary functions ($$), ($$$), ($$$$), ($$$$$), - ApplyAcc(..), HasExpType(..), HasArraysRepr(..), + ApplyAcc(..), unAcc, unAccFunction, mkExp, unExp, unExpFunction, unPair, mkPairToTuple, - -- Debugging - showPreAccOp, showPreExpOp, + -- ** Miscellaneous + showPreAccOp, + showPreExpOp, ) where --- standard library -import Prelude hiding ( exp ) -import Data.Kind --- friends +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Representation.Slice +import Data.Array.Accelerate.Representation.Stencil hiding ( StencilR, stencilR ) +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Representation.Vec +import Data.Array.Accelerate.Sugar.Array ( Arrays ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Foreign +import Data.Array.Accelerate.Sugar.Shape ( (:.)(..) ) import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Array.Sugar (Elt, Arrays, EltRepr, ArrRepr, (:.), Foreign, eltType, fromElt, DIM1) -import qualified Data.Array.Accelerate.Array.Sugar as Sugar -import Data.Array.Accelerate.Array.Representation hiding (DIM1) -import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc - , OpenExp(..), Exp - , Boundary(..), HasArraysRepr(..), arrayRepr, expType - , showPreAccOp, showPreExpOp ) -import GHC.TypeNats +import qualified Data.Array.Accelerate.Representation.Stencil as R +import qualified Data.Array.Accelerate.Sugar.Array as Sugar +import qualified Data.Array.Accelerate.Sugar.Shape as Sugar + +import Data.Array.Accelerate.AST ( PrimFun(..), primFunType + , PrimConst(..), primConstType ) +import Data.Primitive.Vec + +import Data.Kind +import Prelude + +import GHC.TypeLits + -- Array computations -- ------------------ @@ -267,13 +292,14 @@ import GHC.TypeNats -- 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 (SmartAcc (ArrRepr a)) +newtype Acc a = Acc (SmartAcc (Sugar.ArraysR a)) newtype SmartAcc a = SmartAcc (PreSmartAcc SmartAcc SmartExp a) --- 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. +-- 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 @@ -325,7 +351,7 @@ data PreSmartAcc acc exp as where -> Array sh e -> PreSmartAcc acc exp (Array sh e) - Unit :: TupleType e + Unit :: TypeR e -> exp e -> PreSmartAcc acc exp (Scalar e) @@ -349,33 +375,33 @@ data PreSmartAcc acc exp as where -> exp slix -> PreSmartAcc acc exp (Array sl e) - Map :: TupleType e - -> TupleType e' + Map :: TypeR e + -> TypeR e' -> (SmartExp e -> exp e') -> acc (Array sh e) -> PreSmartAcc acc exp (Array sh e') - ZipWith :: TupleType e1 - -> TupleType e2 - -> TupleType e3 + ZipWith :: TypeR e1 + -> TypeR e2 + -> TypeR e3 -> (SmartExp e1 -> SmartExp e2 -> exp e3) -> acc (Array sh e1) -> acc (Array sh e2) -> PreSmartAcc acc exp (Array sh e3) - Fold :: TupleType e + Fold :: TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> exp e -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array sh e) - Fold1 :: TupleType e + Fold1 :: TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array sh e) FoldSeg :: IntegralType i - -> TupleType e + -> TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> exp e -> acc (Array (sh, Int) e) @@ -383,42 +409,42 @@ data PreSmartAcc acc exp as where -> PreSmartAcc acc exp (Array (sh, Int) e) Fold1Seg :: IntegralType i - -> TupleType e + -> TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> acc (Array (sh, Int) e) -> acc (Segments i) -> PreSmartAcc acc exp (Array (sh, Int) e) - Scanl :: TupleType e + Scanl :: TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> exp e -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array (sh, Int) e) - Scanl' :: TupleType e + Scanl' :: TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> exp e -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array (sh, Int) e, Array sh e) - Scanl1 :: TupleType e + Scanl1 :: TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array (sh, Int) e) - Scanr :: TupleType e + Scanr :: TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> exp e -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array (sh, Int) e) - Scanr' :: TupleType e + Scanr' :: TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> exp e -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array (sh, Int) e, Array sh e) - Scanr1 :: TupleType e + Scanr1 :: TypeR e -> (SmartExp e -> SmartExp e -> exp e) -> acc (Array (sh, Int) e) -> PreSmartAcc acc exp (Array (sh, Int) e) @@ -436,16 +462,16 @@ data PreSmartAcc acc exp as where -> acc (Array sh e) -> PreSmartAcc acc exp (Array sh' e) - Stencil :: StencilR sh a stencil - -> TupleType b + Stencil :: R.StencilR sh a stencil + -> TypeR b -> (SmartExp stencil -> exp b) -> PreBoundary acc exp (Array sh a) -> acc (Array sh a) -> PreSmartAcc acc exp (Array sh b) - Stencil2 :: StencilR sh a stencil1 - -> StencilR sh b stencil2 - -> TupleType c + Stencil2 :: R.StencilR sh a stencil1 + -> R.StencilR sh b stencil2 + -> TypeR c -> (SmartExp stencil1 -> SmartExp stencil2 -> exp c) -> PreBoundary acc exp (Array sh a) -> acc (Array sh a) @@ -453,178 +479,6 @@ data PreSmartAcc acc exp as where -> acc (Array sh b) -> PreSmartAcc acc exp (Array sh c) - -- Collect :: Arrays arrs - -- => seq arrs - -- -> PreSmartAcc acc seq exp arrs - -class HasArraysRepr f where - arraysRepr :: f a -> ArraysR a - -arrayRepr :: HasArraysRepr f => f (Array sh e) -> ArrayR (Array sh e) -arrayRepr acc = case arraysRepr acc of - TupRsingle repr -> repr - -instance HasArraysRepr acc => HasArraysRepr (PreSmartAcc acc exp) where - arraysRepr acc = case acc of - Atag repr _ -> repr - Pipe _ _ repr _ _ _ -> repr - Aforeign repr _ _ _ -> repr - Acond _ a _ -> arraysRepr a - Awhile _ _ _ a -> arraysRepr a - Anil -> TupRunit - Apair a1 a2 -> arraysRepr a1 `TupRpair` arraysRepr a2 - Aprj idx a | TupRpair t1 t2 <- arraysRepr a - -> case idx of - PairIdxLeft -> t1 - PairIdxRight -> t2 - Aprj _ _ -> error "Ejector seat? You're joking!" - Use repr _ -> TupRsingle repr - Unit tp _ -> TupRsingle $ ArrayR ShapeRz $ tp - Generate repr _ _ -> TupRsingle repr - Reshape shr _ a -> let ArrayR _ tp = arrayRepr a - in TupRsingle $ ArrayR shr tp - Replicate si _ a -> let ArrayR _ tp = arrayRepr a - in TupRsingle $ ArrayR (sliceDomainR si) tp - Slice si a _ -> let ArrayR _ tp = arrayRepr a - in TupRsingle $ ArrayR (sliceShapeR si) tp - Map _ tp _ a -> let ArrayR shr _ = arrayRepr a - in TupRsingle $ ArrayR shr tp - ZipWith _ _ tp _ a _ -> let ArrayR shr _ = arrayRepr a - in TupRsingle $ ArrayR shr tp - Fold _ _ _ a -> let ArrayR (ShapeRsnoc shr) tp = arrayRepr a - in TupRsingle (ArrayR shr tp) - Fold1 _ _ a -> let ArrayR (ShapeRsnoc shr) tp = arrayRepr a - in TupRsingle (ArrayR shr tp) - FoldSeg _ _ _ _ a _ -> arraysRepr a - Fold1Seg _ _ _ a _ -> arraysRepr a - Scanl _ _ _ a -> arraysRepr a - Scanl' _ _ _ a -> let repr@(ArrayR (ShapeRsnoc shr) tp) = arrayRepr a - in TupRsingle repr `TupRpair` TupRsingle (ArrayR shr tp) - Scanl1 _ _ a -> arraysRepr a - Scanr _ _ _ a -> arraysRepr a - Scanr' _ _ _ a -> let repr@(ArrayR (ShapeRsnoc shr) tp) = arrayRepr a - in TupRsingle repr `TupRpair` TupRsingle (ArrayR shr tp) - Scanr1 _ _ a -> arraysRepr a - Permute _ _ a _ _ -> arraysRepr a - Backpermute shr _ _ a -> let ArrayR _ tp = arrayRepr a - in TupRsingle (ArrayR shr tp) - Stencil s tp _ _ _ -> TupRsingle $ ArrayR (stencilShape s) tp - Stencil2 s _ tp _ _ _ _ _ -> TupRsingle $ ArrayR (stencilShape s) tp - -instance HasArraysRepr SmartAcc where - arraysRepr (SmartAcc e) = arraysRepr e - - -{-- -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 -- -------------------------------------------- @@ -642,7 +496,7 @@ deriving instance Typeable Seq -- efficiently on constrained hardware such as GPUs, and is thus currently -- unsupported. -- -newtype Exp t = Exp (SmartExp (EltRepr t)) +newtype Exp t = Exp (SmartExp (EltR t)) newtype SmartExp t = SmartExp (PreSmartExp SmartAcc SmartExp t) -- | Scalar expressions to parametrise collective array operations, themselves parameterised over @@ -650,7 +504,7 @@ newtype SmartExp t = SmartExp (PreSmartExp SmartAcc SmartExp t) -- data PreSmartExp acc exp t where -- Needed for conversion to de Bruijn form - Tag :: TupleType t + Tag :: TypeR t -> Level -- environment size at defining occurrence -> PreSmartExp acc exp t @@ -695,7 +549,7 @@ data PreSmartExp acc exp t where -> exp t -> PreSmartExp acc exp t - While :: TupleType t + While :: TypeR t -> (SmartExp t -> exp Bool) -> (SmartExp t -> exp t) -> exp t @@ -708,12 +562,12 @@ data PreSmartExp acc exp t where -> exp a -> PreSmartExp acc exp r - Index :: TupleType t + Index :: TypeR t -> acc (Array sh t) -> exp sh -> PreSmartExp acc exp t - LinearIndex :: TupleType t + LinearIndex :: TypeR t -> acc (Array sh t) -> exp Int -> PreSmartExp acc exp t @@ -727,7 +581,7 @@ data PreSmartExp acc exp t where -> PreSmartExp acc exp Int Foreign :: Foreign asm - => TupleType y + => TypeR y -> asm (x -> y) -> (SmartExp x -> SmartExp y) -- RCE: Using SmartExp instead of exp to aid in sharing recovery. -> exp x @@ -742,38 +596,6 @@ data PreSmartExp acc exp t where -> exp a -> PreSmartExp acc exp b -class HasExpType f where - expType :: f t -> TupleType t - -instance HasExpType exp => HasExpType (PreSmartExp acc exp) where - expType expr = case expr of - Tag tp _ -> tp - Const tp _ -> TupRsingle tp - Nil -> TupRunit - Pair e1 e2 -> expType e1 `TupRpair` expType e2 - Prj idx e | TupRpair t1 t2 <- expType e - -> case idx of - PairIdxLeft -> t1 - PairIdxRight -> t2 - Prj _ _ -> error "I never joke about my work" - VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR - VecUnpack vecR _ -> vecRtuple vecR - ToIndex _ _ _ -> TupRsingle $ scalarTypeInt - FromIndex shr _ _ -> shapeType shr - Cond _ e _ -> expType e - While t _ _ _ -> t - PrimConst c -> TupRsingle $ SingleScalarType $ primConstType c - PrimApp f _ -> snd $ primFunType f - Index tp _ _ -> tp - LinearIndex tp _ _ -> tp - Shape shr _ -> shapeType shr - ShapeSize _ _ -> TupRsingle $ scalarTypeInt - Foreign tp _ _ _ -> tp - Undef tp -> TupRsingle tp - Coerce _ tp _ -> TupRsingle tp - -instance HasExpType SmartExp where - expType (SmartExp e) = expType e -- Smart constructors for stencils -- ------------------------------- @@ -781,7 +603,7 @@ instance HasExpType SmartExp where -- | Boundary condition specification for stencil operations -- data Boundary t where - Boundary :: !(PreBoundary SmartAcc SmartExp (Array (EltRepr sh) (EltRepr e))) + Boundary :: PreBoundary SmartAcc SmartExp (Array (EltR sh) (EltR e)) -> Boundary (Sugar.Array sh e) data PreBoundary acc exp t where @@ -807,34 +629,34 @@ data PreBoundary acc exp t where -- tuple indices (i.e., projections). -- class Stencil sh e stencil where - type StencilRepr sh stencil :: Type + type StencilR sh stencil :: Type - stencilR :: StencilR (EltRepr sh) (EltRepr e) (StencilRepr sh stencil) - stencilPrj :: SmartExp (StencilRepr sh stencil) -> stencil + stencilR :: R.StencilR (EltR sh) (EltR e) (StencilR sh stencil) + stencilPrj :: SmartExp (StencilR 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) - = EltRepr (e, e, e) - stencilR = StencilRunit3 @(EltRepr e) $ eltType @e +instance Elt e => Stencil Sugar.DIM1 e (Exp e, Exp e, Exp e) where + type StencilR Sugar.DIM1 (Exp e, Exp e, Exp e) + = EltR (e, e, e) + stencilR = StencilRunit3 @(EltR e) $ eltR @e stencilPrj s = (Exp $ prj2 s, Exp $ prj1 s, Exp $ prj0 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) - = EltRepr (e, e, e, e, e) - stencilR = StencilRunit5 $ eltType @e +instance Elt e => Stencil Sugar.DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e) where + type StencilR Sugar.DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e) + = EltR (e, e, e, e, e) + stencilR = StencilRunit5 $ eltR @e stencilPrj s = (Exp $ prj4 s, Exp $ prj3 s, Exp $ prj2 s, Exp $ prj1 s, Exp $ prj0 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) - = EltRepr (e, e, e, e, e, e, e) - stencilR = StencilRunit7 $ eltType @e +instance Elt e => Stencil Sugar.DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) where + type StencilR Sugar.DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) + = EltR (e, e, e, e, e, e, e) + stencilR = StencilRunit7 $ eltR @e stencilPrj s = (Exp $ prj6 s, Exp $ prj5 s, Exp $ prj4 s, @@ -843,11 +665,11 @@ instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp Exp $ prj1 s, Exp $ prj0 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) +instance Elt e => Stencil Sugar.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) - = EltRepr (e, e, e, e, e, e, e, e, e) - stencilR = StencilRunit9 $ eltType @e + type StencilR Sugar.DIM1 (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp e) + = EltR (e, e, e, e, e, e, e, e, e) + stencilR = StencilRunit9 $ eltR @e stencilPrj s = (Exp $ prj8 s, Exp $ prj7 s, Exp $ prj6 s, @@ -862,8 +684,8 @@ instance Elt e => Stencil DIM1 e (Exp e, Exp e, Exp e, Exp e, Exp e, Exp e, Exp 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) - = Tup3 (StencilRepr (sh:.Int) row2) (StencilRepr (sh:.Int) row1) (StencilRepr (sh:.Int) row0) + type StencilR (sh:.Int:.Int) (row2, row1, row0) + = Tup3 (StencilR (sh:.Int) row2) (StencilR (sh:.Int) row1) (StencilR (sh:.Int) row0) stencilR = StencilRtup3 (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) stencilPrj s = (stencilPrj @(sh:.Int) @a $ prj2 s, stencilPrj @(sh:.Int) @a $ prj1 s, @@ -874,9 +696,9 @@ instance (Stencil (sh:.Int) a row4, Stencil (sh:.Int) a row2, Stencil (sh:.Int) a row1, Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row4, row3, row2, row1, row0) where - type StencilRepr (sh:.Int:.Int) (row4, row3, row2, row1, row0) - = Tup5 (StencilRepr (sh:.Int) row4) (StencilRepr (sh:.Int) row3) (StencilRepr (sh:.Int) row2) - (StencilRepr (sh:.Int) row1) (StencilRepr (sh:.Int) row0) + type StencilR (sh:.Int:.Int) (row4, row3, row2, row1, row0) + = Tup5 (StencilR (sh:.Int) row4) (StencilR (sh:.Int) row3) (StencilR (sh:.Int) row2) + (StencilR (sh:.Int) row1) (StencilR (sh:.Int) row0) stencilR = StencilRtup5 (stencilR @(sh:.Int) @a @row4) (stencilR @(sh:.Int) @a @row3) (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) stencilPrj s = (stencilPrj @(sh:.Int) @a $ prj4 s, @@ -893,10 +715,10 @@ instance (Stencil (sh:.Int) a row6, Stencil (sh:.Int) a row1, Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row6, row5, row4, row3, row2, row1, row0) where - type StencilRepr (sh:.Int:.Int) (row6, row5, row4, row3, row2, row1, row0) - = Tup7 (StencilRepr (sh:.Int) row6) (StencilRepr (sh:.Int) row5) (StencilRepr (sh:.Int) row4) - (StencilRepr (sh:.Int) row3) (StencilRepr (sh:.Int) row2) (StencilRepr (sh:.Int) row1) - (StencilRepr (sh:.Int) row0) + type StencilR (sh:.Int:.Int) (row6, row5, row4, row3, row2, row1, row0) + = Tup7 (StencilR (sh:.Int) row6) (StencilR (sh:.Int) row5) (StencilR (sh:.Int) row4) + (StencilR (sh:.Int) row3) (StencilR (sh:.Int) row2) (StencilR (sh:.Int) row1) + (StencilR (sh:.Int) row0) stencilR = StencilRtup7 (stencilR @(sh:.Int) @a @row6) (stencilR @(sh:.Int) @a @row5) (stencilR @(sh:.Int) @a @row4) (stencilR @(sh:.Int) @a @row3) (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) @@ -918,10 +740,10 @@ instance (Stencil (sh:.Int) a row8, Stencil (sh:.Int) a row1, Stencil (sh:.Int) a row0) => Stencil (sh:.Int:.Int) a (row8, row7, row6, row5, row4, row3, row2, row1, row0) where - type StencilRepr (sh:.Int:.Int) (row8, row7, row6, row5, row4, row3, row2, row1, row0) - = Tup9 (StencilRepr (sh:.Int) row8) (StencilRepr (sh:.Int) row7) (StencilRepr (sh:.Int) row6) - (StencilRepr (sh:.Int) row5) (StencilRepr (sh:.Int) row4) (StencilRepr (sh:.Int) row3) - (StencilRepr (sh:.Int) row2) (StencilRepr (sh:.Int) row1) (StencilRepr (sh:.Int) row0) + type StencilR (sh:.Int:.Int) (row8, row7, row6, row5, row4, row3, row2, row1, row0) + = Tup9 (StencilR (sh:.Int) row8) (StencilR (sh:.Int) row7) (StencilR (sh:.Int) row6) + (StencilR (sh:.Int) row5) (StencilR (sh:.Int) row4) (StencilR (sh:.Int) row3) + (StencilR (sh:.Int) row2) (StencilR (sh:.Int) row1) (StencilR (sh:.Int) row0) stencilR = StencilRtup9 (stencilR @(sh:.Int) @a @row8) (stencilR @(sh:.Int) @a @row7) (stencilR @(sh:.Int) @a @row6) (stencilR @(sh:.Int) @a @row5) (stencilR @(sh:.Int) @a @row4) (stencilR @(sh:.Int) @a @row3) @@ -967,8 +789,103 @@ prj8 :: SmartExp (((((((((t, a), s7), s6), s5), s4), s3), s2), s1), s0) -> Smart prj8 = prj7 . prjTail --- Smart constructor for literals --- +-- Extracting type information +-- --------------------------- + +class HasArraysR f where + arraysR :: f a -> ArraysR a + +instance HasArraysR SmartAcc where + arraysR (SmartAcc e) = arraysR e + +arrayR :: HasArraysR f => f (Array sh e) -> ArrayR (Array sh e) +arrayR acc = case arraysR acc of + TupRsingle repr -> repr + +instance HasArraysR acc => HasArraysR (PreSmartAcc acc exp) where + arraysR = \case + Atag repr _ -> repr + Pipe _ _ repr _ _ _ -> repr + Aforeign repr _ _ _ -> repr + Acond _ a _ -> arraysR a + Awhile _ _ _ a -> arraysR a + Anil -> TupRunit + Apair a1 a2 -> arraysR a1 `TupRpair` arraysR a2 + Aprj idx a | TupRpair t1 t2 <- arraysR a + -> case idx of + PairIdxLeft -> t1 + PairIdxRight -> t2 + Aprj _ _ -> error "Ejector seat? You're joking!" + Use repr _ -> TupRsingle repr + Unit tp _ -> TupRsingle $ ArrayR ShapeRz $ tp + Generate repr _ _ -> TupRsingle repr + Reshape shr _ a -> let ArrayR _ tp = arrayR a + in TupRsingle $ ArrayR shr tp + Replicate si _ a -> let ArrayR _ tp = arrayR a + in TupRsingle $ ArrayR (sliceDomainR si) tp + Slice si a _ -> let ArrayR _ tp = arrayR a + in TupRsingle $ ArrayR (sliceShapeR si) tp + Map _ tp _ a -> let ArrayR shr _ = arrayR a + in TupRsingle $ ArrayR shr tp + ZipWith _ _ tp _ a _ -> let ArrayR shr _ = arrayR a + in TupRsingle $ ArrayR shr tp + Fold _ _ _ a -> let ArrayR (ShapeRsnoc shr) tp = arrayR a + in TupRsingle (ArrayR shr tp) + Fold1 _ _ a -> let ArrayR (ShapeRsnoc shr) tp = arrayR a + in TupRsingle (ArrayR shr tp) + FoldSeg _ _ _ _ a _ -> arraysR a + Fold1Seg _ _ _ a _ -> arraysR a + Scanl _ _ _ a -> arraysR a + Scanl' _ _ _ a -> let repr@(ArrayR (ShapeRsnoc shr) tp) = arrayR a + in TupRsingle repr `TupRpair` TupRsingle (ArrayR shr tp) + Scanl1 _ _ a -> arraysR a + Scanr _ _ _ a -> arraysR a + Scanr' _ _ _ a -> let repr@(ArrayR (ShapeRsnoc shr) tp) = arrayR a + in TupRsingle repr `TupRpair` TupRsingle (ArrayR shr tp) + Scanr1 _ _ a -> arraysR a + Permute _ _ a _ _ -> arraysR a + Backpermute shr _ _ a -> let ArrayR _ tp = arrayR a + in TupRsingle (ArrayR shr tp) + Stencil s tp _ _ _ -> TupRsingle $ ArrayR (stencilShapeR s) tp + Stencil2 s _ tp _ _ _ _ _ -> TupRsingle $ ArrayR (stencilShapeR s) tp + + +class HasTypeR f where + typeR :: f t -> TypeR t + +instance HasTypeR SmartExp where + typeR (SmartExp e) = typeR e + +instance HasTypeR exp => HasTypeR (PreSmartExp acc exp) where + typeR = \case + Tag tp _ -> tp + Const tp _ -> TupRsingle tp + Nil -> TupRunit + Pair e1 e2 -> typeR e1 `TupRpair` typeR e2 + Prj idx e + | TupRpair t1 t2 <- typeR e -> case idx of + PairIdxLeft -> t1 + PairIdxRight -> t2 + Prj _ _ -> error "I never joke about my work" + VecPack vecR _ -> TupRsingle $ VectorScalarType $ vecRvector vecR + VecUnpack vecR _ -> vecRtuple vecR + ToIndex _ _ _ -> TupRsingle $ scalarTypeInt + FromIndex shr _ _ -> shapeType shr + Cond _ e _ -> typeR e + While t _ _ _ -> t + PrimConst c -> TupRsingle $ SingleScalarType $ primConstType c + PrimApp f _ -> snd $ primFunType f + Index tp _ _ -> tp + LinearIndex tp _ _ -> tp + Shape shr _ -> shapeType shr + ShapeSize _ _ -> TupRsingle $ scalarTypeInt + Foreign tp _ _ _ -> tp + Undef tp -> TupRsingle tp + Coerce _ tp _ -> TupRsingle tp + + +-- Smart constructors +-- ------------------ -- | Scalar expression inlet: make a Haskell value available for processing in -- an Accelerate scalar expression. @@ -983,9 +900,9 @@ prj8 = prj7 . prjTail -- change without the need to generate fresh code. -- constant :: forall e. Elt e => e -> Exp e -constant = Exp . go (eltType @e) . fromElt +constant = Exp . go (eltR @e) . fromElt where - go :: TupleType t -> t -> SmartExp t + go :: TypeR t -> t -> SmartExp t go TupRunit () = SmartExp $ Nil go (TupRsingle tp) c = SmartExp $ Const tp c go (TupRpair t1 t2) (c1, c2) = SmartExp $ go t1 c1 `Pair` go t2 c2 @@ -1014,9 +931,9 @@ constant = Exp . go (eltType @e) . fromElt -- @since 1.2.0.0 -- undef :: forall e. Elt e => Exp e -undef = Exp $ go $ eltType @e +undef = Exp $ go $ eltR @e where - go :: TupleType t -> SmartExp t + go :: TypeR t -> SmartExp t go TupRunit = SmartExp $ Nil go (TupRsingle t) = SmartExp $ Undef t go (TupRpair t1 t2) = SmartExp $ go t1 `Pair` go t2 @@ -1043,13 +960,13 @@ indexTail (Exp x) = mkExp $ Prj PairIdxLeft x -- Smart constructor for constants -- -mkMinBound :: (Elt t, IsBounded (EltRepr t)) => Exp t +mkMinBound :: (Elt t, IsBounded (EltR t)) => Exp t mkMinBound = mkExp $ PrimConst (PrimMinBound boundedType) -mkMaxBound :: (Elt t, IsBounded (EltRepr t)) => Exp t +mkMaxBound :: (Elt t, IsBounded (EltR t)) => Exp t mkMaxBound = mkExp $ PrimConst (PrimMaxBound boundedType) -mkPi :: (Elt r, IsFloating (EltRepr r)) => Exp r +mkPi :: (Elt r, IsFloating (EltR r)) => Exp r mkPi = mkExp $ PrimConst (PrimPi floatingType) @@ -1058,196 +975,196 @@ mkPi = mkExp $ PrimConst (PrimPi floatingType) -- Operators from Floating -mkSin :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkSin :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkSin = mkPrimUnary $ PrimSin floatingType -mkCos :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkCos :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkCos = mkPrimUnary $ PrimCos floatingType -mkTan :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkTan :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkTan = mkPrimUnary $ PrimTan floatingType -mkAsin :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAsin :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkAsin = mkPrimUnary $ PrimAsin floatingType -mkAcos :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAcos :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkAcos = mkPrimUnary $ PrimAcos floatingType -mkAtan :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAtan :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkAtan = mkPrimUnary $ PrimAtan floatingType -mkSinh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkSinh :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkSinh = mkPrimUnary $ PrimSinh floatingType -mkCosh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkCosh :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkCosh = mkPrimUnary $ PrimCosh floatingType -mkTanh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkTanh :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkTanh = mkPrimUnary $ PrimTanh floatingType -mkAsinh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAsinh :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkAsinh = mkPrimUnary $ PrimAsinh floatingType -mkAcosh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAcosh :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkAcosh = mkPrimUnary $ PrimAcosh floatingType -mkAtanh :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkAtanh :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkAtanh = mkPrimUnary $ PrimAtanh floatingType -mkExpFloating :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkExpFloating :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkExpFloating = mkPrimUnary $ PrimExpFloating floatingType -mkSqrt :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkSqrt :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkSqrt = mkPrimUnary $ PrimSqrt floatingType -mkLog :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkLog :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkLog = mkPrimUnary $ PrimLog floatingType -mkFPow :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t -> Exp t +mkFPow :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t -> Exp t mkFPow = mkPrimBinary $ PrimFPow floatingType -mkLogBase :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t -> Exp t +mkLogBase :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t -> Exp t mkLogBase = mkPrimBinary $ PrimLogBase floatingType -- Operators from Num -mkAdd :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t -> Exp t +mkAdd :: (Elt t, IsNum (EltR t)) => Exp t -> Exp t -> Exp t mkAdd = mkPrimBinary $ PrimAdd numType -mkSub :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t -> Exp t +mkSub :: (Elt t, IsNum (EltR t)) => Exp t -> Exp t -> Exp t mkSub = mkPrimBinary $ PrimSub numType -mkMul :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t -> Exp t +mkMul :: (Elt t, IsNum (EltR t)) => Exp t -> Exp t -> Exp t mkMul = mkPrimBinary $ PrimMul numType -mkNeg :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t +mkNeg :: (Elt t, IsNum (EltR t)) => Exp t -> Exp t mkNeg = mkPrimUnary $ PrimNeg numType -mkAbs :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t +mkAbs :: (Elt t, IsNum (EltR t)) => Exp t -> Exp t mkAbs = mkPrimUnary $ PrimAbs numType -mkSig :: (Elt t, IsNum (EltRepr t)) => Exp t -> Exp t +mkSig :: (Elt t, IsNum (EltR t)) => Exp t -> Exp t mkSig = mkPrimUnary $ PrimSig numType -- Operators from Integral -mkQuot :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkQuot :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t -> Exp t mkQuot = mkPrimBinary $ PrimQuot integralType -mkRem :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkRem :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t -> Exp t mkRem = mkPrimBinary $ PrimRem integralType -mkQuotRem :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> (Exp t, Exp t) +mkQuotRem :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t -> (Exp t, Exp t) mkQuotRem (Exp x) (Exp y) = let pair = SmartExp $ PrimQuotRem integralType `PrimApp` SmartExp (Pair x y) in (mkExp $ Prj PairIdxLeft pair, mkExp $ Prj PairIdxRight pair) -mkIDiv :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkIDiv :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t -> Exp t mkIDiv = mkPrimBinary $ PrimIDiv integralType -mkMod :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkMod :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t -> Exp t mkMod = mkPrimBinary $ PrimMod integralType -mkDivMod :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> (Exp t, Exp t) +mkDivMod :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t -> (Exp t, Exp t) mkDivMod (Exp x) (Exp y) = let pair = SmartExp $ PrimDivMod integralType `PrimApp` SmartExp (Pair x y) in (mkExp $ Prj PairIdxLeft pair, mkExp $ Prj PairIdxRight pair) -- Operators from Bits and FiniteBits -mkBAnd :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkBAnd :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t -> Exp t mkBAnd = mkPrimBinary $ PrimBAnd integralType -mkBOr :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkBOr :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t -> Exp t mkBOr = mkPrimBinary $ PrimBOr integralType -mkBXor :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t -> Exp t +mkBXor :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t -> Exp t mkBXor = mkPrimBinary $ PrimBXor integralType -mkBNot :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp t +mkBNot :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp t mkBNot = mkPrimUnary $ PrimBNot integralType -mkBShiftL :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +mkBShiftL :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t mkBShiftL = mkPrimBinary $ PrimBShiftL integralType -mkBShiftR :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +mkBShiftR :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t mkBShiftR = mkPrimBinary $ PrimBShiftR integralType -mkBRotateL :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +mkBRotateL :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t mkBRotateL = mkPrimBinary $ PrimBRotateL integralType -mkBRotateR :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int -> Exp t +mkBRotateR :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t mkBRotateR = mkPrimBinary $ PrimBRotateR integralType -mkPopCount :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int +mkPopCount :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int mkPopCount = mkPrimUnary $ PrimPopCount integralType -mkCountLeadingZeros :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int +mkCountLeadingZeros :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int mkCountLeadingZeros = mkPrimUnary $ PrimCountLeadingZeros integralType -mkCountTrailingZeros :: (Elt t, IsIntegral (EltRepr t)) => Exp t -> Exp Int +mkCountTrailingZeros :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int mkCountTrailingZeros = mkPrimUnary $ PrimCountTrailingZeros integralType -- Operators from Fractional -mkFDiv :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t -> Exp t +mkFDiv :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t -> Exp t mkFDiv = mkPrimBinary $ PrimFDiv floatingType -mkRecip :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t +mkRecip :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t mkRecip = mkPrimUnary $ PrimRecip floatingType -- Operators from RealFrac -mkTruncate :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b +mkTruncate :: (Elt a, Elt b, IsFloating (EltR a), IsIntegral (EltR b)) => Exp a -> Exp b mkTruncate = mkPrimUnary $ PrimTruncate floatingType integralType -mkRound :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b +mkRound :: (Elt a, Elt b, IsFloating (EltR a), IsIntegral (EltR b)) => Exp a -> Exp b mkRound = mkPrimUnary $ PrimRound floatingType integralType -mkFloor :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b +mkFloor :: (Elt a, Elt b, IsFloating (EltR a), IsIntegral (EltR b)) => Exp a -> Exp b mkFloor = mkPrimUnary $ PrimFloor floatingType integralType -mkCeiling :: (Elt a, Elt b, IsFloating (EltRepr a), IsIntegral (EltRepr b)) => Exp a -> Exp b +mkCeiling :: (Elt a, Elt b, IsFloating (EltR a), IsIntegral (EltR b)) => Exp a -> Exp b mkCeiling = mkPrimUnary $ PrimCeiling floatingType integralType -- Operators from RealFloat -mkAtan2 :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp t -> Exp t +mkAtan2 :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t -> Exp t mkAtan2 = mkPrimBinary $ PrimAtan2 floatingType -mkIsNaN :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp Bool +mkIsNaN :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp Bool mkIsNaN = mkPrimUnary $ PrimIsNaN floatingType -mkIsInfinite :: (Elt t, IsFloating (EltRepr t)) => Exp t -> Exp Bool +mkIsInfinite :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp Bool mkIsInfinite = mkPrimUnary $ PrimIsInfinite floatingType -- FIXME: add missing operations from Floating, RealFrac & RealFloat -- Relational and equality operators -mkLt :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkLt :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool mkLt = mkPrimBinary $ PrimLt singleType -mkGt :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkGt :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool mkGt = mkPrimBinary $ PrimGt singleType -mkLtEq :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkLtEq :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool mkLtEq = mkPrimBinary $ PrimLtEq singleType -mkGtEq :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkGtEq :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool mkGtEq = mkPrimBinary $ PrimGtEq singleType -mkEq :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkEq :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool mkEq = mkPrimBinary $ PrimEq singleType -mkNEq :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp Bool +mkNEq :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool mkNEq = mkPrimBinary $ PrimNEq singleType -mkMax :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp t +mkMax :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp t mkMax = mkPrimBinary $ PrimMax singleType -mkMin :: (Elt t, IsSingle (EltRepr t)) => Exp t -> Exp t -> Exp t +mkMin :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp t mkMin = mkPrimBinary $ PrimMin singleType -- Logical operators @@ -1271,10 +1188,10 @@ mkChr = mkPrimUnary PrimChr -- Numeric conversions -mkFromIntegral :: (Elt a, Elt b, IsIntegral (EltRepr a), IsNum (EltRepr b)) => Exp a -> Exp b +mkFromIntegral :: (Elt a, Elt b, IsIntegral (EltR a), IsNum (EltR b)) => Exp a -> Exp b mkFromIntegral = mkPrimUnary $ PrimFromIntegral integralType numType -mkToFloating :: (Elt a, Elt b, IsNum (EltRepr a), IsFloating (EltRepr b)) => Exp a -> Exp b +mkToFloating :: (Elt a, Elt b, IsNum (EltR a), IsFloating (EltR b)) => Exp a -> Exp b mkToFloating = mkPrimUnary $ PrimToFloating numType floatingType -- Other conversions @@ -1284,10 +1201,10 @@ mkBoolToInt (Exp b) = mkExp $ PrimBoolToInt `PrimApp` b -- NOTE: Restricted to scalar types with a type-level BitSizeEq constraint to -- make this version "safe" -mkBitcast :: forall b a. (Elt a, Elt b, IsScalar (EltRepr a), IsScalar (EltRepr b), BitSizeEq (EltRepr a) (EltRepr b)) => Exp a -> Exp b -mkBitcast (Exp a) = mkExp $ Coerce (scalarType @(EltRepr a)) (scalarType @(EltRepr b)) a +mkBitcast :: forall b a. (Elt a, Elt b, IsScalar (EltR a), IsScalar (EltR b), BitSizeEq (EltR a) (EltR b)) => Exp a -> Exp b +mkBitcast (Exp a) = mkExp $ Coerce (scalarType @(EltR a)) (scalarType @(EltR b)) a -mkCoerce :: Coerce (EltRepr a) (EltRepr b) => Exp a -> Exp b +mkCoerce :: Coerce (EltR a) (EltR b) => Exp a -> Exp b mkCoerce (Exp a) = Exp $ mkCoerce' a class Coerce a b where @@ -1329,28 +1246,28 @@ 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) -unAcc :: Arrays a => Acc a -> SmartAcc (ArrRepr a) +unAcc :: Arrays a => Acc a -> SmartAcc (Sugar.ArraysR a) unAcc (Acc a) = a -unAccFunction :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> SmartAcc (ArrRepr a) -> SmartAcc (ArrRepr b) +unAccFunction :: (Arrays a, Arrays b) => (Acc a -> Acc b) -> SmartAcc (Sugar.ArraysR a) -> SmartAcc (Sugar.ArraysR b) unAccFunction f = unAcc . f . Acc -mkExp :: PreSmartExp SmartAcc SmartExp (EltRepr t) -> Exp t +mkExp :: PreSmartExp SmartAcc SmartExp (EltR t) -> Exp t mkExp = Exp . SmartExp -unExp :: Elt e => Exp e -> SmartExp (EltRepr e) +unExp :: Elt e => Exp e -> SmartExp (EltR e) unExp (Exp e) = e -unExpFunction :: (Elt a, Elt b) => (Exp a -> Exp b) -> SmartExp (EltRepr a) -> SmartExp (EltRepr b) +unExpFunction :: (Elt a, Elt b) => (Exp a -> Exp b) -> SmartExp (EltR a) -> SmartExp (EltR b) unExpFunction f = unExp . f . Exp -unExpBinaryFunction :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> Exp c) -> SmartExp (EltRepr a) -> SmartExp (EltRepr b) -> SmartExp (EltRepr c) +unExpBinaryFunction :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> Exp c) -> SmartExp (EltR a) -> SmartExp (EltR b) -> SmartExp (EltR c) unExpBinaryFunction f a b = unExp $ f (Exp a) (Exp b) -mkPrimUnary :: (Elt a, Elt b) => PrimFun (EltRepr a -> EltRepr b) -> Exp a -> Exp b +mkPrimUnary :: (Elt a, Elt b) => PrimFun (EltR a -> EltR b) -> Exp a -> Exp b mkPrimUnary prim (Exp a) = mkExp $ PrimApp prim a -mkPrimBinary :: (Elt a, Elt b, Elt c) => PrimFun ((EltRepr a, EltRepr b) -> EltRepr c) -> Exp a -> Exp b -> Exp c +mkPrimBinary :: (Elt a, Elt b, Elt c) => PrimFun ((EltR a, EltR b) -> EltR c) -> Exp a -> Exp b -> Exp c mkPrimBinary prim (Exp a) (Exp b) = mkExp $ PrimApp prim (SmartExp $ Pair a b) unPair :: SmartExp (a, b) -> (SmartExp a, SmartExp b) @@ -1372,31 +1289,32 @@ instance ApplyAcc (SmartAcc a) where applyAcc = SmartAcc instance (Arrays a, ApplyAcc t) => ApplyAcc (Acc a -> t) where - type FromApplyAcc (Acc a -> t) = SmartAcc (ArrRepr a) -> FromApplyAcc t + type FromApplyAcc (Acc a -> t) = SmartAcc (Sugar.ArraysR a) -> FromApplyAcc t applyAcc f a = applyAcc $ f (unAcc a) instance (Elt a, ApplyAcc t) => ApplyAcc (Exp a -> t) where - type FromApplyAcc (Exp a -> t) = SmartExp (EltRepr a) -> FromApplyAcc t + type FromApplyAcc (Exp a -> t) = SmartExp (EltR a) -> FromApplyAcc t applyAcc f a = applyAcc $ f (unExp a) instance (Elt a, Elt b, ApplyAcc t) => ApplyAcc ((Exp a -> Exp b) -> t) where - type FromApplyAcc ((Exp a -> Exp b) -> t) = (SmartExp (EltRepr a) -> SmartExp (EltRepr b)) -> FromApplyAcc t + type FromApplyAcc ((Exp a -> Exp b) -> t) = (SmartExp (EltR a) -> SmartExp (EltR b)) -> FromApplyAcc t applyAcc f a = applyAcc $ f (unExpFunction a) instance (Elt a, Elt b, Elt c, ApplyAcc t) => ApplyAcc ((Exp a -> Exp b -> Exp c) -> t) where - type FromApplyAcc ((Exp a -> Exp b -> Exp c) -> t) = (SmartExp (EltRepr a) -> SmartExp (EltRepr b) -> SmartExp (EltRepr c)) -> FromApplyAcc t + type FromApplyAcc ((Exp a -> Exp b -> Exp c) -> t) = (SmartExp (EltR a) -> SmartExp (EltR b) -> SmartExp (EltR c)) -> FromApplyAcc t applyAcc f a = applyAcc $ f (unExpBinaryFunction a) instance (Arrays a, Arrays b, ApplyAcc t) => ApplyAcc ((Acc a -> Acc b) -> t) where - type FromApplyAcc ((Acc a -> Acc b) -> t) = (SmartAcc (ArrRepr a) -> SmartAcc (ArrRepr b)) -> FromApplyAcc t + type FromApplyAcc ((Acc a -> Acc b) -> t) = (SmartAcc (Sugar.ArraysR a) -> SmartAcc (Sugar.ArraysR b)) -> FromApplyAcc t applyAcc f a = applyAcc $ f (unAccFunction a) + -- Debugging -- --------- showPreAccOp :: forall acc exp arrs. PreSmartAcc acc exp arrs -> String showPreAccOp (Atag _ i) = "Atag " ++ show i -showPreAccOp (Use repr a) = "Use " ++ showShortendArr repr a +showPreAccOp (Use aR a) = "Use " ++ showArrayShort 5 (showsElt (arrayRtype aR)) aR a showPreAccOp Pipe{} = "Pipe" showPreAccOp Acond{} = "Acond" showPreAccOp Awhile{} = "Awhile" @@ -1425,24 +1343,10 @@ 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" ---} - showPreExpOp :: PreSmartExp acc exp t -> String showPreExpOp (Tag _ i) = "Tag" ++ show i -showPreExpOp (Const tp c) = "Const " ++ showElement (TupRsingle tp) c +showPreExpOp (Const t c) = "Const " ++ showElt (TupRsingle t) c showPreExpOp (Undef _) = "Undef" showPreExpOp Nil{} = "Nil" showPreExpOp Pair{} = "Pair" diff --git a/src/Data/Array/Accelerate/Sugar/Array.hs b/src/Data/Array/Accelerate/Sugar/Array.hs new file mode 100644 index 000000000..f7c39c559 --- /dev/null +++ b/src/Data/Array/Accelerate/Sugar/Array.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Sugar.Array +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Sugar.Array + where + +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape +import Data.Array.Accelerate.Representation.Type +import qualified Data.Array.Accelerate.Representation.Array as R + +import Control.DeepSeq +import Data.Kind +import Data.Typeable +import Language.Haskell.TH hiding ( Type ) +import Language.Haskell.TH.Extra +import System.IO.Unsafe + +import GHC.Exts ( IsList ) +import GHC.Generics +import qualified GHC.Exts as GHC + + +type Scalar = Array DIM0 -- ^ Scalar arrays hold a single element +type Vector = Array DIM1 -- ^ Vectors are one-dimensional arrays +type Matrix = Array DIM2 -- ^ Matrices are two-dimensional arrays + +-- | 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 sub-arrays. +-- +type Segments = Vector + + +-- | 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 16-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. +-- +newtype Array sh e = Array (R.Array (EltR sh) (EltR e)) + deriving Typeable + +instance (Shape sh, Elt e, Eq sh, Eq e) => Eq (Array sh e) where + arr1 == arr2 = shape arr1 == shape arr2 && toList arr1 == toList arr2 + arr1 /= arr2 = shape arr1 /= shape arr2 || toList arr1 /= toList arr2 + +instance (Shape sh, Elt e, Show e) => Show (Array sh e) where + show (Array arr) = R.showArray (shows . toElt @e) (arrayR @sh @e) arr + +instance Elt e => IsList (Array DIM1 e) where + type Item (Vector e) = e + toList = toList + fromListN n = fromList (Z:.n) + fromList xs = GHC.fromListN (length xs) xs + +instance (Shape sh, Elt e) => NFData (Array sh e) where + rnf (Array arr) = R.rnfArray (arrayR @sh @e) arr + +-- Note: [Embedded class constraints on Array] +-- +-- Previously, we had embedded 'Shape' and 'Elt' constraints on the 'Array' +-- constructor. This was occasionally convenient, however, this has a negative +-- impact on the kind of code which GHC can generate. For example, if we write +-- the function: +-- +-- > (!) :: Array sh e -> sh -> e +-- +-- Without the 'Shape' and 'Elt' constraints on the type signature, and instead +-- recover those when pattern matching on 'Array', then GHC is unable to +-- specialise functions past this point. In this example, even if 'sh' and 'e' +-- are fixed, GHC would not be able to inline the definitions from 'ArrayElt' +-- which perform the actual data accesses. +-- +-- - TLM 2018-09-13 +-- + +-- | Yield an array's shape +-- +shape :: Shape sh => Array sh e -> sh +shape (Array arr) = toElt (R.shape arr) + +-- | Change the shape of an array without altering its contents. The 'size' of +-- the source and result arrays must be identical. +-- +reshape :: forall sh sh' e. (Shape sh, Shape sh') => sh -> Array sh' e -> Array sh e +reshape sh (Array arr) = Array $ R.reshape (shapeR @sh) (fromElt sh) (shapeR @sh') arr + +-- | Return the value of an array at the given multidimensional index +-- +infixl 9 ! +(!) :: forall sh e. (Shape sh, Elt e) => Array sh e -> sh -> e +(!) (Array arr) ix = toElt $ R.indexArray (arrayR @sh @e) arr (fromElt ix) + +-- | Return the value of an array at given the linear (row-major) index +-- +infixl 9 !! +(!!) :: forall sh e. Elt e => Array sh e -> Int -> e +(!!) (Array arr) i = toElt $ R.linearIndexArray (eltR @e) arr i + +-- | 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 +fromFunction sh f = unsafePerformIO $! fromFunctionM sh (return . f) + +-- | Create an array using a monadic function applied at each index +-- +-- @since 1.2.0.0 +-- +fromFunctionM :: forall sh e. (Shape sh, Elt e) => sh -> (sh -> IO e) -> IO (Array sh e) +fromFunctionM sh f = Array <$> R.fromFunctionM (arrayR @sh @e) (fromElt sh) f' + where + f' x = do + y <- f (toElt x) + return (fromElt y) + +-- | Create a vector from the concatenation of the given list of vectors +-- +concatVectors :: forall e. Elt e => [Vector e] -> Vector e +concatVectors = toArr . R.concatVectors (eltR @e) . map fromArr + +-- | Creates a new, uninitialized Accelerate array +-- +allocateArray :: forall sh e. (Shape sh, Elt e) => sh -> IO (Array sh e) +allocateArray sh = Array <$> R.allocateArray (arrayR @sh @e) (fromElt 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) :: 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. +-- +fromList :: forall sh e. (Shape sh, Elt e) => sh -> [e] -> Array sh e +fromList sh xs = toArr $ R.fromList (arrayR @sh @e) (fromElt sh) $ map fromElt xs + +-- | Convert an accelerated 'Array' to a list in row-major order +-- +toList :: forall sh e. (Shape sh, Elt e) => Array sh e -> [e] +toList = map toElt . R.toList (arrayR @sh @e) . fromArr + + +-- | The 'Arrays' class characterises the types which can appear in collective +-- Accelerate computations of type 'Data.Array.Accelerate.Acc'. +-- +-- 'Arrays' consists of nested tuples of individual 'Array's, currently up +-- to 16-elements wide. Accelerate computations can thereby return multiple +-- results. +-- +class Arrays a where + -- | Type representation mapping, which explains how to convert from the + -- surface type into the internal representation type, which consists + -- only of 'Array', and '()' and '(,)' as type-level nil and snoc. + -- + type ArraysR a :: Type + type ArraysR a = GArraysR () (Rep a) + + arraysR :: R.ArraysR (ArraysR a) + toArr :: ArraysR a -> a + fromArr :: a -> ArraysR a + + default arraysR + :: (GArrays (Rep a), ArraysR a ~ GArraysR () (Rep a)) + => R.ArraysR (ArraysR a) + arraysR = garrays @(Rep a) TupRunit + + default toArr + :: (Generic a, GArrays (Rep a), ArraysR a ~ GArraysR () (Rep a)) + => ArraysR a -> a + toArr = to . snd . gtoArr @(Rep a) @() + + default fromArr + :: (Generic a, GArrays (Rep a), ArraysR a ~ GArraysR () (Rep a)) + => a -> ArraysR a + fromArr = (`gfromArr` ()) . from + +arrayR :: forall sh e. (Shape sh, Elt e) => R.ArrayR (R.Array (EltR sh) (EltR e)) +arrayR = R.ArrayR (shapeR @sh) (eltR @e) + +class GArrays f where + type GArraysR t f + garrays :: R.ArraysR t -> R.ArraysR (GArraysR t f) + gfromArr :: f a -> t -> GArraysR t f + gtoArr :: GArraysR t f -> (t, f a) + +instance GArrays U1 where + type GArraysR t U1 = t + garrays = id + gfromArr U1 = id + gtoArr t = (t, U1) + +instance GArrays a => GArrays (M1 i c a) where + type GArraysR t (M1 i c a) = GArraysR t a + garrays = garrays @a + gfromArr (M1 x) = gfromArr x + gtoArr x = let (t, x1) = gtoArr x in (t, M1 x1) + +instance Arrays a => GArrays (K1 i a) where + type GArraysR t (K1 i a) = (t, ArraysR a) + garrays t = TupRpair t (arraysR @a) + gfromArr (K1 x) t = (t, fromArr x) + gtoArr (t, x) = (t, K1 (toArr x)) + +instance (GArrays a, GArrays b) => GArrays (a :*: b) where + type GArraysR t (a :*: b) = GArraysR (GArraysR t a) b + garrays = garrays @b . garrays @a + gfromArr (a :*: b) = gfromArr b . gfromArr a + gtoArr t = + let (t1, b) = gtoArr t + (t2, a) = gtoArr t1 + in + (t2, a :*: b) + + +instance Arrays () where + type ArraysR () = () + arraysR = TupRunit + fromArr = id + toArr = id + +instance (Shape sh, Elt e) => Arrays (Array sh e) where + type ArraysR (Array sh e) = R.Array (EltR sh) (EltR e) + arraysR = R.arraysRarray (shapeR @sh) (eltR @e) + fromArr (Array arr) = arr + toArr = Array + +runQ $ do + let + mkTuple :: Int -> Q Dec + mkTuple n = + let + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + res = tupT ts + ctx = mapM (appT [t| Arrays |]) ts + in + instanceD ctx [t| Arrays $res |] [] + -- + mapM mkTuple [2..16] + diff --git a/src/Data/Array/Accelerate/Sugar/Elt.hs b/src/Data/Array/Accelerate/Sugar/Elt.hs new file mode 100644 index 000000000..85d0c977a --- /dev/null +++ b/src/Data/Array/Accelerate/Sugar/Elt.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Sugar.Elt +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Sugar.Elt + where + +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type + +import Data.Kind +import Language.Haskell.TH hiding ( Type ) +import Language.Haskell.TH.Extra + +import GHC.Generics + + +-- | The 'Elt' class characterises the allowable array element types, and +-- hence the types which can appear in scalar Accelerate expressions of +-- type 'Data.Array.Accelerate.Exp'. +-- +-- 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 16-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" +-- * +-- * +-- +-- For simple product types it is possible to derive 'Elt' automatically, +-- for example: +-- +-- > data Point = Point Int Float +-- > deriving (Generic, Elt) +-- +class Elt a where + -- | Type representation mapping, which explains how to convert a type + -- from the surface type into the internal representation type consisting + -- only of simple primitive types, unit '()', and pair '(,)'. + -- + type EltR a :: Type + type EltR a = GEltR () (Rep a) + -- + eltR :: TypeR (EltR a) + fromElt :: a -> EltR a + toElt :: EltR a -> a + + default eltR + :: (GElt (Rep a), EltR a ~ GEltR () (Rep a)) + => TypeR (EltR a) + eltR = geltR @(Rep a) TupRunit + + default fromElt + :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a)) + => a + -> EltR a + fromElt = gfromElt () . from + + default toElt + :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a)) + => EltR a + -> a + toElt = to . snd . gtoElt @(Rep a) @() + + +class GElt f where + type GEltR t f + geltR :: TypeR t -> TypeR (GEltR t f) + gfromElt :: t -> f a -> GEltR t f + gtoElt :: GEltR t f -> (t, f a) + +instance GElt U1 where + type GEltR t U1 = t + geltR t = t + gfromElt t U1 = t + gtoElt t = (t, U1) + +instance GElt a => GElt (M1 i c a) where + type GEltR t (M1 i c a) = GEltR t a + geltR = geltR @a + gfromElt t (M1 x) = gfromElt t x + gtoElt x = let (t, x1) = gtoElt x in (t, M1 x1) + +instance Elt a => GElt (K1 i a) where + type GEltR t (K1 i a) = (t, EltR a) + geltR t = TupRpair t (eltR @a) + gfromElt t (K1 x) = (t, fromElt x) + gtoElt (t, x) = (t, K1 (toElt x)) + +instance (GElt a, GElt b) => GElt (a :*: b) where + type GEltR t (a :*: b) = GEltR (GEltR t a) b + geltR = geltR @b . geltR @a + gfromElt t (a :*: b) = gfromElt (gfromElt t a) b + gtoElt t = + let (t1, b) = gtoElt t + (t2, a) = gtoElt t1 + in + (t2, a :*: b) + + +-- Note: [Deriving Elt] +-- +-- We can't use the cunning generalised newtype deriving mechanism, because the +-- generated 'eltType' function does not type check. For example, it will +-- generate the following implementation for 'CShort': +-- +-- > eltR +-- > = coerce +-- > @(TypeR (EltR Int16)) +-- > @(TypeR (EltR CShort)) +-- > (eltR :: TypeR (EltR CShort)) +-- +-- Which yields the error "couldn't match type 'EltRepr a0' with 'Int16'". +-- Since this function returns a type family type, the type signature on the +-- result is not enough to fix the type 'a'. Instead, we require the use of +-- (visible) type applications: +-- +-- > eltR +-- > = coerce +-- > @(TypeR (EltR Int16)) +-- > @(TypeR (EltR CShort)) +-- > (eltR @(EltR CShort)) +-- +-- Note that this does not affect deriving instances via 'Generic' +-- +-- Instances for basic types are generated at the end of this module. +-- + +instance Elt () where + type EltR () = () + eltR = TupRunit + fromElt = id + toElt = id + +runQ $ do + let + -- XXX: we might want to do the digItOut trick used by FromIntegral? + -- + integralTypes :: [Name] + integralTypes = + [ ''Int + , ''Int8 + , ''Int16 + , ''Int32 + , ''Int64 + , ''Word + , ''Word8 + , ''Word16 + , ''Word32 + , ''Word64 + ] + + floatingTypes :: [Name] + floatingTypes = + [ ''Half + , ''Float + , ''Double + ] + + nonNumTypes :: [Name] + nonNumTypes = + [ ''Bool + , ''Char + ] + + newtypes :: [Name] + newtypes = + [ ''CShort + , ''CUShort + , ''CInt + , ''CUInt + , ''CLong + , ''CULong + , ''CLLong + , ''CULLong + , ''CFloat + , ''CDouble + , ''CChar + , ''CSChar + , ''CUChar + ] + + mkSimple :: Name -> Q [Dec] + mkSimple name = + let t = conT name + in + [d| instance Elt $t where + type EltR $t = $t + eltR = TupRsingle scalarType + fromElt = id + toElt = id + |] + + mkTuple :: Int -> Q Dec + mkTuple n = + let + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + ts = map varT xs + res = tupT ts + ctx = mapM (appT [t| Elt |]) ts + in + instanceD ctx [t| Elt $res |] [] + + -- mkVecElt :: Name -> Integer -> Q [Dec] + -- mkVecElt name n = + -- let t = conT name + -- v = [t| Vec $(litT (numTyLit n)) $t |] + -- in + -- [d| instance Elt $v where + -- type EltR $v = $v + -- eltR = TupRsingle scalarType + -- fromElt = id + -- toElt = id + -- |] + + -- ghci> $( stringE . show =<< reify ''CFloat ) + -- TyConI (NewtypeD [] Foreign.C.Types.CFloat [] Nothing (NormalC Foreign.C.Types.CFloat [(Bang NoSourceUnpackedness NoSourceStrictness,ConT GHC.Types.Float)]) []) + -- + mkNewtype :: Name -> Q [Dec] + mkNewtype name = do + r <- reify name + base <- case r of + TyConI (NewtypeD _ _ _ _ (NormalC _ [(_, ConT b)]) _) -> return b + _ -> error "unexpected case generating newtype Elt instance" + -- + [d| instance Elt $(conT name) where + type EltR $(conT name) = $(conT base) + eltR = TupRsingle scalarType + fromElt $(conP (mkName (nameBase name)) [varP (mkName "x")]) = x + toElt = $(conE (mkName (nameBase name))) + |] + -- + ss <- mapM mkSimple (integralTypes ++ floatingTypes ++ nonNumTypes) + ns <- mapM mkNewtype newtypes + ts <- mapM mkTuple [2..16] + -- vs <- sequence [ mkVecElt t n | t <- integralTypes ++ floatingTypes, n <- [2,3,4,8,16] ] + return (concat ss ++ concat ns ++ ts) + diff --git a/src/Data/Array/Accelerate/Sugar/Foreign.hs b/src/Data/Array/Accelerate/Sugar/Foreign.hs new file mode 100644 index 000000000..d42d2f547 --- /dev/null +++ b/src/Data/Array/Accelerate/Sugar/Foreign.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Sugar.Foreign +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Sugar.Foreign + where + +import Data.Array.Accelerate.Error + +import Data.Typeable +import Language.Haskell.TH + + +-- 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 _ = "" + + -- 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" + diff --git a/src/Data/Array/Accelerate/Sugar/Shape.hs b/src/Data/Array/Accelerate/Sugar/Shape.hs new file mode 100644 index 000000000..987637470 --- /dev/null +++ b/src/Data/Array/Accelerate/Sugar/Shape.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Sugar.Shape +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Array indices are snoc lists at both the type and value level. That is, +-- they're backwards, where the end-of-list token, 'Z', occurs first. For +-- example, the type of a rank-2 array index is @Z :. Int :. Int@, and +-- shape of a rank-2 array with 5 rows and 10 columns is @Z :. 5 :. 10@. +-- +-- In Accelerate the rightmost dimension is the /fastest varying/ or +-- innermost; these values are adjacent in memory. +-- + +module Data.Array.Accelerate.Sugar.Shape + where + +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Representation.Type +import qualified Data.Array.Accelerate.Representation.Shape as R +import qualified Data.Array.Accelerate.Representation.Slice as R + +import Data.Kind +import GHC.Generics + + +-- 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 + +-- | Rank-0 index +-- +data Z = Z + deriving (Show, Eq, Generic, Elt) + +-- | 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 (Eq, Generic) -- Not deriving Elt or Show + +-- 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 + showsPrec p (sh :. sz) = + showsPrec p sh . showString " :. " . showsPrec p 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 (Show, Eq, Generic, Elt) + +-- | 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 (Show, Eq, Generic) + +-- | 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 (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 (Show, Eq) + + +-- | Number of dimensions of a /shape/ or /index/ (>= 0) +-- +rank :: forall sh. Shape sh => Int +rank = R.rank (shapeR @sh) + +-- | Total number of elements in an array of the given /shape/ +-- +size :: forall sh. Shape sh => sh -> Int +size = R.size (shapeR @sh) . fromElt + +-- | The empty /shape/ +-- +empty :: forall sh. Shape sh => sh +empty = toElt $ R.empty (shapeR @sh) + +-- | Magic value identifying elements ignored in 'permute' +-- +ignore :: forall sh. Shape sh => sh +ignore = toElt $ R.ignore (shapeR @sh) + +-- | Yield the intersection of two shapes +intersect :: forall sh. Shape sh => sh -> sh -> sh +intersect x y = toElt $ R.intersect (shapeR @sh) (fromElt x) (fromElt y) + +-- | Yield the union of two shapes +-- +union :: forall sh. Shape sh => sh -> sh -> sh +union x y = toElt $ R.union (shapeR @sh) (fromElt x) (fromElt y) + +-- | 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 :: forall sh. Shape sh + => sh -- ^ Total shape (extent) of the array + -> sh -- ^ The argument index + -> Int -- ^ Corresponding linear index +toIndex sh ix = R.toIndex (shapeR @sh) (fromElt sh) (fromElt ix) + +-- | Inverse of 'toIndex'. +-- +fromIndex :: forall sh. Shape sh + => sh -- ^ Total shape (extent) of the array + -> Int -- ^ The argument index + -> sh -- ^ Corresponding multi-dimensional index +fromIndex sh = toElt . R.fromIndex (shapeR @sh) (fromElt sh) + +-- | Iterate through all of the indices of a shape, applying the given +-- function at each index. The index space is traversed in row-major order. +-- +iter :: forall sh e. Shape sh + => sh -- ^ The total shape (extent) of the index space + -> (sh -> e) -- ^ Function to apply at each index + -> (e -> e -> e) -- ^ Function to combine results + -> e -- ^ Value to return in case of an empty iteration space + -> e +iter sh f = R.iter (shapeR @sh) (fromElt sh) (f . toElt) + +-- | Variant of 'iter' without an initial value +-- +iter1 :: forall sh e. Shape sh + => sh + -> (sh -> e) + -> (e -> e -> e) + -> e +iter1 sh f = R.iter1 (shapeR @sh) (fromElt sh) (f . toElt) + +-- | Convert a minpoint-maxpoint index into a zero-indexed shape +-- +rangeToShape :: forall sh. Shape sh => (sh, sh) -> sh +rangeToShape (u, v) = toElt $ R.rangeToShape (shapeR @sh) (fromElt u, fromElt v) + +-- | Convert a shape into a minpoint-maxpoint index +-- +shapeToRange :: forall sh. Shape sh => sh -> (sh, sh) +shapeToRange ix = + let (u, v) = R.shapeToRange (shapeR @sh) (fromElt ix) + in (toElt u, toElt v) + +-- | Convert a shape to a list of dimensions +-- +shapeToList :: forall sh. Shape sh => sh -> [Int] +shapeToList = R.shapeToList (shapeR @sh) . fromElt + +-- | Convert a list of dimensions into a shape. If the list does not +-- contain exactly the number of elements as specified by the type of the +-- shape: error. +-- +listToShape :: forall sh. Shape sh => [Int] -> sh +listToShape = toElt . R.listToShape (shapeR @sh) + +-- | Attempt to convert a list of dimensions into a shape +-- +listToShape' :: forall sh. Shape sh => [Int] -> Maybe sh +listToShape' = fmap toElt . R.listToShape' (shapeR @sh) + +-- | 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) + => R.SliceIndex slix (EltR sl) co (EltR dim) + -> dim + -> sl +sliceShape slix = toElt . R.sliceShape slix . fromElt + +-- | Enumerate all slices within a given bound. The innermost dimension +-- changes most rapidly. +-- +-- Example: +-- +-- > let slix = sliceIndex @(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) + => R.SliceIndex (EltR slix) sl co (EltR dim) + -> dim -- Bounds + -> [slix] -- All slices within bounds. +enumSlices slix = map toElt . R.enumSlices slix . fromElt + +-- | Shapes and indices of multi-dimensional arrays +-- +class (Elt sh, Elt (Any sh), FullShape sh ~ sh, CoSliceShape sh ~ sh, SliceShape sh ~ Z) + => Shape sh where + + -- | Reified type witness for shapes + shapeR :: R.ShapeR (EltR sh) + + -- | The slice index for slice specifier 'Any sh' + sliceAnyIndex :: R.SliceIndex (EltR (Any sh)) (EltR sh) () (EltR sh) + + -- | The slice index for specifying a slice with only the Z component projected + sliceNoneIndex :: R.SliceIndex (EltR sh) () (EltR sh) (EltR 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 :: Type -- the projected slice + type CoSliceShape sl :: Type -- the complement of the slice + type FullShape sl :: Type -- the combined dimension + sliceIndex :: R.SliceIndex (EltR sl) + (EltR (SliceShape sl)) + (EltR (CoSliceShape sl)) + (EltR (FullShape sl)) + +-- | 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 :: Type -- the slice + slicesIndex :: slix ~ DivisionSlice sl + => R.SliceIndex (EltR slix) + (EltR (SliceShape slix)) + (EltR (CoSliceShape slix)) + (EltR (FullShape slix)) + +instance (Elt t, Elt h) => Elt (t :. h) where + type EltR (t :. h) = (EltR t, EltR h) + eltR = TupRpair (eltR @t) (eltR @h) + fromElt (t:.h) = (fromElt t, fromElt h) + toElt (t, h) = toElt t :. toElt h + +instance Elt (Any Z) +instance Shape sh => Elt (Any (sh :. Int)) where + type EltR (Any (sh :. Int)) = (EltR (Any sh), ()) + eltR = TupRpair (eltR @(Any sh)) TupRunit + fromElt _ = (fromElt (Any :: Any sh), ()) + toElt _ = Any + +instance Shape Z where + shapeR = R.ShapeRz + sliceAnyIndex = R.SliceNil + sliceNoneIndex = R.SliceNil + +instance Shape sh => Shape (sh:.Int) where + shapeR = R.ShapeRsnoc (shapeR @sh) + sliceAnyIndex = R.SliceAll (sliceAnyIndex @sh) + sliceNoneIndex = R.SliceFixed (sliceNoneIndex @sh) + +instance Slice Z where + type SliceShape Z = Z + type CoSliceShape Z = Z + type FullShape Z = Z + sliceIndex = R.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 = R.SliceAll (sliceIndex @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 = R.SliceFixed (sliceIndex @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 @sh + +instance Division Z where + type DivisionSlice Z = Z + slicesIndex = R.SliceNil + +instance Division sl => Division (sl:.All) where + type DivisionSlice (sl:.All) = DivisionSlice sl :. All + slicesIndex = R.SliceAll (slicesIndex @sl) + +instance Division sl => Division (sl:.Split) where + type DivisionSlice (sl:.Split) = DivisionSlice sl :. Int + slicesIndex = R.SliceFixed (slicesIndex @sl) + +instance Shape sh => Division (Any sh) where + type DivisionSlice (Any sh) = Any sh + slicesIndex = sliceAnyIndex @sh + +instance (Shape sh, Slice sh) => Division (Divide sh) where + type DivisionSlice (Divide sh) = sh + slicesIndex = sliceNoneIndex @sh + diff --git a/src/Data/Array/Accelerate/Sugar/Stencil.hs b/src/Data/Array/Accelerate/Sugar/Stencil.hs new file mode 100644 index 000000000..9fa49629a --- /dev/null +++ b/src/Data/Array/Accelerate/Sugar/Stencil.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Sugar.Stencil +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Sugar.Stencil + where + +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape +import Data.Array.Accelerate.Representation.Type +import qualified Data.Array.Accelerate.Representation.Stencil as R + +import Data.Kind + +-- Reification of the stencil type from nested tuples of Accelerate +-- expressions in the surface language. This enables us to represent the +-- stencil function as a unary function. +-- +class Stencil sh e stencil where + type StencilR sh stencil :: Type + stencilR :: R.StencilR (EltR sh) (EltR e) (StencilR sh stencil) + +instance Elt e => Stencil DIM1 e (exp e, exp e, exp e) where + type StencilR DIM1 (exp e, exp e, exp e) = EltR (e, e, e) + stencilR = R.StencilRunit3 $ eltR @e + +instance Elt e => Stencil DIM1 e (exp e, exp e, exp e, exp e, exp e) where + type StencilR DIM1 (exp e, exp e, exp e, exp e, exp e) = + EltR (e, e, e, e, e) + stencilR = R.StencilRunit5 $ eltR @e + +instance Elt e => Stencil DIM1 e (exp e, exp e, exp e, exp e, exp e, exp e, exp e) where + type StencilR DIM1 (exp e, exp e, exp e, exp e, exp e, exp e, exp e) = + EltR (e, e, e, e, e, e, e) + stencilR = R.StencilRunit7 $ eltR @e + +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 StencilR DIM1 (exp e, exp e, exp e, exp e, exp e, exp e, exp e, exp e, exp e) = + EltR (e, e, e, e, e, e, e, e, e) + stencilR = R.StencilRunit9 $ eltR @e + +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 StencilR (sh:.Int:.Int) (row2, row1, row0) = + Tup3 (StencilR (sh:.Int) row2) (StencilR (sh:.Int) row1) (StencilR (sh:.Int) row0) + stencilR = R.StencilRtup3 (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) + +instance ( Stencil (sh:.Int) a row4 + , Stencil (sh:.Int) a row3 + , Stencil (sh:.Int) a row2 + , Stencil (sh:.Int) a row1 + , Stencil (sh:.Int) a row0 + ) + => Stencil (sh:.Int:.Int) a (row4, row3, row2, row1, row0) where + type StencilR (sh:.Int:.Int) (row4, row3, row2, row1, row0) = + Tup5 (StencilR (sh:.Int) row4) (StencilR (sh:.Int) row3) (StencilR (sh:.Int) row2) + (StencilR (sh:.Int) row1) (StencilR (sh:.Int) row0) + stencilR = R.StencilRtup5 + (stencilR @(sh:.Int) @a @row4) (stencilR @(sh:.Int) @a @row3) (stencilR @(sh:.Int) @a @row2) + (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) + +instance ( Stencil (sh:.Int) a row6 + , Stencil (sh:.Int) a row5 + , Stencil (sh:.Int) a row4 + , Stencil (sh:.Int) a row3 + , Stencil (sh:.Int) a row2 + , Stencil (sh:.Int) a row1 + , Stencil (sh:.Int) a row0 + ) + => Stencil (sh:.Int:.Int) a (row6, row5, row4, row3, row2, row1, row0) where + type StencilR (sh:.Int:.Int) (row6, row5, row4, row3, row2, row1, row0) = + Tup7 (StencilR (sh:.Int) row6) (StencilR (sh:.Int) row5) (StencilR (sh:.Int) row4) + (StencilR (sh:.Int) row3) (StencilR (sh:.Int) row2) (StencilR (sh:.Int) row1) + (StencilR (sh:.Int) row0) + stencilR = R.StencilRtup7 + (stencilR @(sh:.Int) @a @row6) (stencilR @(sh:.Int) @a @row5) (stencilR @(sh:.Int) @a @row4) + (stencilR @(sh:.Int) @a @row3) (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) + (stencilR @(sh:.Int) @a @row0) + +instance ( Stencil (sh:.Int) a row8 + , Stencil (sh:.Int) a row7 + , Stencil (sh:.Int) a row6 + , Stencil (sh:.Int) a row5 + , Stencil (sh:.Int) a row4 + , Stencil (sh:.Int) a row3 + , Stencil (sh:.Int) a row2 + , Stencil (sh:.Int) a row1 + , Stencil (sh:.Int) a row0 + ) + => Stencil (sh:.Int:.Int) a (row8, row7, row6, row5, row4, row3, row2, row1, row0) where + type StencilR (sh:.Int:.Int) (row8, row7, row6, row5, row4, row3, row2, row1, row0) = + Tup9 (StencilR (sh:.Int) row8) (StencilR (sh:.Int) row7) (StencilR (sh:.Int) row6) + (StencilR (sh:.Int) row5) (StencilR (sh:.Int) row4) (StencilR (sh:.Int) row3) + (StencilR (sh:.Int) row2) (StencilR (sh:.Int) row1) (StencilR (sh:.Int) row0) + stencilR = R.StencilRtup9 + (stencilR @(sh:.Int) @a @row8) (stencilR @(sh:.Int) @a @row7) (stencilR @(sh:.Int) @a @row6) + (stencilR @(sh:.Int) @a @row5) (stencilR @(sh:.Int) @a @row4) (stencilR @(sh:.Int) @a @row3) + (stencilR @(sh:.Int) @a @row2) (stencilR @(sh:.Int) @a @row1) (stencilR @(sh:.Int) @a @row0) + diff --git a/src/Data/Array/Accelerate/Sugar/Vec.hs b/src/Data/Array/Accelerate/Sugar/Vec.hs new file mode 100644 index 000000000..f6d491555 --- /dev/null +++ b/src/Data/Array/Accelerate/Sugar/Vec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.Sugar.Vec +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Sugar.Vec + where + +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Type +import Data.Primitive.Types +import Data.Primitive.Vec + +import GHC.TypeLits +import GHC.Prim + + +type VecElt a = (Elt a, Prim a, IsSingle a, EltR a ~ a) + +instance (KnownNat n, VecElt a) => Elt (Vec n a) where + type EltR (Vec n a) = Vec n a + eltR = TupRsingle (VectorScalarType (VectorType (fromIntegral (natVal' (proxy# :: Proxy# n))) singleType)) + toElt = id + fromElt = id + diff --git a/src/Data/Array/Accelerate/Test/NoFib/Base.hs b/src/Data/Array/Accelerate/Test/NoFib/Base.hs index f9e76c892..4df85e395 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Base.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Base.hs @@ -14,10 +14,13 @@ 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.Smart +import Data.Array.Accelerate.Sugar.Array +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape +import Data.Array.Accelerate.Trafo.Sharing import Data.Array.Accelerate.Type +import Data.Primitive.Vec import Control.Monad import Data.Primitive.Types diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs index 0c1bbd475..9c2e3f486 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs @@ -23,7 +23,8 @@ module Data.Array.Accelerate.Test.NoFib.Imaginary.DotP ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Array as S +import Data.Array.Accelerate.Sugar.Elt as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -52,15 +53,15 @@ test_dotp runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a) + testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a, Show a) => Gen a -> TestTree testElt e = - testProperty (show (eltType @a)) $ test_dotp' runN e + testProperty (show (eltR @a)) $ test_dotp' runN e test_dotp' - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs index b7b41eb61..42068ee71 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs @@ -23,7 +23,8 @@ module Data.Array.Accelerate.Test.NoFib.Imaginary.SASUM ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Array as S +import Data.Array.Accelerate.Sugar.Elt as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -52,15 +53,15 @@ test_sasum runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a) + testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a, Show a) => Gen a -> TestTree testElt e = - testProperty (show (eltType @a)) $ test_sasum' runN e + testProperty (show (eltR @a)) $ test_sasum' runN e test_sasum' - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs index c0ba90e49..7f2e84e51 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs @@ -23,7 +23,9 @@ module Data.Array.Accelerate.Test.NoFib.Imaginary.SAXPY ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Array as S +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -52,15 +54,15 @@ test_saxpy runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, A.Num a, Similar a) + testElt :: forall a. (P.Num a, A.Num a, Similar a, Show a) => Gen a -> TestTree testElt e = - testProperty (show (eltType @a)) $ test_saxpy' runN e + testProperty (show (eltR @a)) $ test_saxpy' runN e test_saxpy' - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs index 267fc89ad..e6f6430ad 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs @@ -26,7 +26,9 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue264 ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Array as S +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -55,11 +57,11 @@ test_issue264 runN = ] where testElt - :: forall a. (Similar a, P.Num a, A.Num a) + :: forall a. (Similar a, Show a, P.Num a, A.Num a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testProperty "neg.neg" $ test_neg_neg runN e ] @@ -118,7 +120,7 @@ test_not_not_or runN = 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) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs index 9c4042865..9bd8136e5 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs @@ -31,7 +31,8 @@ import Prelude ( fail ) #endif import Data.Array.Accelerate hiding ( fromInteger ) -import Data.Array.Accelerate.Array.Sugar as Sugar +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config @@ -53,11 +54,11 @@ test_issue364 runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall e. (Num e, Eq e, P.Num e, P.Enum e, P.Eq e) + testElt :: forall e. (Show e, Num e, Eq e, P.Num e, P.Enum e, P.Eq e) => Gen e -> TestTree testElt _ = - testGroup (show (eltType @e)) + testGroup (show (eltR @e)) [ testCase "A" $ expectedArray @_ @e Z 64 @=? runN (scanl iappend one) (intervalArray Z 64) , testCase "B" $ expectedArray @_ @e Z 65 @=? runN (scanl iappend one) (intervalArray Z 65) -- failed for integral types ] @@ -89,7 +90,7 @@ intervalArray :: (Shape sh, Elt e, P.Num e, P.Enum e) intervalArray sh n = fromList (sh:.n) . P.concat - $ P.replicate (Sugar.size sh) [ (i,i) | i <- [0.. (P.fromIntegral n-1)] ] + $ P.replicate (S.size sh) [ (i,i) | i <- [0.. (P.fromIntegral n-1)] ] expectedArray :: (Shape sh, Elt e, P.Num e, P.Enum e) => sh @@ -98,5 +99,5 @@ expectedArray :: (Shape sh, Elt e, P.Num e, P.Enum e) expectedArray sh n = fromList (sh:.n+1) $ P.concat - $ P.replicate (Sugar.size sh) $ (-1,-1) : [ (0,i) | i <- [0 .. P.fromIntegral n - 1] ] + $ P.replicate (S.size sh) $ (-1,-1) : [ (0,i) | i <- [0 .. P.fromIntegral n - 1] ] diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs index d07bf63a8..f13531bbe 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs @@ -27,7 +27,7 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue407 ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as A +import Data.Array.Accelerate.Sugar.Elt as S import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty @@ -42,10 +42,10 @@ test_issue407 runN = ] where testElt - :: forall a. (P.Fractional a, A.RealFloat a) + :: forall a. (Show a, P.Fractional a, A.RealFloat a) => TestTree testElt = - testGroup (show (A.eltType @a)) + testGroup (show (eltR @a)) [ testCase "isNaN" $ eNaN @=? runN (A.map A.isNaN) xs , testCase "isInfinite" $ eInf @=? runN (A.map A.isInfinite) xs ] diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs index 7b3c9b122..87f7bc0f8 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs @@ -25,7 +25,7 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue409 ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as A +import Data.Array.Accelerate.Sugar.Elt as S import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty @@ -40,10 +40,10 @@ test_issue409 runN = ] where testElt - :: forall a. (P.Floating a, P.Eq a, A.Floating a) + :: forall a. (Show a, P.Floating a, P.Eq a, A.Floating a) => TestTree testElt = - testGroup (show (A.eltType @a)) + testGroup (show (eltR @a)) [ testCase "A" $ e1 @=? indexArray (runN (A.map f) t1) Z ] where diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs index e7909667e..053b5278e 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs @@ -24,7 +24,9 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Array as S +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -54,18 +56,18 @@ test_backpermute runN = ] where testElt - :: forall a. (Similar a, Elt a) + :: forall a. (Similar a, Elt a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, Slice sh, P.Eq sh) + :: forall sh. (Shape sh, Slice sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -79,7 +81,7 @@ test_backpermute runN = ] test_take - :: (Shape sh, Slice sh, Similar e, P.Eq sh, Elt e) + :: (Shape sh, Slice sh, Show sh, Similar e, Show e, P.Eq sh, Elt e) => RunN -> Gen (sh:.Int) -> Gen e @@ -92,7 +94,7 @@ test_take runN dim e = 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) + :: (Shape sh, Slice sh, Show sh, Similar e, Show e, P.Eq sh, Elt e) => RunN -> Gen (sh:.Int) -> Gen e @@ -105,7 +107,7 @@ test_drop runN dim e = 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) + :: (Shape sh, Shape sh', Show sh, Show sh', P.Eq sh', Similar e, Show e, Elt e) => RunN -> Gen sh -> Gen sh' diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs index deabe823a..3cd23ffa9 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs @@ -26,7 +26,9 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Filter ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Array as S +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -54,18 +56,18 @@ test_filter runN = ] where testIntegralElt - :: forall a. (P.Integral a, A.Integral a, Similar a) + :: forall a. (P.Integral a, A.Integral a, Similar a, Show a) => Gen a -> TestTree testIntegralElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, Slice sh, P.Eq sh) + :: forall sh. (Shape sh, Slice sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -74,18 +76,18 @@ test_filter runN = ] testFloatingElt - :: forall a. (P.Floating a, P.Ord a, A.Floating a, A.Ord a, Similar a) + :: forall a. (P.Floating a, P.Ord a, A.Floating a, A.Ord a, Similar a, Show a) => Gen a -> TestTree testFloatingElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, Slice sh, P.Eq sh) + :: forall sh. (Shape sh, Slice sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -95,7 +97,7 @@ test_filter runN = test_even - :: (Shape sh, Slice sh, Similar e, P.Eq sh, P.Integral e, A.Integral e) + :: (Shape sh, Slice sh, Show sh, Similar e, Show e, P.Eq sh, P.Integral e, A.Integral e) => RunN -> Gen (sh:.Int) -> Gen e @@ -107,7 +109,7 @@ test_even runN dim 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) + :: (Shape sh, Slice sh, Show sh, Similar e, Show e, P.Eq sh, P.Num e, P.Ord e, A.Num e, A.Ord e) => RunN -> Gen (sh:.Int) -> Gen e diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs index 285e88e66..47f5bc41c 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs @@ -25,7 +25,8 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Fold ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -55,19 +56,19 @@ test_fold runN = ] where testElt - :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a) + :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a, Show a) => Gen a -> Gen a -> TestTree testElt e small = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -96,18 +97,18 @@ test_foldSeg runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a) + testElt :: forall a. (P.Num a, P.Ord a , A.Num a, A.Ord a , Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -124,7 +125,7 @@ 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Num e, A.Num e) => RunN -> Gen (sh:.Int) -> Gen e @@ -138,7 +139,7 @@ test_sum runN dim z 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Num e, P.Ord e, A.Num e, A.Ord e) => RunN -> Gen (sh:.Int) -> Gen e @@ -150,7 +151,7 @@ test_mss runN dim e = let !go = runN maximumSegmentSum in go xs ~~~ maximumSegmentSumRef xs test_minimum - :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen (sh:.Int) -> Gen e @@ -162,7 +163,7 @@ test_minimum runN dim e = let !go = runN A.minimum in go xs ~~~ fold1Ref P.min xs test_maximum - :: (Shape sh, Similar e, P.Eq sh, P.Ord e, A.Ord e) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen (sh:.Int) -> Gen e @@ -174,7 +175,7 @@ test_maximum runN dim 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) + :: forall sh e. (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Num e, A.Num e) => RunN -> Gen (sh:.Int) -> Gen e @@ -191,7 +192,7 @@ test_segmented_sum runN dim z 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.Ord e, A.Ord e) + :: forall sh e. (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen (sh:.Int) -> Gen e @@ -206,7 +207,7 @@ test_segmented_minimum runN dim 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.Ord e, A.Ord e) + :: forall sh e. (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen (sh:.Int) -> Gen e diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs index 3e1ebcd15..05c99bda1 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs @@ -28,7 +28,9 @@ 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.Sugar.Array as S +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -60,18 +62,19 @@ test_map runN = testIntegralElt :: forall a. ( P.Integral a, P.FiniteBits a , A.Integral a, A.FiniteBits a - , A.FromIntegral a Double, Similar a ) + , A.FromIntegral a Double + , Similar a, Show a ) => Gen a -> TestTree testIntegralElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim0 , testDim dim1 , testDim dim2 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen sh -> TestTree testDim sh = @@ -92,18 +95,18 @@ test_map runN = ] testFloatingElt - :: forall a. (P.RealFloat a, A.Floating a, A.RealFrac a, Similar a) + :: forall a. (P.RealFloat a, A.Floating a, A.RealFrac a, Similar a, Show a) => (Range a -> Gen a) -> TestTree testFloatingElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim0 , testDim dim1 , testDim dim2 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen sh -> TestTree testDim sh = @@ -144,7 +147,7 @@ test_map runN = test_negate - :: (Shape sh, Similar e, A.Num e, P.Num e, P.Eq sh) + :: (Shape sh, Show sh, Similar e, Show e, A.Num e, P.Num e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -156,7 +159,7 @@ test_negate runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, A.Num e, P.Num e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -168,7 +171,7 @@ test_abs runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, A.Num e, P.Num e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -180,7 +183,7 @@ test_signum runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, A.Bits e, P.Bits e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -192,7 +195,7 @@ test_complement runN dim e = let !go = runN (A.map A.complement) in go xs ~~~ mapRef P.complement xs test_popCount - :: (Shape sh, A.Bits e, P.Bits e, P.Eq sh) + :: (Shape sh, Show sh, Show e, A.Bits e, P.Bits e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -204,7 +207,7 @@ test_popCount runN dim e = let !go = runN (A.map A.popCount) in go xs ~~~ mapRef P.popCount xs test_countLeadingZeros - :: (Shape sh, A.FiniteBits e, P.FiniteBits e, P.Eq sh) + :: (Shape sh, Show sh, Show e, A.FiniteBits e, P.FiniteBits e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -216,7 +219,7 @@ test_countLeadingZeros runN dim e = let !go = runN (A.map A.countLeadingZeros) in go xs ~~~ mapRef countLeadingZerosRef xs test_countTrailingZeros - :: (Shape sh, A.FiniteBits e, P.FiniteBits e, P.Eq sh) + :: (Shape sh, Show sh, Show e, A.FiniteBits e, P.FiniteBits e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -228,7 +231,7 @@ test_countTrailingZeros runN dim e = let !go = runN (A.map A.countTrailingZeros) in go xs ~~~ mapRef countTrailingZerosRef xs test_fromIntegral - :: forall sh e. (Shape sh, P.Eq sh, P.Integral e, A.Integral e, A.FromIntegral e Double) + :: forall sh e. (Shape sh, Show sh, Show e, P.Eq sh, P.Integral e, A.Integral e, A.FromIntegral e Double) => RunN -> Gen sh -> Gen e @@ -240,7 +243,7 @@ test_fromIntegral runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Fractional e, A.Fractional e) => RunN -> Gen sh -> Gen e @@ -252,7 +255,7 @@ test_recip runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -264,7 +267,7 @@ test_sin runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -276,7 +279,7 @@ test_cos runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -288,7 +291,7 @@ test_tan runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -300,7 +303,7 @@ test_asin runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -312,7 +315,7 @@ test_acos runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -324,7 +327,7 @@ test_atan runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -336,7 +339,7 @@ test_asinh runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -348,7 +351,7 @@ test_acosh runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -360,7 +363,7 @@ test_atanh runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -372,7 +375,7 @@ test_exp runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -384,7 +387,7 @@ test_sqrt runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -396,7 +399,7 @@ test_log runN dim e = let !go = runN (A.map log) in go xs ~~~ mapRef log xs test_truncate - :: forall sh e. (Shape sh, P.Eq sh, P.RealFrac e, A.RealFrac e) + :: forall sh e. (Shape sh, Show sh, Show e, P.Eq sh, P.RealFrac e, A.RealFrac e) => RunN -> Gen sh -> Gen e @@ -408,7 +411,7 @@ test_truncate runN dim e = let !go = runN (A.map A.truncate) in go xs ~~~ mapRef (P.truncate :: e -> Int) xs test_round - :: forall sh e. (Shape sh, P.Eq sh, P.RealFrac e, A.RealFrac e) + :: forall sh e. (Shape sh, Show sh, Show e, P.Eq sh, P.RealFrac e, A.RealFrac e) => RunN -> Gen sh -> Gen e @@ -420,7 +423,7 @@ test_round runN dim e = let !go = runN (A.map A.round) in go xs ~~~ mapRef (P.round :: e -> Int) xs test_floor - :: forall sh e. (Shape sh, P.Eq sh, P.RealFrac e, A.RealFrac e) + :: forall sh e. (Shape sh, Show sh, Show e, P.Eq sh, P.RealFrac e, A.RealFrac e) => RunN -> Gen sh -> Gen e @@ -432,7 +435,7 @@ test_floor runN dim e = let !go = runN (A.map A.floor) in go xs ~~~ mapRef (P.floor :: e -> Int) xs test_ceiling - :: forall sh e. (Shape sh, P.Eq sh, P.RealFrac e, A.RealFrac e) + :: forall sh e. (Shape sh, Show sh, Show e, P.Eq sh, P.RealFrac e, A.RealFrac e) => RunN -> Gen sh -> Gen e @@ -448,7 +451,7 @@ test_ceiling runN dim e = -- ------------------------ mapRef :: (Shape sh, Elt a, Elt b) => (a -> b) -> Array sh a -> Array sh b -mapRef f xs = fromFunction (arrayShape xs) (\ix -> f (xs Sugar.! ix)) +mapRef f xs = fromFunction (arrayShape xs) (\ix -> f (xs S.! ix)) countLeadingZerosRef :: P.FiniteBits a => a -> Int #if __GLASGOW_HASKELL__ >= 710 diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs index bbbc395d5..9bd22eb20 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs @@ -21,18 +21,15 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Permute ( ) where -import Control.Monad -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 qualified Data.Array.Accelerate.Array.Representation as R import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Sugar.Array as S +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar +import qualified Data.Array.Accelerate.Representation.Array as R import Hedgehog import qualified Hedgehog.Gen as Gen @@ -41,6 +38,11 @@ import qualified Hedgehog.Range as Range import Test.Tasty import Test.Tasty.Hedgehog +import Control.Monad +import System.IO.Unsafe +import Prelude as P +import qualified Data.Set as Set + test_permute :: RunN -> TestTree test_permute runN = @@ -59,18 +61,18 @@ test_permute runN = ] where testElt - :: forall a. (Similar a, P.Num a, A.Num a) + :: forall a. (Similar a, P.Num a, A.Num a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. Shape sh + :: forall sh. (Shape sh, Show sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -86,7 +88,7 @@ test_permute runN = test_scatter - :: forall sh sh' e. (Shape sh, Shape sh', P.Eq sh', Similar e, Elt e) + :: forall sh sh' e. (Shape sh, Shape sh', Show sh, Show sh', P.Eq sh', Similar e, Elt e, Show e) => RunN -> Gen sh -> Gen sh' @@ -121,7 +123,7 @@ test_scatter runN dim dim' e = test_accumulate - :: (Shape sh, Shape sh', P.Eq sh', Similar e, P.Num e, A.Num e) + :: (Shape sh, Shape sh', Show sh, Show sh', P.Eq sh', Similar e, P.Num e, A.Num e, Show e) => RunN -> Gen sh -> Gen sh' @@ -153,7 +155,7 @@ permuteRef permuteRef f def@(Array (R.Array _ aold)) p arr@(Array (R.Array _ anew)) = unsafePerformIO $ do let - tp = S.eltType @e + tp = S.eltR @e sh = S.shape arr sh' = S.shape def n = S.size sh @@ -166,9 +168,9 @@ permuteRef f def@(Array (R.Array _ aold)) p arr@(Array (R.Array _ anew)) = -- unless (ix' P.== S.ignore) $ do let i' = S.toIndex sh' ix' - x <- toElt <$> unsafeReadArrayData tp anew i - x' <- toElt <$> unsafeReadArrayData tp aold i' - unsafeWriteArrayData tp aold i' (fromElt (f x x')) + x <- toElt <$> readArrayData tp anew i + x' <- toElt <$> readArrayData tp aold i' + writeArrayData tp aold i' (fromElt (f x x')) -- go (i+1) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs index 9e728f591..620f40419 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -23,10 +24,13 @@ import Control.Lens ( view, _1, import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Array as S +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config -import Data.Array.Accelerate.Type +import Data.Primitive.Vec +import Data.Primitive.Types import Hedgehog import qualified Hedgehog.Gen as Gen @@ -51,16 +55,16 @@ test_simd runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall e. (VecElt e, P.Eq e) + testElt :: forall e. (VecElt e, P.Eq e, Show e) => Gen e -> TestTree testElt e = - testGroup (show (eltType @e)) + testGroup (show (eltR @e)) [ testExtract e , testInject e ] - testExtract :: forall e. (VecElt e, P.Eq e) + testExtract :: forall e. (VecElt e, P.Eq e, Show e) => Gen e -> TestTree testExtract e = @@ -70,7 +74,7 @@ test_simd runN = , testProperty "V4" $ test_extract_v4 runN dim1 e ] - testInject :: forall e. (VecElt e, P.Eq e) + testInject :: forall e. (VecElt e, P.Eq e, Show e) => Gen e -> TestTree testInject e = @@ -82,7 +86,7 @@ test_simd runN = test_extract_v2 - :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) + :: (Shape sh, Show sh, Show e, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -95,7 +99,7 @@ test_extract_v2 runN dim e = let !go = runN (A.map (view _m . unpackVec2')) in go xs === mapRef (view _l . unpackVec2) xs test_extract_v3 - :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) + :: (Shape sh, Show sh, Show e, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -108,7 +112,7 @@ test_extract_v3 runN dim e = let !go = runN (A.map (view _m . unpackVec3')) in go xs === mapRef (view _l . unpackVec3) xs test_extract_v4 - :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) + :: (Shape sh, Show sh, Show e, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -121,7 +125,7 @@ test_extract_v4 runN dim e = let !go = runN (A.map (view _m . unpackVec4')) in go xs === mapRef (view _l . unpackVec4) xs test_inject_v2 - :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) + :: (Shape sh, Show sh, Show e, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -135,7 +139,7 @@ test_inject_v2 runN dim e = let !go = runN (A.zipWith A.V2) in go xs ys === zipWithRef Vec2 xs ys test_inject_v3 - :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) + :: (Shape sh, Show sh, Show e, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -151,7 +155,7 @@ test_inject_v3 runN dim e = let !go = runN (A.zipWith3 A.V3) in go xs ys zs === zipWith3Ref Vec3 xs ys zs test_inject_v4 - :: (Shape sh, VecElt e, P.Eq e, P.Eq sh) + :: (Shape sh, Show sh, Show e, VecElt e, P.Eq e, P.Eq sh) => RunN -> Gen sh -> Gen e @@ -169,6 +173,15 @@ test_inject_v4 runN dim e = let !go = runN (A.zipWith4 A.V4) in go xs ys zs ws === zipWith4Ref Vec4 xs ys zs ws +unpackVec2 :: Prim e => Vec2 e -> (e, e) +unpackVec2 (Vec2 a b) = (a, b) + +unpackVec3 :: Prim e => Vec3 e -> (e, e, e) +unpackVec3 (Vec3 a b c) = (a, b, c) + +unpackVec4 :: Prim e => Vec4 e -> (e, e, e, e) +unpackVec4 (Vec4 a b c d) = (a, b, c, d) + unpackVec2' :: VecElt e => Exp (Vec2 e) -> (Exp e, Exp e) unpackVec2' (A.V2 a b) = (a, b) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs index a327b050a..d2c405d53 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs @@ -30,7 +30,8 @@ module Data.Array.Accelerate.Test.NoFib.Prelude.Scan ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -60,18 +61,18 @@ test_scanl runN = ] where testElt - :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a) + :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -96,18 +97,18 @@ test_scanl1 runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a) + testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -131,18 +132,18 @@ test_scanl' runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a) + testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -167,18 +168,18 @@ test_scanr runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a) + testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -203,18 +204,18 @@ test_scanr1 runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a) + testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -238,18 +239,18 @@ test_scanr' runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a) + testElt :: forall a. (P.Num a, P.Eq a, A.Num a, A.Eq a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -274,18 +275,18 @@ test_scanlSeg runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, A.Num a, Similar a) + testElt :: forall a. (P.Num a, A.Num a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, Slice sh, P.Eq sh) + :: forall sh. (Shape sh, Slice sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -309,18 +310,18 @@ test_scanl1Seg runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, A.Num a, Similar a) + testElt :: forall a. (P.Num a, A.Num a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, Slice sh, P.Eq sh) + :: forall sh. (Shape sh, Slice sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -343,18 +344,18 @@ test_scanl'Seg runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, A.Num a, Similar a) + testElt :: forall a. (P.Num a, A.Num a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, Slice sh, P.Eq sh) + :: forall sh. (Shape sh, Slice sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -378,18 +379,18 @@ test_scanrSeg runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, A.Num a, Similar a) + testElt :: forall a. (P.Num a, A.Num a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, Slice sh, P.Eq sh) + :: forall sh. (Shape sh, Slice sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -413,18 +414,18 @@ test_scanr1Seg runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, A.Num a, Similar a) + testElt :: forall a. (P.Num a, A.Num a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, Slice sh, P.Eq sh) + :: forall sh. (Shape sh, Slice sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -447,18 +448,18 @@ test_scanr'Seg runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, A.Num a, Similar a) + testElt :: forall a. (P.Num a, A.Num a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim1 , testDim dim2 , testDim dim3 ] where testDim - :: forall sh. (Shape sh, Slice sh, P.Eq sh) + :: forall sh. (Shape sh, Slice sh, Show sh, P.Eq sh) => Gen (sh:.Int) -> TestTree testDim sh = @@ -472,7 +473,7 @@ 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -486,7 +487,7 @@ test_scanl_sum runN dim z 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -498,7 +499,7 @@ test_scanl1_sum runN dim 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -512,7 +513,7 @@ test_scanl'_sum runN dim z 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -525,7 +526,7 @@ test_scanr_sum runN dim z 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -537,7 +538,7 @@ test_scanr1_sum runN dim 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -551,7 +552,7 @@ test_scanr'_sum runN dim z 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -563,7 +564,7 @@ test_scanl_interval runN dim 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -575,7 +576,7 @@ test_scanl1_interval runN dim 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -587,7 +588,7 @@ test_scanl'_interval runN dim 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -599,7 +600,7 @@ test_scanr_interval runN dim 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -611,7 +612,7 @@ test_scanr1_interval runN dim 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) + :: (Shape sh, Show sh, Similar e, P.Eq sh, P.Eq e, P.Num e, A.Eq e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -623,7 +624,7 @@ test_scanr'_interval runN dim 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) + :: forall sh e. (Shape sh, Slice sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -640,7 +641,7 @@ test_scanlSeg_sum runN dim z 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) + :: forall sh e. (Shape sh, Slice sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -655,7 +656,7 @@ test_scanl1Seg_sum runN dim 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) + :: forall sh e. (Shape sh, Slice sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -672,7 +673,7 @@ test_scanl'Seg_sum runN dim z 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) + :: forall sh e. (Shape sh, Slice sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -689,7 +690,7 @@ test_scanrSeg_sum runN dim z 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) + :: forall sh e. (Shape sh, Slice sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e @@ -704,7 +705,7 @@ test_scanr1Seg_sum runN dim 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) + :: forall sh e. (Shape sh, Slice sh, Show sh, Similar e, P.Eq sh, P.Num e, A.Num e, Show e) => RunN -> Gen (sh:.Int) -> Gen e diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs index e7c4eaefb..d4188a550 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs @@ -28,7 +28,9 @@ 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.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Array as S +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Type import Data.Array.Accelerate.Test.NoFib.Base @@ -60,11 +62,11 @@ test_stencil runN = ] where testElt - :: forall a. (P.Num a, A.Num a, Similar a) + :: forall a. (P.Num a, A.Num a, Similar a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim1 , testDim2 , testDim3 @@ -96,7 +98,7 @@ test_stencil runN = test_stencil3 - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property @@ -115,7 +117,7 @@ test_stencil3 runN e = go xs ~~~ stencil3Ref r b xs test_stencil5 - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property @@ -134,7 +136,7 @@ test_stencil5 runN e = go xs ~~~ stencil5Ref r b xs test_stencil7 - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property @@ -153,7 +155,7 @@ test_stencil7 runN e = go xs ~~~ stencil7Ref r b xs test_stencil9 - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property @@ -173,7 +175,7 @@ test_stencil9 runN e = test_stencil3x3 - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property @@ -194,7 +196,7 @@ test_stencil3x3 runN e = go xs ~~~ stencil3x3Ref r b xs test_stencil5x5 - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property @@ -215,7 +217,7 @@ test_stencil5x5 runN e = go xs ~~~ stencil5x5Ref r b xs test_stencil7x7 - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property @@ -236,7 +238,7 @@ test_stencil7x7 runN e = go xs ~~~ stencil7x7Ref r b xs test_stencil9x9 - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property @@ -257,7 +259,7 @@ test_stencil9x9 runN e = go xs ~~~ stencil9x9Ref r b xs test_stencil3x3x3 - :: (P.Num e, A.Num e, Similar e) + :: (P.Num e, A.Num e, Similar e, Show e) => RunN -> Gen e -> Property @@ -625,11 +627,11 @@ stencil3x3x3Ref st bnd arr = bound :: forall sh e. Shape sh => SimpleBoundary e -> sh -> sh -> Either e sh bound bnd sh0 ix0 = - case go (eltType @sh) (fromElt sh0) (fromElt ix0) of + case go (eltR @sh) (fromElt sh0) (fromElt ix0) of Left e -> Left e Right ix' -> Right (toElt ix') where - go :: TupleType t -> t -> t -> Either e t + go :: TypeR t -> t -> t -> Either e t go TupRunit () () = Right () go (TupRpair tsh tsz) (sh,sz) (ih,iz) = go tsh sh ih `addDim` go tsz sz iz go (TupRsingle t) sh i diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs index d5324b1c0..d52058280 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs @@ -27,11 +27,13 @@ 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.Sugar.Elt import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar +import qualified Data.Array.Accelerate.Sugar.Array as S +import qualified Data.Array.Accelerate.Sugar.Shape as S import Hedgehog import qualified Hedgehog.Gen as Gen @@ -60,22 +62,22 @@ test_zipWith runN = testIntegralElt :: forall a. ( P.Integral a, P.FiniteBits a , A.Integral a, A.FiniteBits a - , Similar a ) + , Similar a, Show a ) => Gen a -> TestTree testIntegralElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim0 , testDim dim1 , testDim dim2 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh, Show sh) => Gen sh -> TestTree testDim sh = - testGroup ("DIM" P.++ show (rank @sh)) + testGroup ("DIM" P.++ show (S.rank @sh)) [ -- operators on Num testProperty "(+)" $ test_plus runN sh e , testProperty "(-)" $ test_minus runN sh e @@ -110,22 +112,22 @@ test_zipWith runN = ] testFloatingElt - :: forall a. (P.RealFloat a, A.RealFloat a, Similar a) + :: forall a. (P.RealFloat a, A.RealFloat a, Similar a, Show a) => (Range a -> Gen a) -> TestTree testFloatingElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @a)) [ testDim dim0 , testDim dim1 , testDim dim2 ] where testDim - :: forall sh. (Shape sh, P.Eq sh) + :: forall sh. (Shape sh, Show sh, P.Eq sh) => Gen sh -> TestTree testDim sh = - testGroup ("DIM" P.++ show (rank @sh)) + testGroup ("DIM" P.++ show (S.rank @sh)) [ -- operators on Num testProperty "(+)" $ test_plus runN sh (full e) , testProperty "(-)" $ test_minus runN sh (full e) @@ -156,7 +158,7 @@ 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Num e, A.Num e) => RunN -> Gen sh -> Gen e @@ -170,7 +172,7 @@ test_plus runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Num e, A.Num e) => RunN -> Gen sh -> Gen e @@ -184,7 +186,7 @@ test_minus runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Num e, A.Num e) => RunN -> Gen sh -> Gen e @@ -198,7 +200,7 @@ test_mult runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Integral e, A.Integral e) => RunN -> Gen sh -> Gen e @@ -212,7 +214,7 @@ test_quot runN dim e = 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Integral e, A.Integral e) => RunN -> Gen sh -> Gen e @@ -226,7 +228,7 @@ test_rem runN dim e = 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Integral e, A.Integral e) => RunN -> Gen sh -> Gen e @@ -240,7 +242,7 @@ test_quotRem runN dim e = 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Integral e, A.Integral e) => RunN -> Gen sh -> Gen e @@ -254,7 +256,7 @@ test_idiv runN dim e = 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Eq e, P.Fractional e, A.Fractional e) => RunN -> Gen sh -> Gen e @@ -268,7 +270,7 @@ test_fdiv runN dim e = 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -282,7 +284,7 @@ test_pow runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Floating e, A.Floating e) => RunN -> Gen sh -> Gen e @@ -296,7 +298,7 @@ test_logBase runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.RealFloat e, A.RealFloat e) => RunN -> Gen sh -> Gen e @@ -310,7 +312,7 @@ test_atan2 runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Integral e, A.Integral e) => RunN -> Gen sh -> Gen e @@ -324,7 +326,7 @@ test_mod runN dim e = 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Integral e, A.Integral e) => RunN -> Gen sh -> Gen e @@ -338,7 +340,7 @@ test_divMod runN dim e = 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Bits e, A.Bits e) => RunN -> Gen sh -> Gen e @@ -352,7 +354,7 @@ test_band runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Bits e, A.Bits e) => RunN -> Gen sh -> Gen e @@ -366,7 +368,7 @@ test_bor runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Bits e, A.Bits e) => RunN -> Gen sh -> Gen e @@ -380,7 +382,7 @@ test_xor runN dim 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) + :: forall sh e. (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.FiniteBits e, A.FiniteBits e) => RunN -> Gen sh -> Gen e @@ -395,7 +397,7 @@ test_shift runN dim e = 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) + :: forall sh e. (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.FiniteBits e, A.FiniteBits e) => RunN -> Gen sh -> Gen e @@ -410,7 +412,7 @@ test_shiftL runN dim e = 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) + :: forall sh e. (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.FiniteBits e, A.FiniteBits e) => RunN -> Gen sh -> Gen e @@ -425,7 +427,7 @@ test_shiftR runN dim e = 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) + :: forall sh e. (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.FiniteBits e, A.FiniteBits e) => RunN -> Gen sh -> Gen e @@ -440,7 +442,7 @@ test_rotate runN dim e = 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) + :: forall sh e. (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.FiniteBits e, A.FiniteBits e) => RunN -> Gen sh -> Gen e @@ -455,7 +457,7 @@ test_rotateL runN dim e = 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) + :: forall sh e. (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.FiniteBits e, A.FiniteBits e) => RunN -> Gen sh -> Gen e @@ -470,7 +472,7 @@ test_rotateR runN dim e = let !go = runN (A.zipWith A.rotateR) in go xs ys ~~~ zipWithRef P.rotateR xs ys test_lt - :: (Shape sh, P.Eq sh, P.Ord e, A.Ord e) + :: (Shape sh, Show sh, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen sh -> Gen e @@ -484,7 +486,7 @@ test_lt runN dim e = let !go = runN (A.zipWith (A.<)) in go xs ys ~~~ zipWithRef (P.<) xs ys test_gt - :: (Shape sh, P.Eq sh, P.Ord e, A.Ord e) + :: (Shape sh, Show sh, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen sh -> Gen e @@ -498,7 +500,7 @@ test_gt runN dim e = let !go = runN (A.zipWith (A.>)) in go xs ys ~~~ zipWithRef (P.>) xs ys test_lte - :: (Shape sh, P.Eq sh, P.Ord e, A.Ord e) + :: (Shape sh, Show sh, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen sh -> Gen e @@ -512,7 +514,7 @@ test_lte runN dim e = let !go = runN (A.zipWith (A.<=)) in go xs ys ~~~ zipWithRef (P.<=) xs ys test_gte - :: (Shape sh, P.Eq sh, P.Ord e, A.Ord e) + :: (Shape sh, Show sh, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen sh -> Gen e @@ -526,7 +528,7 @@ test_gte runN dim e = let !go = runN (A.zipWith (A.>=)) in go xs ys ~~~ zipWithRef (P.>=) xs ys test_eq - :: (Shape sh, P.Eq sh, P.Ord e, A.Ord e) + :: (Shape sh, Show sh, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen sh -> Gen e @@ -540,7 +542,7 @@ test_eq runN dim e = let !go = runN (A.zipWith (A.==)) in go xs ys ~~~ zipWithRef (P.==) xs ys test_neq - :: (Shape sh, P.Eq sh, P.Ord e, A.Ord e) + :: (Shape sh, Show sh, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen sh -> Gen e @@ -554,7 +556,7 @@ test_neq runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen sh -> Gen e @@ -568,7 +570,7 @@ test_min runN dim 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) + :: (Shape sh, Show sh, Similar e, Show e, P.Eq sh, P.Ord e, A.Ord e) => RunN -> Gen sh -> Gen e diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs index 34b4b8915..c3e49e471 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs @@ -25,7 +25,8 @@ module Data.Array.Accelerate.Test.NoFib.Spectral.BlackScholes ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Elt as S +import Data.Array.Accelerate.Sugar.Array as S import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -47,15 +48,15 @@ test_blackscholes runN = ] where testElt - :: forall a. (P.Floating a, P.Ord a, A.Floating a, A.Ord a , Similar a) + :: forall a. (P.Floating a, P.Ord a, A.Floating a, A.Ord a , Similar a, Show a) => (Range a -> Gen a) -> TestTree testElt e = - testProperty (show (eltType @a)) $ test_blackscholes' runN e + testProperty (show (eltR @a)) $ test_blackscholes' runN e test_blackscholes' - :: (P.Floating a, P.Ord a, A.Floating a, A.Ord a, Similar a) + :: (P.Floating a, P.Ord a, A.Floating a, A.Ord a, Similar a, Show a) => RunN -> (Range a -> Gen a) -> Property diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs index 1ec13bac3..2850a3ebb 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs @@ -29,7 +29,7 @@ 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, eltType ) +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -57,18 +57,18 @@ test_radixsort runN = -- , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (Similar a, P.Ord a, Radix a) + testElt :: forall a. (Similar a, P.Ord a, Radix a, Show a) => Gen a -> TestTree testElt e = - testGroup (show (eltType @a)) + testGroup (show (eltR @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) + :: (P.Ord e, Radix e, Similar e, Show e) => RunN -> Gen e -> Property @@ -79,7 +79,7 @@ test_sort_ascending runN e = let !go = runN radixsort in go xs ~~~ sortRef P.compare xs test_sort_descending - :: (P.Ord e, Radix e, Similar e) + :: (P.Ord e, Radix e, Similar e, Show e) => RunN -> Gen e -> Property @@ -90,7 +90,7 @@ test_sort_descending runN 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) + :: (P.Ord k, Radix k, Similar k, Show k, Elt v, Similar v, Show v) => RunN -> Gen k -> Gen v @@ -183,5 +183,5 @@ radixsortBy rdx arr = foldr1 (>->) (P.map radixPass [0..p-1]) arr -- 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)) +sortRef cmp xs = fromList (arrayShape xs) (sortBy cmp (toList xs)) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs index 31c1a8404..874953632 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs @@ -24,7 +24,7 @@ module Data.Array.Accelerate.Test.NoFib.Spectral.SMVM ( import Prelude as P import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Sugar as S +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config import Data.Array.Accelerate.Test.Similar @@ -45,14 +45,14 @@ test_smvm runN = , at @TestDouble $ testElt f64 ] where - testElt :: forall a. (P.Num a, A.Num a, Similar a) + testElt :: forall a. (P.Num a, A.Num a, Similar a, Show a) => Gen a -> TestTree testElt e = - testProperty (show (eltType @a)) $ test_smvm' runN e + testProperty (show (eltR @a)) $ test_smvm' runN e -test_smvm' :: (A.Num e, P.Num e, Similar e) => RunN -> Gen e -> Property +test_smvm' :: (A.Num e, P.Num e, Similar e, Show e) => RunN -> Gen e -> Property test_smvm' runN e = property $ do (smat, cols) <- forAll (sparseMatrix e) @@ -66,7 +66,7 @@ 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) + let nnz = P.sum (toList seg) smat <- array (Z:.nnz) ((,) <$> Gen.int (Range.linear 0 (cols-1)) <*> e) return ((seg,smat), cols) @@ -86,7 +86,7 @@ smvm smat vec smvmRef :: (Elt a, P.Num a) => SparseMatrix a -> Vector a -> Vector a smvmRef (segd, smat) vec = - fromList (S.shape segd) + fromList (arrayShape segd) [ P.sum [ val * indexArray vec (Z :. i) | (i,val) <- row ] | row <- splitPlaces (toList segd) (toList smat) ] diff --git a/src/Data/Array/Accelerate/Test/Similar.hs b/src/Data/Array/Accelerate/Test/Similar.hs index c70dba4cf..da802e0fa 100644 --- a/src/Data/Array/Accelerate/Test/Similar.hs +++ b/src/Data/Array/Accelerate/Test/Similar.hs @@ -17,8 +17,10 @@ module Data.Array.Accelerate.Test.Similar where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Data.Complex +import Data.Array.Accelerate.Sugar.Array +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape import Data.Array.Accelerate.Type import Hedgehog diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index 9cadbe8c4..d5c3005c2 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo @@ -18,49 +13,28 @@ module Data.Array.Accelerate.Trafo ( -- * HOAS -> de Bruijn conversion - -- ** Options - module Data.Array.Accelerate.Trafo.Config, - -- ** Array computations convertAcc, convertAccWith, -- ** Array functions - Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr, + Afunction, ArraysFunctionR, convertAfun, convertAfunWith, -- ** Sequence computations -- convertSeq, convertSeqWith, -- ** Scalar expressions - Function, FunctionR, + Function, EltFunctionR, convertExp, convertFun, - -- * Fusion - DelayedAcc, DelayedOpenAcc(..), - DelayedAfun, DelayedOpenAfun, - - -- * Substitution - module Data.Array.Accelerate.Trafo.Substitution, - - -- * Term equality - Match(..), (:~:)(..), - - -- ** Auxiliary - matchDelayedOpenAcc, - encodeDelayedOpenAcc, - ) where -import Control.DeepSeq -import Data.Typeable - +import Data.Array.Accelerate.Sugar.Array ( ArraysR ) +import Data.Array.Accelerate.Sugar.Elt ( EltR ) import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Array.Sugar ( ArrRepr, EltRepr ) -import Data.Array.Accelerate.Trafo.Base ( Match(..), matchDelayedOpenAcc, encodeDelayedOpenAcc ) import Data.Array.Accelerate.Trafo.Config -import Data.Array.Accelerate.Trafo.Fusion ( DelayedAcc, DelayedOpenAcc(..), DelayedAfun, DelayedOpenAfun ) -import Data.Array.Accelerate.Trafo.Sharing ( Function, FunctionR, Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr, EltReprFunctionR ) -import Data.Array.Accelerate.Trafo.Substitution +import Data.Array.Accelerate.Trafo.Delayed +import Data.Array.Accelerate.Trafo.Sharing ( Afunction, ArraysFunctionR, Function, EltFunctionR ) import qualified Data.Array.Accelerate.AST as AST import qualified Data.Array.Accelerate.Trafo.Fusion as Fusion import qualified Data.Array.Accelerate.Trafo.LetSplit as LetSplit @@ -68,6 +42,8 @@ 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 +import Control.DeepSeq + #ifdef ACCELERATE_DEBUG import Text.Printf import System.IO.Unsafe @@ -82,10 +58,10 @@ import Data.Array.Accelerate.Debug.Timed -- | Convert a closed array expression to de Bruijn form while also -- incorporating sharing observation and array fusion. -- -convertAcc :: Acc arrs -> DelayedAcc (ArrRepr arrs) +convertAcc :: Acc arrs -> DelayedAcc (ArraysR arrs) convertAcc = convertAccWith defaultOptions -convertAccWith :: Config -> Acc arrs -> DelayedAcc (ArrRepr arrs) +convertAccWith :: Config -> Acc arrs -> DelayedAcc (ArraysR arrs) convertAccWith config = phase "array-fusion" (Fusion.convertAccWith config) . phase "array-split-lets" LetSplit.convertAcc @@ -96,10 +72,10 @@ convertAccWith config -- | Convert a unary function over array computations, incorporating sharing -- observation and array fusion -- -convertAfun :: Afunction f => f -> DelayedAfun (AreprFunctionR f) +convertAfun :: Afunction f => f -> DelayedAfun (ArraysFunctionR f) convertAfun = convertAfunWith defaultOptions -convertAfunWith :: Afunction f => Config -> f -> DelayedAfun (AreprFunctionR f) +convertAfunWith :: Afunction f => Config -> f -> DelayedAfun (ArraysFunctionR f) convertAfunWith config = phase "array-fusion" (Fusion.convertAfunWith config) . phase "array-split-lets" LetSplit.convertAfun @@ -110,18 +86,18 @@ convertAfunWith config -- | Convert a closed scalar expression, incorporating sharing observation and -- optimisation. -- -convertExp :: Exp e -> AST.Exp () (EltRepr e) +convertExp :: Exp e -> AST.Exp () (EltR e) convertExp - = phase "exp-simplify" Rewrite.simplify -- XXX: only if simplification is enabled + = phase "exp-simplify" Rewrite.simplifyExp . phase "sharing-recovery" Sharing.convertExp -- | Convert closed scalar functions, incorporating sharing observation and -- optimisation. -- -convertFun :: Function f => f -> AST.Fun () (EltReprFunctionR f) +convertFun :: Function f => f -> AST.Fun () (EltFunctionR f) convertFun - = phase "exp-simplify" Rewrite.simplify + = phase "exp-simplify" Rewrite.simplifyFun . phase "sharing-recovery" Sharing.convertFun {-- @@ -159,6 +135,6 @@ phase n f x = unsafePerformIO $ do 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 +phase _ f = f #endif diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index b24e11b42..2d9408cbe 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -28,24 +28,24 @@ module Data.Array.Accelerate.Trafo.Algebra ( ) where +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Pretty.Print ( primOperator, isInfix, opName ) +import Data.Array.Accelerate.Trafo.Environment +import Data.Array.Accelerate.Type + +import qualified Data.Array.Accelerate.Debug.Stats as Stats + import Data.Bits import Data.Char import Data.Monoid -import Data.Text ( Text ) +import Data.Text ( Text ) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Text -import GHC.Float ( float2Double, double2Float ) -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.Pretty.Print ( primOperator, isInfix, opName ) -import Data.Array.Accelerate.Trafo.Base -import Data.Array.Accelerate.Type - -import qualified Data.Array.Accelerate.Debug.Stats as Stats +import GHC.Float ( float2Double, double2Float ) +import Prelude hiding ( exp ) +import qualified Prelude as P -- Propagate constant expressions, which are either constant valued expressions @@ -64,7 +64,7 @@ propagate env = cvtE PrimConst c -> Just (evalPrimConst c) Evar (Var _ ix) | e <- prjExp ix env - , Nothing <- match exp e -> cvtE e + , Nothing <- matchOpenExp exp e -> cvtE e Nil -> Just () Pair e1 e2 -> (,) <$> cvtE e1 <*> cvtE e2 _ -> Nothing @@ -324,7 +324,7 @@ evalSub' ty (untup2 -> Just (x,y)) env $ Just . snd $ evalPrimApp env (PrimAdd ty) (Const tp (-b) `Pair` x) -- (Tuple $ NilTup `SnocTup` Const (fromElt (-b)) `SnocTup` x) - | Just Refl <- match x y + | Just Refl <- matchOpenExp x y = Stats.ruleFired "x-x" $ Just $ Const tp 0 where diff --git a/src/Data/Array/Accelerate/Trafo/Config.hs b/src/Data/Array/Accelerate/Trafo/Config.hs index 488d02001..e43f6a4f8 100644 --- a/src/Data/Array/Accelerate/Trafo/Config.hs +++ b/src/Data/Array/Accelerate/Trafo/Config.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Config -- Copyright : [2008..2019] The Accelerate Team diff --git a/src/Data/Array/Accelerate/Trafo/Delayed.hs b/src/Data/Array/Accelerate/Trafo/Delayed.hs new file mode 100644 index 000000000..ab2300a44 --- /dev/null +++ b/src/Data/Array/Accelerate/Trafo/Delayed.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Delayed +-- Copyright : [2012..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- 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. +-- + +module Data.Array.Accelerate.Trafo.Delayed + where + +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.Analysis.Hash +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Trafo.Substitution + +import Data.Array.Accelerate.Debug.Stats as Stats + +import Control.DeepSeq +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra + + +type DelayedAcc = DelayedOpenAcc () +type DelayedAfun = PreOpenAfun DelayedOpenAcc () +type DelayedOpenAfun = PreOpenAfun DelayedOpenAcc + +-- type DelayedOpenSeq = PreOpenSeq DelayedOpenAcc +-- data DelayedSeq t where +-- DelayedSeq :: Extend DelayedOpenAcc () aenv +-- -> DelayedOpenSeq aenv () t +-- -> DelayedSeq t + +data DelayedOpenAcc aenv a where + Manifest :: PreOpenAcc DelayedOpenAcc aenv a + -> DelayedOpenAcc aenv a + + Delayed :: + { reprD :: ArrayR (Array sh e) + , extentD :: Exp aenv sh + , indexD :: Fun aenv (sh -> e) + , linearIndexD :: Fun aenv (Int -> e) + } -> DelayedOpenAcc aenv (Array sh e) + +instance HasArraysR DelayedOpenAcc where + arraysR (Manifest a) = arraysR a + arraysR Delayed{..} = TupRsingle reprD + +instance Rebuildable DelayedOpenAcc where + type AccClo DelayedOpenAcc = DelayedOpenAcc + rebuildPartial v = \case + Manifest pacc -> Manifest <$> rebuildPartial v pacc + Delayed{..} -> (\e i l -> Delayed reprD (unOpenAccExp e) (unOpenAccFun i) (unOpenAccFun l)) + <$> rebuildPartial v (OpenAccExp extentD) + <*> rebuildPartial v (OpenAccFun indexD) + <*> rebuildPartial v (OpenAccFun linearIndexD) + +instance Sink DelayedOpenAcc where + weaken k = Stats.substitution "weaken" . rebuildA (rebuildWeakenVar k) + +instance NFData (DelayedOpenAfun aenv t) where + rnf = rnfPreOpenAfun rnfDelayedOpenAcc + +instance NFData (DelayedOpenAcc aenv t) where + rnf = rnfDelayedOpenAcc + +encodeDelayedOpenAcc :: EncodeAcc DelayedOpenAcc +encodeDelayedOpenAcc options acc = + let + travE :: Exp aenv sh -> Builder + travE = encodeOpenExp + + travF :: Fun aenv f -> Builder + travF = encodeOpenFun + + travA :: PreOpenAcc DelayedOpenAcc aenv a -> Builder + travA = encodePreOpenAcc options encodeDelayedOpenAcc + + deepA :: PreOpenAcc DelayedOpenAcc aenv a -> Builder + deepA | perfect options = travA + | otherwise = encodeArraysType . arraysR + in + case acc of + Manifest pacc -> intHost $(hashQ ("Manifest" :: String)) <> deepA pacc + Delayed _ sh f g -> intHost $(hashQ ("Delayed" :: String)) <> travE sh <> travF f <> travF g + +matchDelayedOpenAcc :: MatchAcc DelayedOpenAcc +matchDelayedOpenAcc (Manifest pacc1) (Manifest pacc2) + = matchPreOpenAcc matchDelayedOpenAcc pacc1 pacc2 +matchDelayedOpenAcc (Delayed _ sh1 ix1 lx1) (Delayed _ sh2 ix2 lx2) + | Just Refl <- matchOpenExp sh1 sh2 + , Just Refl <- matchOpenFun ix1 ix2 + , Just Refl <- matchOpenFun lx1 lx2 + = Just Refl +matchDelayedOpenAcc _ _ + = Nothing + +rnfDelayedOpenAcc :: NFDataAcc DelayedOpenAcc +rnfDelayedOpenAcc (Manifest pacc) = + rnfPreOpenAcc rnfDelayedOpenAcc pacc +rnfDelayedOpenAcc (Delayed aR sh ix lx) = + rnfArrayR aR `seq` rnfOpenExp sh `seq` rnfOpenFun ix `seq` rnfOpenFun lx + +liftDelayedOpenAcc :: LiftAcc DelayedOpenAcc +liftDelayedOpenAcc (Manifest pacc) = + [|| Manifest $$(liftPreOpenAcc liftDelayedOpenAcc pacc) ||] +liftDelayedOpenAcc (Delayed aR sh ix lx) = + [|| Delayed $$(liftArrayR aR) $$(liftOpenExp sh) $$(liftOpenFun ix) $$(liftOpenFun lx) ||] + diff --git a/src/Data/Array/Accelerate/Trafo/Environment.hs b/src/Data/Array/Accelerate/Trafo/Environment.hs new file mode 100644 index 000000000..82629223d --- /dev/null +++ b/src/Data/Array/Accelerate/Trafo/Environment.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Environment +-- Copyright : [2012..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Trafo.Environment + where + +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.Environment +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Trafo.Substitution +import Data.Array.Accelerate.Type + +import Data.Array.Accelerate.Debug.Stats as Stats + + +-- 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 env env' aenv where + EmptyExp :: Gamma env env' aenv + + PushExp :: Gamma env env' aenv + -> WeakOpenExp env aenv t + -> Gamma env (env', t) aenv + +data WeakOpenExp env aenv t where + Subst :: env :> env' + -> OpenExp env aenv t + -> OpenExp env' aenv t {- LAZY -} + -> WeakOpenExp 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. +-- +-- +-- +incExp + :: Gamma env env' aenv + -> Gamma (env,s) env' aenv +incExp EmptyExp = EmptyExp +incExp (PushExp env w) = incExp env `PushExp` subs w + where + subs :: forall env aenv s t. WeakOpenExp env aenv t -> WeakOpenExp (env,s) aenv t + subs (Subst k (e :: OpenExp env_ aenv t) _) = Subst (weakenSucc' k) e (weakenE (weakenSucc' k) e) + +prjExp :: Idx env' t -> Gamma env env' aenv -> OpenExp env aenv t +prjExp ZeroIdx (PushExp _ (Subst _ _ e)) = e +prjExp (SuccIdx ix) (PushExp env _) = prjExp ix env +prjExp _ _ = $internalError "prjExp" "inconsistent valuation" + +pushExp :: Gamma env env' aenv -> OpenExp env aenv t -> Gamma env (env',t) aenv +pushExp env e = env `PushExp` Subst weakenId e e + +{-- +lookupExp + :: Gamma env env' aenv + -> OpenExp 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 + :: Gamma env env' aenv + -> Gamma 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 env env' aenv + -> Gamma env env' aenv' +sinkGamma _ EmptyExp = EmptyExp +sinkGamma ext (PushExp env e) = PushExp (sinkGamma ext env) (sinkA 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 s f env env' where + BaseEnv :: Extend s f env env + + PushEnv :: Extend s f env env' + -> LeftHandSide s t env' env'' + -> f env' t + -> Extend s f env env'' + +pushArrayEnv + :: HasArraysR acc + => Extend ArrayR acc aenv aenv' + -> acc aenv' (Array sh e) + -> Extend ArrayR acc aenv (aenv', Array sh e) +pushArrayEnv env a = PushEnv env (LeftHandSideSingle $ arrayR a) a + + +-- Append two environment witnesses +-- +append :: Extend s acc env env' -> Extend s acc env' env'' -> Extend s acc env env'' +append x BaseEnv = x +append x (PushEnv e lhs a) = PushEnv (append x e) lhs 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 :: (forall env t. PreOpenAcc acc env t -> acc env t) + -> Extend ArrayR acc aenv aenv' + -> PreOpenAcc acc aenv' a + -> PreOpenAcc acc aenv a +bind _ BaseEnv = id +bind inject (PushEnv g lhs a) = bind inject g . Alet lhs 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. +-- +sinkA :: Sink f => Extend s acc env env' -> f env t -> f env' t +sinkA env = weaken (sinkWeaken env) -- TODO: Fix Stats sinkA vs sink1 + +sink1 :: Sink f => Extend s acc env env' -> f (env,t') t -> f (env',t') t +sink1 env = weaken $ sink $ sinkWeaken env + +sinkWeaken :: Extend s acc env env' -> env :> env' +sinkWeaken (PushEnv e (LeftHandSideWildcard _) _) = sinkWeaken e +sinkWeaken (PushEnv e (LeftHandSideSingle _) _) = weakenSucc' $ sinkWeaken e +sinkWeaken (PushEnv e (LeftHandSidePair l1 l2) _) = sinkWeaken (PushEnv (PushEnv e l1 undefined) l2 undefined) +sinkWeaken BaseEnv = Stats.substitution "sink" weakenId + +-- Wrapper around OpenExp, with the order of type arguments env and aenv flipped +newtype OpenExp' aenv env e = OpenExp' (OpenExp env aenv e) + +bindExps :: Extend ScalarType (OpenExp' aenv) env env' + -> OpenExp env' aenv e + -> OpenExp env aenv e +bindExps BaseEnv = id +bindExps (PushEnv g lhs (OpenExp' b)) = bindExps g . Let lhs b + diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index b2f4258a2..68c2eba1c 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -15,6 +15,7 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- TODO: remove this & fix warnings {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Fusion -- Copyright : [2012..2019] The Accelerate Team @@ -35,11 +36,6 @@ module Data.Array.Accelerate.Trafo.Fusion ( - -- ** Types - DelayedAcc, DelayedOpenAcc(..), - DelayedAfun, DelayedOpenAfun, - - -- ** Conversion convertAcc, convertAccWith, convertAfun, convertAfunWith, @@ -51,13 +47,22 @@ import Prelude hiding ( exp, until ) -- friends import Data.BitSet import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Environment +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.Error -import Data.Array.Accelerate.Trafo.Base import Data.Array.Accelerate.Trafo.Config +import Data.Array.Accelerate.Trafo.Var +import Data.Array.Accelerate.Trafo.Delayed +import Data.Array.Accelerate.Trafo.Environment import Data.Array.Accelerate.Trafo.Shrink import Data.Array.Accelerate.Trafo.Simplify import Data.Array.Accelerate.Trafo.Substitution -import Data.Array.Accelerate.Array.Representation hiding (fromIndex, toIndex, shape) +import Data.Array.Accelerate.Representation.Array ( Array, ArrayR(..), ArraysR ) +import Data.Array.Accelerate.Representation.Shape ( ShapeR(..), shapeType ) +import Data.Array.Accelerate.Representation.Slice +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Type @@ -89,6 +94,7 @@ convertAfunWith config = withSimplStats . convertOpenAfun config -- -- | 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)) @@ -122,6 +128,7 @@ withSimplStats x = x convertOpenAcc :: Config -> OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs convertOpenAcc config = manifest config . computeAcc . embedOpenAcc config + -- 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 @@ -130,13 +137,13 @@ convertOpenAcc config = manifest config . computeAcc . embedOpenAcc config delayed :: Config -> OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e) delayed config (embedOpenAcc config -> Embed env cc) | BaseEnv <- env - = case simplify cc of - Done v -> avarsIn v - Yield repr sh f -> Delayed repr sh f (f `compose` fromIndex (arrayRshape repr) sh) - Step repr sh p f v - | Just Refl <- match sh (arrayShape v) - , Just Refl <- isIdentity p -> Delayed repr sh (f `compose` indexArray v) (f `compose` linearIndex v) - | f' <- f `compose` indexArray v `compose` p -> Delayed repr sh f' (f' `compose` fromIndex (arrayRshape repr) sh) + = case simplifyCC cc of + Done v -> avarsIn Manifest v + Yield aR sh f -> Delayed aR sh f (f `compose` fromIndex (arrayRshape aR) sh) + Step aR sh p f v + | Just Refl <- matchOpenExp sh (arrayShape v) + , Just Refl <- isIdentity p -> Delayed aR sh (f `compose` indexArray v) (f `compose` linearIndex v) + | f' <- f `compose` indexArray v `compose` p -> Delayed aR sh f' (f' `compose` fromIndex (arrayRshape aR) sh) -- | otherwise = manifest config (computeAcc (Embed env cc)) @@ -152,8 +159,8 @@ manifest config (OpenAcc pacc) = -- Non-fusible terms -- ----------------- Avar ix -> Avar ix - Use repr arr -> Use repr arr - Unit tp e -> Unit tp e + Use aR a -> Use aR a + Unit t e -> Unit t e Alet lhs bnd body -> alet lhs (manifest config bnd) (manifest config body) Acond p t e -> Acond p (manifest config t) (manifest config e) Awhile p f a -> Awhile (cvtAF p) (cvtAF f) (manifest config a) @@ -170,10 +177,10 @@ manifest config (OpenAcc pacc) = -- of a let-binding to be used multiple times. The input array here -- should be a evaluated array term, else something went wrong. -- - Map tp f a -> Map tp f (delayed config a) + Map t f a -> Map t f (delayed config a) Generate repr sh f -> Generate repr sh f Transform repr sh p f a -> Transform repr sh p f (delayed config a) - Backpermute shr sh p a -> Backpermute shr sh p (delayed config a) + Backpermute shR sh p a -> Backpermute shR sh p (delayed config a) Reshape slr sl a -> Reshape slr sl (manifest config a) Replicate{} -> fusionError @@ -198,9 +205,9 @@ manifest config (OpenAcc pacc) = Scanr1 f a -> Scanr1 f (delayed config a) Scanr' f z a -> Scanr' f z (delayed config a) Permute f d p a -> Permute f (manifest config d) p (delayed config a) - Stencil s tp f x a -> Stencil s tp f x (delayed config a) - Stencil2 s1 s2 tp f x a y b - -> Stencil2 s1 s2 tp f x (delayed config a) y (delayed config b) + Stencil s t f x a -> Stencil s t f x (delayed config a) + Stencil2 s1 s2 t f x a y b + -> Stencil2 s1 s2 t f x (delayed config a) y (delayed config b) -- Collect s -> Collect (cvtS s) where @@ -212,7 +219,7 @@ manifest config (OpenAcc pacc) = -> DelayedOpenAcc aenv' b -> PreOpenAcc DelayedOpenAcc aenv b alet lhs bnd body - | Just bodyVars <- extractArrayVars body + | Just bodyVars <- extractDelayedArrayVars body , Just Refl <- bindingIsTrivial lhs bodyVars , Manifest x <- bnd = x @@ -233,7 +240,7 @@ manifest config (OpenAcc pacc) = -> PreOpenAcc DelayedOpenAcc aenv b apply repr afun x | Alam lhs (Abody body) <- afun - , Just bodyVars <- extractArrayVars body + , Just bodyVars <- extractDelayedArrayVars body , Just Refl <- bindingIsTrivial lhs bodyVars , Manifest x' <- x = Stats.ruleFired "applyD/identity" x' @@ -292,17 +299,17 @@ convertOpenSeq config s = --} +type EmbedAcc acc = forall aenv arrs. acc aenv arrs -> Embed acc aenv arrs +type ElimAcc acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Bool + -- | 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. acc aenv arrs -> Embed acc aenv arrs -type ElimAcc acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Bool - embedOpenAcc :: Config -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs embedOpenAcc config (OpenAcc pacc) = - embedPreAcc config (embedOpenAcc config) elimOpenAcc pacc + embedPreOpenAcc config matchOpenAcc (embedOpenAcc config) 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 @@ -321,15 +328,19 @@ embedOpenAcc config (OpenAcc pacc) = count :: UsesOfAcc OpenAcc count no ix (OpenAcc pacc) = usesOfPreAcc no count ix pacc + matchOpenAcc :: MatchAcc OpenAcc + matchOpenAcc (OpenAcc pacc1) (OpenAcc pacc2) = + matchPreOpenAcc matchOpenAcc pacc1 pacc2 + -embedPreAcc - :: forall acc aenv arrs. Kit acc - => Config - -> EmbedAcc acc - -> ElimAcc acc - -> PreOpenAcc acc aenv arrs - -> Embed acc aenv arrs -embedPreAcc config embedAcc elimAcc pacc +embedPreOpenAcc + :: Config + -> MatchAcc OpenAcc + -> EmbedAcc OpenAcc + -> ElimAcc OpenAcc + -> PreOpenAcc OpenAcc aenv arrs + -> Embed OpenAcc aenv arrs +embedPreOpenAcc config matchAcc embedAcc elimAcc pacc = unembed $ case pacc of @@ -344,17 +355,17 @@ embedPreAcc config embedAcc elimAcc pacc -- Alet lhs bnd body -> aletD embedAcc elimAcc lhs bnd body Anil -> done $ Anil - Acond p at ae -> acondD embedAcc (cvtE p) at ae - Apply repr f a -> done $ Apply repr (cvtAF f) (cvtA a) + Acond p at ae -> acondD matchAcc embedAcc (cvtE p) at ae + Apply aR f a -> done $ Apply aR (cvtAF f) (cvtA a) Awhile p f a -> done $ Awhile (cvtAF p) (cvtAF f) (cvtA a) Apair a1 a2 -> done $ Apair (cvtA a1) (cvtA a2) - Aforeign repr ff f a -> done $ Aforeign repr ff (cvtAF f) (cvtA a) + Aforeign aR ff f a -> done $ Aforeign aR ff (cvtAF f) (cvtA a) -- Collect s -> collectD s -- Array injection Avar v -> done $ Avar v - Use repr arr -> done $ Use repr arr - Unit tp e -> done $ Unit tp (cvtE e) + Use aR a -> done $ Use aR a + Unit t e -> done $ Unit t (cvtE e) -- Producers -- --------- @@ -369,11 +380,11 @@ embedPreAcc config embedAcc elimAcc pacc -- independently of all others, and so we can aggressively fuse arbitrary -- sequences of these operations. -- - Generate repr sh f -> generateD repr (cvtE sh) (cvtF f) + Generate aR sh f -> generateD aR (cvtE sh) (cvtF f) - Map tp f a -> mapD tp (cvtF f) (embedAcc a) - ZipWith tp f a b -> fuse2 (into (zipWithD tp) (cvtF f)) a b - Transform repr sh p f a -> transformD repr (cvtE sh) (cvtF p) (cvtF f) (embedAcc a) + Map t f a -> mapD t (cvtF f) (embedAcc a) + ZipWith t f a b -> fuse2 (into (zipWithD t) (cvtF f)) a b + Transform aR sh p f a -> transformD aR (cvtE sh) (cvtF p) (cvtF f) (embedAcc a) Backpermute slr sl p a -> fuse (into2 (backpermuteD slr) (cvtE sl) (cvtF p)) a @@ -397,40 +408,41 @@ embedPreAcc config embedAcc elimAcc pacc -- node, so that the producer can be directly embedded into the consumer -- during the code generation phase. -- - Fold f z a -> embed repr (into2 Fold (cvtF f) (cvtE z)) a - Fold1 f a -> embed repr (into Fold1 (cvtF f)) a - FoldSeg i f z a s -> embed2 repr (into2 (FoldSeg i) (cvtF f) (cvtE z)) a s - Fold1Seg i f a s -> embed2 repr (into (Fold1Seg i) (cvtF f)) a s - Scanl f z a -> embed repr (into2 Scanl (cvtF f) (cvtE z)) a - Scanl1 f a -> embed repr (into Scanl1 (cvtF f)) a - Scanl' f z a -> embed repr (into2 Scanl' (cvtF f) (cvtE z)) a - Scanr f z a -> embed repr (into2 Scanr (cvtF f) (cvtE z)) a - Scanr1 f a -> embed repr (into Scanr1 (cvtF f)) a - Scanr' f z a -> embed repr (into2 Scanr' (cvtF f) (cvtE z)) a - Permute f d p a -> embed2 repr (into2 permute (cvtF f) (cvtF p)) d a - Stencil s t f x a -> embed repr (into2 (stencil1 s t) (cvtF f) (cvtB x)) a + Fold f z a -> embed aR (into2 Fold (cvtF f) (cvtE z)) a + Fold1 f a -> embed aR (into Fold1 (cvtF f)) a + FoldSeg i f z a s -> embed2 aR (into2 (FoldSeg i) (cvtF f) (cvtE z)) a s + Fold1Seg i f a s -> embed2 aR (into (Fold1Seg i) (cvtF f)) a s + Scanl f z a -> embed aR (into2 Scanl (cvtF f) (cvtE z)) a + Scanl1 f a -> embed aR (into Scanl1 (cvtF f)) a + Scanl' f z a -> embed aR (into2 Scanl' (cvtF f) (cvtE z)) a + Scanr f z a -> embed aR (into2 Scanr (cvtF f) (cvtE z)) a + Scanr1 f a -> embed aR (into Scanr1 (cvtF f)) a + Scanr' f z a -> embed aR (into2 Scanr' (cvtF f) (cvtE z)) a + Permute f d p a -> embed2 aR (into2 permute (cvtF f) (cvtF p)) d a + Stencil s t f x a -> embed aR (into2 (stencil1 s t) (cvtF f) (cvtB x)) a Stencil2 s1 s2 t f x a y b - -> embed2 repr (into3 (stencil2 s1 s2 t) (cvtF f) (cvtB x) (cvtB y)) a b + -> embed2 aR (into3 (stencil2 s1 s2 t) (cvtF f) (cvtB x) (cvtB y)) a b where - repr = arraysRepr pacc + aR = arraysR pacc + -- If fusion is not enabled, force terms to the manifest representation -- - unembed :: Embed acc aenv arrs -> Embed acc aenv arrs + unembed :: Embed OpenAcc aenv arrs -> Embed OpenAcc aenv arrs unembed x | array_fusion `member` options config = x | Embed env cc <- x - , pacc <- compute cc - = case extractArrayVars $ inject pacc of + , pacc <- compute cc + = case avarsOut extractOpenAcc pacc of Just vars -> Embed env $ Done vars _ - | DeclareVars lhs _ value <- declareVars (arraysRepr pacc) - -> Embed (PushEnv env lhs $ inject pacc) $ Done $ value weakenId + | DeclareVars lhs _ value <- declareVars (arraysR pacc) + -> Embed (PushEnv env lhs $ OpenAcc pacc) $ Done $ value weakenId - cvtA :: acc aenv' a -> acc aenv' a + cvtA :: OpenAcc aenv' a -> OpenAcc aenv' a cvtA = computeAcc . embedAcc - cvtAF :: PreOpenAfun acc aenv' f -> PreOpenAfun acc aenv' f + cvtAF :: PreOpenAfun OpenAcc aenv' f -> PreOpenAfun OpenAcc aenv' f cvtAF (Alam lhs f) = Alam lhs (cvtAF f) cvtAF (Abody a) = Abody (cvtA a) @@ -453,10 +465,10 @@ embedPreAcc config embedAcc elimAcc pacc -- applies scalar simplifications. -- cvtF :: Fun aenv' t -> Fun aenv' t - cvtF = simplify + cvtF = simplifyFun cvtE :: Exp aenv' t -> Exp aenv' t - cvtE = simplify + cvtE = simplifyExp cvtB :: Boundary aenv' t -> Boundary aenv' t cvtB Clamp = Clamp @@ -467,15 +479,28 @@ embedPreAcc config embedAcc elimAcc pacc -- Helpers to embed and fuse delayed terms -- - into :: Sink f => (f env' a -> b) -> f env a -> Extend ArrayR acc env env' -> b + into :: Sink f + => (f env' a -> b) + -> f env a + -> Extend ArrayR OpenAcc env env' + -> b into op a env = op (sinkA env a) into2 :: (Sink f1, Sink f2) - => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b -> Extend ArrayR acc env env' -> c + => (f1 env' a -> f2 env' b -> c) + -> f1 env a + -> f2 env b + -> Extend ArrayR OpenAcc env env' + -> c into2 op a b env = op (sinkA env a) (sinkA 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 ArrayR acc env env' -> d + => (f1 env' a -> f2 env' b -> f3 env' c -> d) + -> f1 env a + -> f2 env b + -> f3 env c + -> Extend ArrayR OpenAcc env env' + -> d into3 op a b c env = op (sinkA env a) (sinkA env b) (sinkA env c) -- Operations which can be fused into consumers. Move all of the local @@ -483,15 +508,15 @@ embedPreAcc config embedAcc elimAcc pacc -- directly on the delayed representation. See also: [Representing -- delayed arrays] -- - fuse :: (forall aenv'. Extend ArrayR acc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) - -> acc aenv as - -> Embed acc aenv bs + fuse :: (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) + -> OpenAcc aenv as + -> Embed OpenAcc aenv bs fuse op (embedAcc -> Embed env cc) = Embed env (op env cc) - fuse2 :: (forall aenv'. Extend ArrayR acc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs -> Cunctation aenv' cs) - -> acc aenv as - -> acc aenv bs - -> Embed acc aenv cs + fuse2 :: (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs -> Cunctation aenv' cs) + -> OpenAcc aenv as + -> OpenAcc aenv bs + -> Embed OpenAcc aenv cs fuse2 op a1 a0 | Embed env1 cc1 <- embedAcc a1 , Embed env0 cc0 <- embedAcc (sinkA env1 a0) @@ -530,23 +555,23 @@ embedPreAcc config embedAcc elimAcc pacc -- update the array of default values. -- embed :: ArraysR bs - -> (forall aenv'. Extend ArrayR acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs) - -> acc aenv as - -> Embed acc aenv bs + -> (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> OpenAcc aenv' as -> PreOpenAcc OpenAcc aenv' bs) + -> OpenAcc aenv as + -> Embed OpenAcc aenv bs embed reprBs op (embedAcc -> Embed env cc) | Done{} <- cc , DeclareVars lhs _ value <- declareVars reprBs - = Embed (PushEnv BaseEnv lhs $ inject (op BaseEnv (computeAcc (Embed env cc)))) $ Done $ value weakenId + = Embed (PushEnv BaseEnv lhs $ OpenAcc (op BaseEnv (computeAcc (Embed env cc)))) $ Done $ value weakenId | otherwise -- Next line is duplicated for both branches, as the type variable for the environment is instantiated differently , DeclareVars lhs _ value <- declareVars reprBs - = Embed (PushEnv env lhs $ inject (op env (inject (compute cc)))) $ Done $ value weakenId + = Embed (PushEnv env lhs $ OpenAcc (op env (OpenAcc (compute cc)))) $ Done $ value weakenId embed2 :: ArraysR cs - -> (forall aenv'. Extend ArrayR acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs) - -> acc aenv as - -> acc aenv bs - -> Embed acc aenv cs + -> (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> OpenAcc aenv' as -> OpenAcc aenv' bs -> PreOpenAcc OpenAcc aenv' cs) + -> OpenAcc aenv as + -> OpenAcc aenv bs + -> Embed OpenAcc aenv cs embed2 reprCs op (embedAcc -> Embed env1 cc1) a0 | Done{} <- cc1 , a1 <- computeAcc (Embed env1 cc1) @@ -557,11 +582,16 @@ embedPreAcc config embedAcc elimAcc pacc = case cc0 of Done{} | DeclareVars lhs _ value <- declareVars reprCs - -> Embed (PushEnv env1 lhs $ inject (op env1 (inject (compute cc1)) (computeAcc (Embed env0 cc0)))) $ Done $ value weakenId + -> Embed (PushEnv env1 lhs $ OpenAcc (op env1 (OpenAcc (compute cc1)) (computeAcc (Embed env0 cc0)))) + $ Done + $ value weakenId _ - -- Next line is duplicated for both branches, as the type variable for the environment is instantiated differently + -- Next line is duplicated for both branches, as the type + -- variable for the environment is instantiated differently | DeclareVars lhs _ value <- declareVars reprCs - -> Embed (PushEnv env lhs $ inject (op env (inject (compute (sinkA env0 cc1))) (inject (compute cc0)))) $ Done $ value weakenId + -> Embed (PushEnv env lhs $ OpenAcc (op env (OpenAcc (compute (sinkA env0 cc1))) (OpenAcc (compute cc0)))) + $ Done + $ value weakenId -- trav1 :: (Arrays as, Arrays bs) -- => (forall aenv'. Embed acc aenv' as -> Embed acc aenv' as) @@ -650,10 +680,10 @@ embedSeq embedAcc s cvtCT (SnocAtup t c) = SnocAtup (cvtCT t) (travC c env) cvtE :: Elt t => Exp aenv' t -> Exp aenv' t - cvtE = simplify + cvtE = simplifyExp cvtF :: Fun aenv' t -> Fun aenv' t - cvtF = simplify + cvtF = simplifyFun cvtA :: Arrays a => acc aenv' a -> acc aenv' a cvtA = computeAcc . embedAcc @@ -696,7 +726,7 @@ data ExtendProducer acc aenv senv arrs where -- are defined with respect to this existentially quantified type, and there is -- no way to directly combine these two environments: -- --- append :: Extend ArrayR env env1 -> Extend ArrayR env env2 -> Extend ArrayR env ??? +-- append :: Extend env env1 -> Extend env env2 -> Extend env ??? -- -- And hence, no way to combine the terms of the delayed representation. -- @@ -714,8 +744,8 @@ data Embed acc aenv a where -> Cunctation aenv' a -> Embed acc aenv a -instance HasArraysRepr acc => HasArraysRepr (Embed acc) where - arraysRepr (Embed _ c) = arraysRepr c +instance HasArraysR acc => HasArraysR (Embed acc) where + arraysR (Embed _ c) = arraysR c -- Cunctation (n): the action or an instance of delaying; a tardy action. -- @@ -756,32 +786,43 @@ data Cunctation aenv a where -> ArrayVar aenv (Array sh a) -> Cunctation aenv (Array sh' b) -instance Simplify (Cunctation aenv a) where - simplify = \case - Done v -> Done v - Yield repr (simplify -> sh) (simplify -> f) -> Yield repr sh f - Step repr (simplify -> sh) (simplify -> p) (simplify -> f) v - | Just Refl <- match sh (arrayShape v) - , Just Refl <- isIdentity p - , Just Refl <- isIdentity f -> Done $ VarsSingle v - | otherwise -> Step repr sh p f v +instance HasArraysR Cunctation where + arraysR (Done v) = varsType v + arraysR (Yield aR _ _) = TupRsingle aR + arraysR (Step aR _ _ _ _) = TupRsingle aR + +instance Sink Cunctation where + weaken k = \case + Done v -> Done (weakenVars k v) + Step repr sh p f v -> Step repr (weaken k sh) (weaken k p) (weaken k f) (weaken k v) + Yield repr sh f -> Yield repr (weaken k sh) (weaken k f) + +simplifyCC :: Cunctation aenv a -> Cunctation aenv a +simplifyCC = \case + Done v + -> Done v + Yield aR (simplifyExp -> sh) (simplifyFun -> f) + -> Yield aR sh f + Step aR (simplifyExp -> sh) (simplifyFun -> p) (simplifyFun -> f) v + | Just Refl <- matchOpenExp sh (arrayShape v) + , Just Refl <- isIdentity p + , Just Refl <- isIdentity f + -> Done $ TupRsingle v + | otherwise + -> Step aR sh p f v -instance HasArraysRepr Cunctation where - arraysRepr (Done v) = varsType v - arraysRepr (Yield repr _ _) = TupRsingle repr - arraysRepr (Step repr _ _ _ _) = TupRsingle repr -- Convert a real AST node into the internal representation -- -done :: Kit acc => PreOpenAcc acc aenv a -> Embed acc aenv a +done :: PreOpenAcc OpenAcc aenv a -> Embed OpenAcc aenv a done pacc - | Just vars <- extractArrayVars $ inject pacc + | Just vars <- avarsOut extractOpenAcc pacc = Embed BaseEnv (Done vars) - | DeclareVars lhs _ value <- declareVars (arraysRepr pacc) - = Embed (PushEnv BaseEnv lhs $ inject pacc) $ Done $ value weakenId + | DeclareVars lhs _ value <- declareVars (arraysR pacc) + = Embed (PushEnv BaseEnv lhs $ OpenAcc pacc) $ Done $ value weakenId doneZeroIdx :: ArrayR (Array sh e) -> Cunctation (aenv, Array sh e) (Array sh e) -doneZeroIdx repr = Done $ VarsSingle $ Var repr ZeroIdx +doneZeroIdx repr = Done $ TupRsingle $ Var repr ZeroIdx -- Recast a cunctation into a mapping from indices to elements. -- @@ -789,10 +830,9 @@ yield :: Cunctation aenv (Array sh e) -> Cunctation aenv (Array sh e) yield cc = case cc of - Yield{} -> cc - Step repr sh p f v -> Yield repr sh (f `compose` indexArray v `compose` p) - Done (VarsSingle v@(Var repr _)) - -> Yield repr (arrayShape v) (indexArray v) + Yield{} -> cc + Step tR sh p f v -> Yield tR sh (f `compose` indexArray v `compose` p) + Done (TupRsingle v@(Var tR _)) -> Yield tR (arrayShape v) (indexArray v) -- Recast a cunctation into transformation step form. Not possible if the source @@ -802,10 +842,10 @@ step :: Cunctation aenv (Array sh e) -> Maybe (Cunctation aenv (Array sh e)) step cc = case cc of - Yield{} -> Nothing - Step{} -> Just cc - Done (VarsSingle v@(Var repr@(ArrayR shr tp) _)) - -> Just $ Step repr (arrayShape v) (identity $ shapeType shr) (identity tp) v + Yield{} -> Nothing + Step{} -> Just cc + Done (TupRsingle v@(Var aR@(ArrayR shR tR) _)) + -> Just $ Step aR (arrayShape v) (identity $ shapeType shR) (identity tR) v -- Get the shape of a delayed array @@ -816,15 +856,6 @@ shape cc | Yield _ sh _ <- yield cc = sh --- Environment manipulation --- ======================== - -instance Sink Cunctation where - weaken k = \case - Done v -> Done (weaken k v) - Step repr sh p f v -> Step repr (weaken k sh) (weaken k p) (weaken k f) (weaken k v) - Yield repr sh f -> Yield repr (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 @@ -884,21 +915,21 @@ instance Kit acc => Sink (SinkSeq acc senv) where -- We do a bit of extra work to (try to) maintain that terms should be left -- at their lowest common use site. SEE: [Fusion and the lowest common use site] -- -computeAcc :: Kit acc => Embed acc aenv arrs -> acc aenv arrs -computeAcc (Embed BaseEnv cc) = inject (compute cc) +computeAcc :: Embed OpenAcc aenv arrs -> OpenAcc aenv arrs +computeAcc (Embed BaseEnv cc) = OpenAcc (compute cc) computeAcc (Embed env@(PushEnv bot lhs top) cc) = - case simplify cc of - Done v -> bindA env (avarsIn v) - Yield repr sh f -> bindA env (inject (Generate repr sh f)) + case simplifyCC cc of + Done v -> bindA env (avarsIn OpenAcc v) + Yield repr sh f -> bindA env (OpenAcc (Generate repr sh f)) Step repr sh p f v@(Var _ ix) - | Just Refl <- match sh (arrayShape v) + | Just Refl <- matchOpenExp sh (arrayShape v) , Just Refl <- isIdentity p -> case ix of ZeroIdx | LeftHandSideSingle ArrayR{} <- lhs , Just (OpenAccFun g) <- strengthen noTop (OpenAccFun f) - -> bindA bot (inject (Map (arrayRtype repr) g top)) - _ -> bindA env (inject (Map (arrayRtype repr) f (avarIn v))) + -> bindA bot (OpenAcc (Map (arrayRtype repr) g top)) + _ -> bindA env (OpenAcc (Map (arrayRtype repr) f (avarIn OpenAcc v))) | Just Refl <- isIdentity f -> case ix of @@ -906,8 +937,8 @@ computeAcc (Embed env@(PushEnv bot lhs top) cc) = | LeftHandSideSingle ArrayR{} <- lhs , Just (OpenAccFun q) <- strengthen noTop (OpenAccFun p) , Just (OpenAccExp sz) <- strengthen noTop (OpenAccExp sh) - -> bindA bot (inject (Backpermute (arrayRshape repr) sz q top)) - _ -> bindA env (inject (Backpermute (arrayRshape repr) sh p (avarIn v))) + -> bindA bot (OpenAcc (Backpermute (arrayRshape repr) sz q top)) + _ -> bindA env (OpenAcc (Backpermute (arrayRshape repr) sh p (avarIn OpenAcc v))) | otherwise -> case ix of @@ -916,22 +947,21 @@ computeAcc (Embed env@(PushEnv bot lhs top) cc) = , Just (OpenAccFun g) <- strengthen noTop (OpenAccFun f) , Just (OpenAccFun q) <- strengthen noTop (OpenAccFun p) , Just (OpenAccExp sz) <- strengthen noTop (OpenAccExp sh) - -> bindA bot (inject (Transform repr sz q g top)) - _ -> bindA env (inject (Transform repr sh p f (avarIn v))) + -> bindA bot (OpenAcc (Transform repr sz q g top)) + _ -> bindA env (OpenAcc (Transform repr sh p f (avarIn OpenAcc v))) where - bindA :: Kit acc - => Extend ArrayR acc aenv aenv' - -> acc aenv' a - -> acc aenv a + bindA :: Extend ArrayR OpenAcc aenv aenv' + -> OpenAcc aenv' a + -> OpenAcc aenv a bindA BaseEnv b = b bindA (PushEnv env lhs a) b -- If the freshly bound value is directly, returned, we don't have to bind it in a -- let. We can do this if the left hand side does not contain wildcards (other than -- wildcards for unit / nil) and if the value contains the same variables. - | Just vars <- extractArrayVars b + | Just vars <- extractOpenArrayVars b , Just Refl <- bindingIsTrivial lhs vars = bindA env a - | otherwise = bindA env (inject (Alet lhs a b)) + | otherwise = bindA env (OpenAcc (Alet lhs a b)) noTop :: (aenv, a) :?> aenv noTop ZeroIdx = Nothing @@ -941,25 +971,26 @@ computeAcc (Embed env@(PushEnv bot lhs top) cc) = -- Convert the internal representation of delayed arrays into a real AST -- node. Use the most specific version of a combinator whenever possible. -- -compute :: Kit acc => Cunctation aenv arrs -> PreOpenAcc acc aenv arrs -compute cc = case simplify cc of - Done VarsNil -> Anil - Done (VarsSingle v@(Var ArrayR{} _)) -> Avar v - Done (VarsPair v1 v2) -> avarsIn v1 `Apair` avarsIn v2 +compute :: Cunctation aenv arrs -> PreOpenAcc OpenAcc aenv arrs +compute cc = case simplifyCC cc of + Done TupRunit -> Anil + Done (TupRsingle v@(Var ArrayR{} _)) -> Avar v + Done (TupRpair v1 v2) -> avarsIn OpenAcc v1 `Apair` avarsIn OpenAcc v2 Yield repr sh f -> Generate repr sh f - Step (ArrayR shr tp) sh p f v - | Just Refl <- match sh (arrayShape v) - , Just Refl <- isIdentity p -> Map tp f (avarIn v) - | Just Refl <- isIdentity f -> Backpermute shr sh p (avarIn v) - | otherwise -> Transform (ArrayR shr tp) sh p f (avarIn v) + Step (ArrayR shR tR) sh p f v + | Just Refl <- matchOpenExp sh (arrayShape v) + , Just Refl <- isIdentity p -> Map tR f (avarIn OpenAcc v) + | Just Refl <- isIdentity f -> Backpermute shR sh p (avarIn OpenAcc v) + | otherwise -> Transform (ArrayR shR tR) sh p f (avarIn OpenAcc v) -- Representation of a generator as a delayed array -- -generateD :: ArrayR (Array sh e) - -> Exp aenv sh - -> Fun aenv (sh -> e) - -> Embed acc aenv (Array sh e) +generateD + :: ArrayR (Array sh e) + -> Exp aenv sh + -> Fun aenv (sh -> e) + -> Embed OpenAcc aenv (Array sh e) generateD repr sh f = Stats.ruleFired "generateD" $ Embed BaseEnv (Yield repr sh f) @@ -968,34 +999,33 @@ generateD repr 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 - => TupleType b - -> Fun aenv (a -> b) - -> Embed acc aenv (Array sh a) - -> Embed acc aenv (Array sh b) -mapD tp f (unzipD tp f -> Just a) = a -mapD tp f (Embed env cc) +mapD :: TypeR b + -> Fun aenv (a -> b) + -> Embed OpenAcc aenv (Array sh a) + -> Embed OpenAcc aenv (Array sh b) +mapD tR f (unzipD tR f -> Just a) = a +mapD tR f (Embed env cc) = Stats.ruleFired "mapD" $ Embed env (go cc) where - go (step -> Just (Step (ArrayR shr _) sh ix g v)) = Step (ArrayR shr tp) sh ix (sinkA env f `compose` g) v - go (yield -> Yield (ArrayR shr _) sh g) = Yield (ArrayR shr tp) sh (sinkA env f `compose` g) + go (step -> Just (Step (ArrayR shR _) sh ix g v)) = Step (ArrayR shR tR) sh ix (sinkA env f `compose` g) v + go (yield -> Yield (ArrayR shR _) sh g) = Yield (ArrayR shR tR) sh (sinkA 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. -- unzipD - :: Kit acc - => TupleType b - -> Fun aenv (a -> b) - -> Embed acc aenv (Array sh a) - -> Maybe (Embed acc aenv (Array sh b)) -unzipD tp f (Embed env cc@(Done v)) + :: TypeR b + -> Fun aenv (a -> b) + -> Embed OpenAcc aenv (Array sh a) + -> Maybe (Embed OpenAcc aenv (Array sh b)) +unzipD tR f (Embed env cc@(Done v)) | Lam lhs (Body a) <- f - , Just vars <- extractExpVars a - , ArrayR shr _ <- arrayRepr cc - , f' <- Lam lhs $ Body $ evars vars = Just $ Embed (env `pushArrayEnv` inject (Map tp f' $ avarsIn v)) $ doneZeroIdx $ ArrayR shr tp + , Just vars <- extractExpVars a + , ArrayR shR _ <- arrayR cc + , f' <- Lam lhs $ Body $ expVars vars + = Just $ Embed (env `pushArrayEnv` OpenAcc (Map tR f' $ avarsIn OpenAcc v)) $ doneZeroIdx $ ArrayR shR tR unzipD _ _ _ = Nothing @@ -1009,34 +1039,37 @@ backpermuteD -> Fun aenv (sh' -> sh) -> Cunctation aenv (Array sh e) -> Cunctation aenv (Array sh' e) -backpermuteD shr' sh' p = Stats.ruleFired "backpermuteD" . go +backpermuteD shR' sh' p = Stats.ruleFired "backpermuteD" . go where - go (step -> Just (Step (ArrayR _ tp) _ q f v)) = Step (ArrayR shr' tp) sh' (q `compose` p) f v - go (yield -> Yield (ArrayR _ tp) _ g) = Yield (ArrayR shr' tp) sh' (g `compose` p) + go (step -> Just (Step (ArrayR _ tR) _ q f v)) = Step (ArrayR shR' tR) sh' (q `compose` p) f v + go (yield -> Yield (ArrayR _ tR) _ g) = Yield (ArrayR shR' tR) sh' (g `compose` p) -- Transform as a combined map and backwards permutation -- transformD - :: Kit acc - => ArrayR (Array sh' b) - -> Exp aenv sh' - -> Fun aenv (sh' -> sh) - -> Fun aenv (a -> b) - -> Embed acc aenv (Array sh a) - -> Embed acc aenv (Array sh' b) -transformD (ArrayR shr' tp) sh' p f + :: ArrayR (Array sh' b) + -> Exp aenv sh' + -> Fun aenv (sh' -> sh) + -> Fun aenv (a -> b) + -> Embed OpenAcc aenv (Array sh a) + -> Embed OpenAcc aenv (Array sh' b) +transformD (ArrayR shR' tR) sh' p f = Stats.ruleFired "transformD" - . fuse (into2 (backpermuteD shr') sh' p) - . mapD tp f + . fuse (into2 (backpermuteD shR') sh' p) + . mapD tR f where - fuse :: (forall aenv'. Extend ArrayR acc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) - -> Embed acc aenv as - -> Embed acc aenv bs + fuse :: (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) + -> Embed OpenAcc aenv as + -> Embed OpenAcc 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 ArrayR acc env env' -> c + => (f1 env' a -> f2 env' b -> c) + -> f1 env a + -> f2 env b + -> Extend ArrayR OpenAcc env env' + -> c into2 op a b env = op (sinkA env a) (sinkA env b) @@ -1079,50 +1112,50 @@ sliceD sliceIndex slix cc -- same number of elements: this has been lost for the delayed cases! -- reshapeD - :: Kit acc - => ShapeR sl - -> Embed acc aenv (Array sh e) - -> Exp aenv sl - -> Embed acc aenv (Array sl e) + :: ShapeR sl + -> Embed OpenAcc aenv (Array sh e) + -> Exp aenv sl + -> Embed OpenAcc aenv (Array sl e) reshapeD slr (Embed env cc) (sinkA env -> sl) | Done v <- cc - = Embed (env `pushArrayEnv` inject (Reshape slr sl (avarsIn v))) $ doneZeroIdx repr + = Embed (env `pushArrayEnv` OpenAcc (Reshape slr sl (avarsIn OpenAcc v))) $ doneZeroIdx repr | otherwise = Stats.ruleFired "reshapeD" - $ Embed env (backpermuteD slr sl (reindex (arrayRshape $ arrayRepr cc) (shape cc) slr sl) cc) + $ Embed env (backpermuteD slr sl (reindex (arrayRshape $ arrayR cc) (shape cc) slr sl) cc) where - ArrayR _ tp = arrayRepr cc - repr = ArrayR slr tp + ArrayR _ tR = arrayR cc + repr = ArrayR slr tR -- Combine two arrays element-wise with a binary function to produce a delayed -- array. -- -zipWithD :: TupleType c - -> Fun aenv (a -> b -> c) - -> Cunctation aenv (Array sh a) - -> Cunctation aenv (Array sh b) - -> Cunctation aenv (Array sh c) -zipWithD tp f cc1 cc0 +zipWithD + :: TypeR c + -> Fun aenv (a -> b -> c) + -> Cunctation aenv (Array sh a) + -> Cunctation aenv (Array sh b) + -> Cunctation aenv (Array sh c) +zipWithD tR 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 (ArrayR shr _) sh1 p1 f1 v1) <- step cc1 + | Just (Step (ArrayR shR _) sh1 p1 f1 v1) <- step cc1 , Just (Step _ sh0 p0 f0 v0) <- step cc0 - , Just Refl <- match v1 v0 - , Just Refl <- match p1 p0 + , Just Refl <- matchVar v1 v0 + , Just Refl <- matchOpenFun p1 p0 = Stats.ruleFired "zipWithD/step" - $ Step (ArrayR shr tp) (mkIntersect shr sh1 sh0) p0 (combine f f1 f0) v0 + $ Step (ArrayR shR tR) (intersect shR sh1 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 (ArrayR shr _) sh1 f1 <- yield cc1 + | Yield (ArrayR shR _) sh1 f1 <- yield cc1 , Yield _ sh0 f0 <- yield cc0 = Stats.ruleFired "zipWithD" - $ Yield (ArrayR shr tp) (mkIntersect shr sh1 sh0) (combine f f1 f0) + $ Yield (ArrayR shR tR) (intersect shR sh1 sh0) (combine f f1 f0) where combine :: forall aenv a b c e. @@ -1147,12 +1180,15 @@ zipWithD tp f cc1 cc0 , ixa'' <- weakenE k1 ixa' -> Lam lhs $ Body $ Let lhsA ixa'' $ Let lhsB (weakenE (weakenWithLHS lhsA .> k2) ixb') c' -combineLhs :: LeftHandSide s t env env1' -> LeftHandSide s t env env2' -> CombinedLHS s t env1' env2' env +combineLhs + :: LeftHandSide s t env env1' + -> LeftHandSide s t env env2' + -> CombinedLHS s t env1' env2' env combineLhs = go weakenId weakenId where go :: env1 :> env -> env2 :> env -> LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> CombinedLHS s t env1' env2' env - go k1 k2 (LeftHandSideWildcard tp) (LeftHandSideWildcard _) = CombinedLHS (LeftHandSideWildcard tp) k1 k2 - go k1 k2 (LeftHandSideSingle tp) (LeftHandSideSingle _) = CombinedLHS (LeftHandSideSingle tp) (sink k1) (sink k2) + go k1 k2 (LeftHandSideWildcard tR) (LeftHandSideWildcard _) = CombinedLHS (LeftHandSideWildcard tR) k1 k2 + go k1 k2 (LeftHandSideSingle tR) (LeftHandSideSingle _) = CombinedLHS (LeftHandSideSingle tR) (sink k1) (sink k2) go k1 k2 (LeftHandSidePair l1 h1) (LeftHandSidePair l2 h2) | CombinedLHS l k1' k2' <- go k1 k2 l1 l2 , CombinedLHS h k1'' k2'' <- go k1' k2' h1 h2 = CombinedLHS (LeftHandSidePair l h) k1'' k2'' @@ -1162,7 +1198,10 @@ combineLhs = go weakenId weakenId | Exists lhs' <- rebuildLHS lhs = CombinedLHS lhs' (sinkWithLHS lhs lhs' k1) (weakenWithLHS lhs' .> k2) data CombinedLHS s t env1' env2' env where - CombinedLHS :: LeftHandSide s t env env' -> env1' :> env' -> env2' :> env' -> CombinedLHS s t env1' env2' env + CombinedLHS :: LeftHandSide s t env env' + -> env1' :> env' + -> env2' :> env' + -> CombinedLHS s t env1' env2' env -- NOTE: [Sharing vs. Fusion] -- @@ -1244,13 +1283,12 @@ data CombinedLHS s t env1' env2' env where -- in -- in -- -aletD :: Kit acc - => EmbedAcc acc - -> ElimAcc acc +aletD :: EmbedAcc OpenAcc + -> ElimAcc OpenAcc -> ALeftHandSide arrs aenv aenv' - -> acc aenv arrs - -> acc aenv' brrs - -> Embed acc aenv brrs + -> OpenAcc aenv arrs + -> OpenAcc aenv' brrs + -> Embed OpenAcc aenv brrs aletD embedAcc elimAcc lhs (embedAcc -> Embed env1 cc1) acc0 -- let-floating @@ -1261,7 +1299,7 @@ aletD embedAcc elimAcc lhs (embedAcc -> Embed env1 cc1) acc0 -- that must be later eliminated by shrinking. -- | LeftHandSideSingle _ <- lhs - , Done (VarsSingle v1@(Var ArrayR{} _)) <- cc1 + , Done (TupRsingle v1@(Var ArrayR{} _)) <- cc1 , Embed env0 cc0 <- embedAcc $ rebuildA (subAtop (Avar v1) . sink1 env1) acc0 = Stats.ruleFired "aletD/float" $ Embed (env1 `append` env0) cc0 @@ -1272,13 +1310,13 @@ aletD embedAcc elimAcc lhs (embedAcc -> Embed env1 cc1) acc0 = aletD' embedAcc elimAcc lhs (Embed env1 cc1) (embedAcc acc0) -aletD' :: forall acc aenv aenv' arrs brrs. Kit acc - => EmbedAcc acc - -> ElimAcc acc +aletD' :: forall aenv aenv' arrs brrs. + EmbedAcc OpenAcc + -> ElimAcc OpenAcc -> ALeftHandSide arrs aenv aenv' - -> Embed acc aenv arrs - -> Embed acc aenv' brrs - -> Embed acc aenv brrs + -> Embed OpenAcc aenv arrs + -> Embed OpenAcc aenv' brrs + -> Embed OpenAcc aenv brrs aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed env0 cc0) -- let-binding @@ -1307,28 +1345,37 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en Yield{} -> eliminate env1 cc1 acc0' where - acc0 :: acc aenv' brrs + acc0 :: OpenAcc aenv' brrs acc0 = computeAcc (Embed env0 cc0) + kmap :: forall aenv a b. (PreOpenAcc OpenAcc aenv a -> PreOpenAcc OpenAcc aenv b) + -> OpenAcc aenv a + -> OpenAcc aenv b + kmap f (OpenAcc pacc) = OpenAcc (f pacc) + -- 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. - Extend ArrayR acc aenv aenv' - -> Cunctation aenv' (Array sh e) - -> acc (aenv', Array sh e) brrs - -> Embed acc aenv brrs + eliminate + :: forall aenv aenv' sh e brrs. + Extend ArrayR OpenAcc aenv aenv' + -> Cunctation aenv' (Array sh e) + -> OpenAcc (aenv', Array sh e) brrs + -> Embed OpenAcc aenv brrs eliminate env1 cc1 body | Done v1 <- cc1 - , VarsSingle v1'@(Var r _) <- v1 = elim r (arrayShape v1') (indexArray v1') + , TupRsingle v1'@(Var r _) <- v1 = elim r (arrayShape v1') (indexArray v1') | Step r sh1 p1 f1 v1 <- cc1 = elim r sh1 (f1 `compose` indexArray v1 `compose` p1) | Yield r sh1 f1 <- cc1 = elim r sh1 f1 where - bnd :: PreOpenAcc acc aenv' (Array sh e) + bnd :: PreOpenAcc OpenAcc aenv' (Array sh e) bnd = compute cc1 - elim :: ArrayR (Array sh e) -> Exp aenv' sh -> Fun aenv' (sh -> e) -> Embed acc aenv brrs + elim :: ArrayR (Array sh e) + -> Exp aenv' sh + -> Fun aenv' (sh -> e) + -> Embed OpenAcc aenv brrs elim r sh1 f1 | sh1' <- weaken (weakenSucc' weakenId) sh1 , f1' <- weaken (weakenSucc' weakenId) f1 @@ -1348,42 +1395,42 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en OpenExp env aenv sh -> OpenFun env aenv (sh -> e) -> ArrayVar aenv (Array sh e) -> OpenExp env aenv t -> OpenExp env aenv t - replaceE sh' f' avar@(Var (ArrayR shr _) _) exp = + replaceE sh' f' avar@(Var (ArrayR shR _) _) exp = case exp of Let lhs x y -> let k = weakenWithLHS lhs in Let lhs (cvtE x) (replaceE (weakenE k sh') (weakenE k f') avar y) Evar var -> Evar var - Foreign tp ff f e -> Foreign tp ff f (cvtE e) - Const tp c -> Const tp c - Undef tp -> Undef tp + Foreign tR ff f e -> Foreign tR ff f (cvtE e) + Const tR c -> Const tR c + Undef tR -> Undef tR Nil -> Nil Pair e1 e2 -> Pair (cvtE e1) (cvtE e2) IndexSlice x ix sh -> IndexSlice x (cvtE ix) (cvtE sh) IndexFull x ix sl -> IndexFull x (cvtE ix) (cvtE sl) - ToIndex shr' sh ix -> ToIndex shr' (cvtE sh) (cvtE ix) - FromIndex shr' sh i -> FromIndex shr' (cvtE sh) (cvtE i) + ToIndex shR' sh ix -> ToIndex shR' (cvtE sh) (cvtE ix) + FromIndex shR' sh i -> FromIndex shR' (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 shr' sh -> ShapeSize shr' (cvtE sh) + ShapeSize shR' sh -> ShapeSize shR' (cvtE sh) While p f x -> While (replaceF sh' f' avar p) (replaceF sh' f' avar f) (cvtE x) Coerce t1 t2 e -> Coerce t1 t2 (cvtE e) Shape a - | Just Refl <- match a avar -> Stats.substitution "replaceE/shape" sh' - | otherwise -> exp + | Just Refl <- matchVar a avar -> Stats.substitution "replaceE/shape" sh' + | otherwise -> exp Index a sh - | Just Refl <- match a avar + | Just Refl <- matchVar a avar , Lam lhs (Body b) <- f' -> Stats.substitution "replaceE/!" . cvtE $ Let lhs sh b | otherwise -> Index a (cvtE sh) LinearIndex a i - | Just Refl <- match a avar + | Just Refl <- matchVar a avar , Lam lhs (Body b) <- f' -> Stats.substitution "replaceE/!!" . cvtE $ Let lhs - (Let (LeftHandSideSingle scalarTypeInt) i $ FromIndex shr (weakenE (weakenSucc' weakenId) sh') $ Evar $ Var scalarTypeInt ZeroIdx) + (Let (LeftHandSideSingle scalarTypeInt) i $ FromIndex shR (weakenE (weakenSucc' weakenId) sh') $ Evar $ Var scalarTypeInt ZeroIdx) b | otherwise -> LinearIndex a (cvtE i) @@ -1402,16 +1449,18 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en in Lam lhs (replaceF (weakenE k sh') (weakenE k f') avar f) replaceA :: forall aenv sh e a. - Exp aenv sh -> Fun aenv (sh -> e) -> ArrayVar aenv (Array sh e) - -> PreOpenAcc acc aenv a - -> PreOpenAcc acc aenv a + Exp aenv sh + -> Fun aenv (sh -> e) + -> ArrayVar aenv (Array sh e) + -> PreOpenAcc OpenAcc aenv a + -> PreOpenAcc OpenAcc aenv a replaceA sh' f' avar pacc = case pacc of Avar v - | Just Refl <- match v avar -> Avar avar - | otherwise -> Avar v + | Just Refl <- matchVar v avar -> Avar avar + | otherwise -> Avar v - Alet lhs bnd (body :: acc aenv1 a) -> + Alet lhs bnd (body :: OpenAcc aenv1 a) -> let w :: aenv :> aenv1 w = weakenWithLHS lhs sh'' = weaken w sh' @@ -1420,7 +1469,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en Alet lhs (cvtA bnd) (kmap (replaceA sh'' f'' (weaken w avar)) body) Use repr arrs -> Use repr arrs - Unit tp e -> Unit tp (cvtE e) + Unit tR e -> Unit tR (cvtE e) Acond p at ae -> Acond (cvtE p) (cvtA at) (cvtA ae) Anil -> Anil Apair a1 a2 -> Apair (cvtA a1) (cvtA a2) @@ -1428,13 +1477,13 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en Apply repr f a -> Apply repr (cvtAF f) (cvtA a) Aforeign repr ff f a -> Aforeign repr ff f (cvtA a) -- no sharing between f and a Generate repr sh f -> Generate repr (cvtE sh) (cvtF f) - Map tp f a -> Map tp (cvtF f) (cvtA a) - ZipWith tp f a b -> ZipWith tp (cvtF f) (cvtA a) (cvtA b) - Backpermute shr sh p a -> Backpermute shr (cvtE sh) (cvtF p) (cvtA a) + Map tR f a -> Map tR (cvtF f) (cvtA a) + ZipWith tR f a b -> ZipWith tR (cvtF f) (cvtA a) (cvtA b) + Backpermute shR sh p a -> Backpermute shR (cvtE sh) (cvtF p) (cvtA a) Transform repr sh p f a -> Transform repr (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 shr sl a -> Reshape shr (cvtE sl) (cvtA a) + Reshape shR sl a -> Reshape shR (cvtE sl) (cvtA a) Fold f z a -> Fold (cvtF f) (cvtE z) (cvtA a) Fold1 f a -> Fold1 (cvtF f) (cvtA a) FoldSeg i f z a s -> FoldSeg i (cvtF f) (cvtE z) (cvtA a) (cvtA s) @@ -1452,7 +1501,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en -- Collect seq -> Collect (cvtSeq seq) where - cvtA :: acc aenv s -> acc aenv s + cvtA :: OpenAcc aenv s -> OpenAcc aenv s cvtA = kmap (replaceA sh' f' avar) cvtE :: Exp aenv s -> Exp aenv s @@ -1468,15 +1517,15 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en cvtB (Constant c) = Constant c cvtB (Function f) = Function (cvtF f) - cvtAF :: PreOpenAfun acc aenv s -> PreOpenAfun acc aenv s + cvtAF :: PreOpenAfun OpenAcc aenv s -> PreOpenAfun OpenAcc aenv s cvtAF = cvt sh' f' avar where cvt :: forall aenv a. Exp aenv sh -> Fun aenv (sh -> e) -> ArrayVar aenv (Array sh e) - -> PreOpenAfun acc aenv a - -> PreOpenAfun acc aenv a + -> PreOpenAfun OpenAcc aenv a + -> PreOpenAfun OpenAcc aenv a cvt sh'' f'' avar' (Abody a) = Abody $ kmap (replaceA sh'' f'' avar') a - cvt sh'' f'' avar' (Alam lhs (af :: PreOpenAfun acc aenv1 b)) = + cvt sh'' f'' avar' (Alam lhs (af :: PreOpenAfun OpenAcc aenv1 b)) = Alam lhs $ cvt (weaken w sh'') (weaken w f'') (weaken w avar') @@ -1534,67 +1583,120 @@ aletD' _ _ lhs (Embed env1 cc1) (Embed env0 cc0) -- both branches. This would result in redundant work processing the bindings -- for the branch not taken. -- -acondD :: Kit acc - => EmbedAcc acc - -> Exp 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)) +acondD :: MatchAcc OpenAcc + -> EmbedAcc OpenAcc + -> Exp aenv Bool + -> OpenAcc aenv arrs + -> OpenAcc aenv arrs + -> Embed OpenAcc aenv arrs +acondD matchAcc embedAcc p t e + | Const _ True <- p = Stats.knownBranch "True" $ embedAcc t + | Const _ False <- p = Stats.knownBranch "False" $ embedAcc e + | Just Refl <- matchAcc t e = Stats.knownBranch "redundant" $ embedAcc e + | otherwise = done $ Acond p (computeAcc (embedAcc t)) + (computeAcc (embedAcc e)) -- Scalar expressions -- ------------------ -identity :: TupleType a -> OpenFun env aenv (a -> a) -identity tp - | DeclareVars lhs _ value <- declareVars tp - = Lam lhs $ Body $ evars $ value weakenId +identity :: TypeR a -> OpenFun env aenv (a -> a) +identity t + | DeclareVars lhs _ value <- declareVars t + = Lam lhs $ Body $ expVars $ value weakenId toIndex :: ShapeR sh -> OpenExp env aenv sh -> OpenFun env aenv (sh -> Int) -toIndex shr sh - | DeclareVars lhs k value <- declareVars $ shapeType shr - = Lam lhs $ Body $ ToIndex shr (weakenE k sh) $ evars $ value weakenId +toIndex shR sh + | DeclareVars lhs k value <- declareVars $ shapeType shR + = Lam lhs $ Body $ ToIndex shR (weakenE k sh) $ expVars $ value weakenId fromIndex :: ShapeR sh -> OpenExp env aenv sh -> OpenFun env aenv (Int -> sh) -fromIndex shr sh = Lam (LeftHandSideSingle scalarTypeInt) $ Body $ FromIndex shr (weakenE (weakenSucc' weakenId) sh) $ Evar $ Var scalarTypeInt ZeroIdx +fromIndex shR sh + = Lam (LeftHandSideSingle scalarTypeInt) + $ Body + $ FromIndex shR (weakenE (weakenSucc' weakenId) sh) + $ Evar + $ Var scalarTypeInt ZeroIdx + +intersect :: ShapeR sh -> OpenExp env aenv sh -> OpenExp env aenv sh -> OpenExp env aenv sh +intersect = mkShapeBinary f + where + f a b = PrimApp (PrimMin singleType) $ Pair a b + +-- union :: ShapeR sh -> OpenExp env aenv sh -> OpenExp env aenv sh -> OpenExp env aenv sh +-- union = mkShapeBinary f +-- where +-- f a b = PrimApp (PrimMax singleType) $ Pair a b + +mkShapeBinary + :: (forall env'. OpenExp env' aenv Int -> OpenExp env' aenv Int -> OpenExp env' aenv Int) + -> ShapeR sh + -> OpenExp env aenv sh + -> OpenExp env aenv sh + -> OpenExp env aenv sh +mkShapeBinary _ ShapeRz _ _ = Nil +mkShapeBinary f (ShapeRsnoc shR) (Pair as a) (Pair bs b) = mkShapeBinary f shR as bs `Pair` f a b +mkShapeBinary f shR (Let lhs bnd a) b = Let lhs bnd $ mkShapeBinary f shR a (weakenE (weakenWithLHS lhs) b) +mkShapeBinary f shR a (Let lhs bnd b) = Let lhs bnd $ mkShapeBinary f shR (weakenE (weakenWithLHS lhs) a) b +mkShapeBinary f shR a b@Pair{} -- `a` is not Pair + | DeclareVars lhs k value <- declareVars $ shapeType shR + = Let lhs a $ mkShapeBinary f shR (expVars $ value weakenId) (weakenE k b) +mkShapeBinary f shR a b -- `b` is not a Pair + | DeclareVars lhs k value <- declareVars $ shapeType shR + = Let lhs b $ mkShapeBinary f shR (weakenE k a) (expVars $ value weakenId) reindex :: ShapeR sh' -> OpenExp env aenv sh' -> ShapeR sh -> OpenExp env aenv sh -> OpenFun env aenv (sh -> sh') -reindex shr' sh' shr sh - | Just Refl <- match sh sh' = identity (shapeType shr') - | otherwise = fromIndex shr' sh' `compose` toIndex shr sh +reindex shR' sh' shR sh + | Just Refl <- matchOpenExp sh sh' = identity (shapeType shR') + | otherwise = fromIndex shR' sh' `compose` toIndex shR sh extend :: SliceIndex slix sl co sh -> Exp aenv slix -> Fun aenv (sh -> sl) extend sliceIndex slix | DeclareVars lhs k value <- declareVars $ shapeType $ sliceDomainR sliceIndex - = Lam lhs $ Body $ IndexSlice sliceIndex (weakenE k slix) $ evars $ value weakenId + = Lam lhs $ Body $ IndexSlice sliceIndex (weakenE k slix) $ expVars $ value weakenId restrict :: SliceIndex slix sl co sh -> Exp aenv slix -> Fun aenv (sl -> sh) restrict sliceIndex slix | DeclareVars lhs k value <- declareVars $ shapeType $ sliceShapeR sliceIndex - = Lam lhs $ Body $ IndexFull sliceIndex (weakenE k slix) $ evars $ value weakenId + = Lam lhs $ Body $ IndexFull sliceIndex (weakenE k slix) $ expVars $ value weakenId arrayShape :: ArrayVar aenv (Array sh e) -> Exp aenv sh -arrayShape = simplify . Shape +arrayShape = simplifyExp . Shape indexArray :: ArrayVar aenv (Array sh e) -> Fun aenv (sh -> e) -indexArray v@(Var (ArrayR shr _) _) - | DeclareVars lhs _ value <- declareVars $ shapeType shr - = Lam lhs $ Body $ Index v $ evars $ value weakenId +indexArray v@(Var (ArrayR shR _) _) + | DeclareVars lhs _ value <- declareVars $ shapeType shR + = Lam lhs $ Body $ Index v $ expVars $ value weakenId linearIndex :: ArrayVar aenv (Array sh e) -> Fun aenv (Int -> e) linearIndex v = Lam (LeftHandSideSingle scalarTypeInt) $ Body $ LinearIndex v $ Evar $ Var scalarTypeInt ZeroIdx + +extractOpenAcc :: ExtractAcc OpenAcc +extractOpenAcc (OpenAcc pacc) = Just pacc + +extractDelayedOpenAcc :: ExtractAcc DelayedOpenAcc +extractDelayedOpenAcc (Manifest pacc) = Just pacc +extractDelayedOpenAcc _ = Nothing + +extractOpenArrayVars + :: OpenAcc aenv a + -> Maybe (ArrayVars aenv a) +extractOpenArrayVars (OpenAcc pacc) = + avarsOut extractOpenAcc pacc + +extractDelayedArrayVars + :: DelayedOpenAcc aenv a + -> Maybe (ArrayVars aenv a) +extractDelayedArrayVars acc + | Just pacc <- extractDelayedOpenAcc acc = avarsOut extractDelayedOpenAcc pacc + | otherwise = Nothing + diff --git a/src/Data/Array/Accelerate/Trafo/LetSplit.hs b/src/Data/Array/Accelerate/Trafo/LetSplit.hs index 6294de7ea..4492e9d43 100644 --- a/src/Data/Array/Accelerate/Trafo/LetSplit.hs +++ b/src/Data/Array/Accelerate/Trafo/LetSplit.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} -- | -- Module : Data.Array.Accelerate.Trafo.LetSplit -- Copyright : [2012..2019] The Accelerate Team @@ -11,60 +12,70 @@ module Data.Array.Accelerate.Trafo.LetSplit ( - convertAcc, convertAfun + convertAfun, + convertAcc, ) where import Prelude hiding ( exp ) import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Trafo.Base +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Environment +import Data.Array.Accelerate.Trafo.Substitution -convertAcc :: Kit acc => acc aenv a -> acc aenv a -convertAcc acc = case extract acc of - Just a -> travA a - Nothing -> acc -travA :: Kit acc => PreOpenAcc acc aenv a -> acc aenv a -travA (Alet lhs bnd body) = travBinding lhs (convertAcc bnd) (convertAcc body) -travA (Avar var) = inject $ Avar var -travA (Apair a1 a2) = inject $ Apair (convertAcc a1) (convertAcc a2) -travA Anil = inject $ Anil -travA (Apply repr f a) = inject $ Apply repr (convertAfun f) (convertAcc a) -travA (Aforeign repr asm f a) = inject $ Aforeign repr asm (convertAfun f) (convertAcc a) -travA (Acond e a1 a2) = inject $ Acond e (convertAcc a1) (convertAcc a2) -travA (Awhile c f a) = inject $ Awhile (convertAfun c) (convertAfun f) (convertAcc a) -travA (Use repr arr) = inject $ Use repr arr -travA (Unit tp e) = inject $ Unit tp e -travA (Reshape shr e a) = inject $ Reshape shr e a -travA (Generate repr e f) = inject $ Generate repr e f -travA (Transform repr sh f g a) = inject $ Transform repr sh f g (convertAcc a) -travA (Replicate slix sl a) = inject $ Replicate slix sl (convertAcc a) -travA (Slice slix a sl) = inject $ Slice slix (convertAcc a) sl -travA (Map tp f a) = inject $ Map tp f (convertAcc a) -travA (ZipWith tp f a1 a2) = inject $ ZipWith tp f (convertAcc a1) (convertAcc a2) -travA (Fold f e a) = inject $ Fold f e (convertAcc a) -travA (Fold1 f a) = inject $ Fold1 f (convertAcc a) -travA (FoldSeg i f e a s) = inject $ FoldSeg i f e (convertAcc a) (convertAcc s) -travA (Fold1Seg i f a s) = inject $ Fold1Seg i f (convertAcc a) (convertAcc s) -travA (Scanl f e a) = inject $ Scanl f e (convertAcc a) -travA (Scanl' f e a) = inject $ Scanl' f e (convertAcc a) -travA (Scanl1 f a) = inject $ Scanl1 f (convertAcc a) -travA (Scanr f e a) = inject $ Scanr f e (convertAcc a) -travA (Scanr' f e a) = inject $ Scanr' f e (convertAcc a) -travA (Scanr1 f a) = inject $ Scanr1 f (convertAcc a) -travA (Permute f a1 g a2) = inject $ Permute f (convertAcc a1) g (convertAcc a2) -travA (Backpermute shr sh f a) = inject $ Backpermute shr sh f (convertAcc a) -travA (Stencil s tp f b a) = inject $ Stencil s tp f b (convertAcc a) -travA (Stencil2 s1 s2 tp f b1 a1 b2 a2) = inject $ Stencil2 s1 s2 tp f b1 (convertAcc a1) b2 (convertAcc a2) +convertAfun :: PreOpenAfun OpenAcc aenv f -> PreOpenAfun OpenAcc aenv f +convertAfun (Alam lhs f) = Alam lhs (convertAfun f) +convertAfun (Abody a) = Abody (convertAcc a) -travBinding :: Kit acc => ALeftHandSide bnd aenv aenv' -> acc aenv bnd -> acc aenv' a -> acc aenv a -travBinding (LeftHandSideWildcard _) _ a = a -travBinding lhs@(LeftHandSideSingle _) bnd a = inject $ Alet lhs bnd a -travBinding lhs@(LeftHandSidePair l1 l2) bnd a = case extract bnd of - Just (Apair b1 b2) -> travBinding l1 b1 $ travBinding l2 (weaken (weakenWithLHS l1) b2) a - _ -> inject $ Alet lhs bnd a +convertAcc :: OpenAcc aenv a -> OpenAcc aenv a +convertAcc (OpenAcc pacc) = OpenAcc (convertPreOpenAcc pacc) -convertAfun :: Kit acc => PreOpenAfun acc aenv f -> PreOpenAfun acc aenv f -convertAfun (Alam lhs f) = Alam lhs $ convertAfun f -convertAfun (Abody a) = Abody $ convertAcc a +convertPreOpenAcc :: PreOpenAcc OpenAcc aenv a -> PreOpenAcc OpenAcc aenv a +convertPreOpenAcc = \case + Alet lhs bnd body -> convertLHS lhs (convertAcc bnd) (convertAcc body) + Avar var -> Avar var + Apair a1 a2 -> Apair (convertAcc a1) (convertAcc a2) + Anil -> Anil + Apply repr f a -> Apply repr (convertAfun f) (convertAcc a) + Aforeign repr asm f a -> Aforeign repr asm (convertAfun f) (convertAcc a) + Acond e a1 a2 -> Acond e (convertAcc a1) (convertAcc a2) + Awhile c f a -> Awhile (convertAfun c) (convertAfun f) (convertAcc a) + Use repr arr -> Use repr arr + Unit tp e -> Unit tp e + Reshape shr e a -> Reshape shr e a + Generate repr e f -> Generate repr e f + Transform repr sh f g a -> Transform repr sh f g (convertAcc a) + Replicate slix sl a -> Replicate slix sl (convertAcc a) + Slice slix a sl -> Slice slix (convertAcc a) sl + Map tp f a -> Map tp f (convertAcc a) + ZipWith tp f a1 a2 -> ZipWith tp f (convertAcc a1) (convertAcc a2) + Fold f e a -> Fold f e (convertAcc a) + Fold1 f a -> Fold1 f (convertAcc a) + FoldSeg i f e a s -> FoldSeg i f e (convertAcc a) (convertAcc s) + Fold1Seg i f a s -> Fold1Seg i f (convertAcc a) (convertAcc s) + Scanl f e a -> Scanl f e (convertAcc a) + Scanl' f e a -> Scanl' f e (convertAcc a) + Scanl1 f a -> Scanl1 f (convertAcc a) + Scanr f e a -> Scanr f e (convertAcc a) + Scanr' f e a -> Scanr' f e (convertAcc a) + Scanr1 f a -> Scanr1 f (convertAcc a) + Permute f a1 g a2 -> Permute f (convertAcc a1) g (convertAcc a2) + Backpermute shr sh f a -> Backpermute shr sh f (convertAcc a) + Stencil s tp f b a -> Stencil s tp f b (convertAcc a) + Stencil2 s1 s2 tp f b1 a1 b2 a2 -> Stencil2 s1 s2 tp f b1 (convertAcc a1) b2 (convertAcc a2) + +convertLHS + :: ALeftHandSide bnd aenv aenv' + -> OpenAcc aenv bnd + -> OpenAcc aenv' a + -> PreOpenAcc OpenAcc aenv a +convertLHS lhs bnd@(OpenAcc pbnd) a@(OpenAcc pa) = + case lhs of + LeftHandSideWildcard{} -> pa + LeftHandSideSingle{} -> Alet lhs bnd a + LeftHandSidePair l1 l2 -> + case pbnd of + Apair b1 b2 -> convertLHS l1 b1 (OpenAcc (convertLHS l2 (weaken (weakenWithLHS l1) b2) a)) + _ -> Alet lhs bnd a diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index d15737b55..29a67c097 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -33,10 +33,10 @@ module Data.Array.Accelerate.Trafo.Sharing ( -- * HOAS to de Bruijn conversion convertAcc, convertAccWith, - Afunction, AfunctionR, AreprFunctionR, AfunctionRepr(..), afunctionRepr, + Afunction, AfunctionR, ArraysFunctionR, AfunctionRepr(..), afunctionRepr, convertAfun, convertAfunWith, - Function, FunctionR, EltReprFunctionR, FunctionRepr(..), functionRepr, + Function, FunctionR, EltFunctionR, FunctionRepr(..), functionRepr, convertExp, convertExpWith, convertFun, convertFunWith, @@ -44,39 +44,45 @@ module Data.Array.Accelerate.Trafo.Sharing ( ) where --- standard library -import Control.Applicative hiding ( Const ) +import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc, OpenExp(..), Exp, Boundary(..), HasArraysR(..), showPreAccOp ) +import Data.Array.Accelerate.AST.Environment +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Debug.Flags as Debug +import Data.Array.Accelerate.Debug.Trace as Debug +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Array ( Array, ArraysR, ArrayR(..), showArraysR ) +import Data.Array.Accelerate.Representation.Shape hiding ( zip ) +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Smart as Smart hiding ( StencilR ) +import Data.Array.Accelerate.Sugar.Array hiding ( Array, ArraysR, (!!) ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Trafo.Config +import Data.Array.Accelerate.Trafo.Var +import Data.Array.Accelerate.Trafo.Substitution +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Type +import Data.BitSet ( (\\), member ) +import qualified Data.Array.Accelerate.AST as AST +import qualified Data.Array.Accelerate.Sugar.Array as Sugar +import qualified Data.Array.Accelerate.Representation.Stencil as R + +import Control.Applicative hiding ( Const ) import Control.Monad.Fix import Data.Hashable -import Data.List hiding ( (\\) ) +import Data.List hiding ( (\\) ) import Data.Maybe -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe ( unsafePerformIO ) import System.Mem.StableName 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 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.BitSet ( (\\), member ) -import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Error -import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Trafo.Base -import Data.Array.Accelerate.Trafo.Config -import Data.Array.Accelerate.Array.Representation hiding ((!!)) -import Data.Array.Accelerate.Array.Sugar ( Elt, EltRepr, Arrays, ArrRepr, eltType ) -import qualified Data.Array.Accelerate.Array.Sugar as Sugar -import Data.Array.Accelerate.AST hiding ( PreOpenAcc(..), OpenAcc(..), Acc - , OpenExp(..), Exp - , Boundary(..) - , showPreAccOp, showPreExpOp, expType, HasArraysRepr(..), arraysRepr ) -import qualified Data.Array.Accelerate.AST as AST -import Data.Array.Accelerate.Debug.Trace as Debug -import Data.Array.Accelerate.Debug.Flags as Debug - -- Layouts -- ------- @@ -101,19 +107,20 @@ type ArrayLayout = Layout ArrayR -- The first argument provides context information for error messages in the -- case of failure. -- -prjIdx :: forall s t env env1. Match s - => String +prjIdx :: forall s t env env1. + String -> (forall t'. TupR s t' -> ShowS) + -> (forall u v. TupR s u -> TupR s v -> Maybe (u :~: v)) -> TupR s t -> Int -> Layout s env env1 -> Vars s env t -prjIdx context showTp tp = go +prjIdx context showTp matchTp tp = go where go :: forall env'. Int -> Layout s env env' -> Vars s env t go _ EmptyLayout = no "environment does not contain index" go 0 (PushLayout _ lhs vars) - | Just Refl <- match tp tp' = vars + | Just Refl <- matchTp tp tp' = vars | otherwise = no $ printf "couldn't match expected type `%s' with actual type `%s'" (showTp tp "") (showTp tp' "") @@ -128,7 +135,7 @@ prjIdx context showTp tp = go -- incLayout :: env1 :> env2 -> Layout s env1 env' -> Layout s env2 env' incLayout _ EmptyLayout = EmptyLayout -incLayout k (PushLayout lyt lhs v) = PushLayout (incLayout k lyt) lhs (weaken k v) +incLayout k (PushLayout lyt lhs v) = PushLayout (incLayout k lyt) lhs (weakenVars k v) sizeLayout :: Layout s env env' -> Int sizeLayout EmptyLayout = 0 @@ -143,30 +150,30 @@ sizeLayout (PushLayout lyt _ _) = 1 + sizeLayout lyt -- | Convert a closed array expression to de Bruijn form while also incorporating sharing -- information. -- -convertAcc :: Acc arrs -> AST.Acc (ArrRepr arrs) +convertAcc :: Acc arrs -> AST.Acc (Sugar.ArraysR arrs) convertAcc = convertAccWith defaultOptions -convertAccWith :: Config -> Acc arrs -> AST.Acc (ArrRepr arrs) +convertAccWith :: Config -> Acc arrs -> AST.Acc (Sugar.ArraysR arrs) convertAccWith config (Acc acc) = convertOpenAcc config EmptyLayout acc -- | Convert a closed function over array computations, while incorporating -- sharing information. -- -convertAfun :: Afunction f => f -> AST.Afun (AreprFunctionR f) +convertAfun :: Afunction f => f -> AST.Afun (ArraysFunctionR f) convertAfun = convertAfunWith defaultOptions -convertAfunWith :: Afunction f => Config -> f -> AST.Afun (AreprFunctionR f) +convertAfunWith :: Afunction f => Config -> f -> AST.Afun (ArraysFunctionR f) convertAfunWith config = convertOpenAfun config EmptyLayout data AfunctionRepr f ar areprr where AfunctionReprBody - :: Arrays b => AfunctionRepr (Acc b) b (ArrRepr b) + :: Arrays b => AfunctionRepr (Acc b) b (Sugar.ArraysR b) AfunctionReprLam :: Arrays a => AfunctionRepr b br breprr - -> AfunctionRepr (Acc a -> b) (a -> br) (ArrRepr a -> breprr) + -> AfunctionRepr (Acc a -> b) (a -> br) (Sugar.ArraysR a -> breprr) -- Convert a HOAS fragment into de Bruijn form, binding variables into the typed -- environment layout one binder at a time. @@ -177,17 +184,17 @@ data AfunctionRepr f ar areprr where -- class Afunction f where type AfunctionR f - type AreprFunctionR f - afunctionRepr :: AfunctionRepr f (AfunctionR f) (AreprFunctionR f) - convertOpenAfun :: Config -> ArrayLayout aenv aenv -> f -> AST.OpenAfun aenv (AreprFunctionR f) + type ArraysFunctionR f + afunctionRepr :: AfunctionRepr f (AfunctionR f) (ArraysFunctionR f) + convertOpenAfun :: Config -> ArrayLayout aenv aenv -> f -> AST.OpenAfun aenv (ArraysFunctionR f) instance (Arrays a, Afunction r) => Afunction (Acc a -> r) where - type AfunctionR (Acc a -> r) = a -> AfunctionR r - type AreprFunctionR (Acc a -> r) = ArrRepr a -> AreprFunctionR r + type AfunctionR (Acc a -> r) = a -> AfunctionR r + type ArraysFunctionR (Acc a -> r) = Sugar.ArraysR a -> ArraysFunctionR r afunctionRepr = AfunctionReprLam $ afunctionRepr @r convertOpenAfun config alyt f - | repr <- Sugar.arrays @a + | repr <- Sugar.arraysR @a , DeclareVars lhs k value <- declareVars repr = let a = Acc $ SmartAcc $ Atag repr $ sizeLayout alyt @@ -196,8 +203,8 @@ instance (Arrays a, Afunction r) => Afunction (Acc a -> r) where Alam lhs $ convertOpenAfun config alyt' $ f a instance Arrays b => Afunction (Acc b) where - type AfunctionR (Acc b) = b - type AreprFunctionR (Acc b) = ArrRepr b + type AfunctionR (Acc b) = b + type ArraysFunctionR (Acc b) = Sugar.ArraysR b afunctionRepr = AfunctionReprBody convertOpenAfun config alyt (Acc body) = Abody $ convertOpenAcc config alyt body @@ -242,10 +249,10 @@ convertSharingAcc -> AST.OpenAcc aenv arrs convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa repr)) | Just i <- findIndex (matchStableAcc sa) aenv' - = avarsIn $ prjIdx (ctxt ++ "; i = " ++ show i) showArraysR repr i alyt + = avarsIn AST.OpenAcc + $ prjIdx (ctxt ++ "; i = " ++ show i) showArraysR matchArraysR repr i alyt | null aenv' - = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++ - show (hashStableNameHeight sa) ++ ")" + = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++ show (hashStableNameHeight sa) ++ ")" | otherwise = $internalError "convertSharingAcc" err where @@ -254,7 +261,7 @@ convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa repr)) err = "inconsistent valuation @ " ++ ctxt ++ ";\n aenv = " ++ show aenv' convertSharingAcc config alyt aenv (ScopedAcc lams (AletSharing sa@(StableSharingAcc (_ :: StableAccName as) boundAcc) bodyAcc)) - = case declareVars $ AST.arraysRepr bound of + = case declareVars $ AST.arraysR bound of DeclareVars lhs k value -> let alyt' = PushLayout (incLayout k alyt) lhs (value weakenId) @@ -277,10 +284,10 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) cvtE :: ScopedExp t -> AST.Exp aenv t cvtE = convertSharingExp config EmptyLayout alyt [] aenv' - cvtF1 :: TupleType a -> (SmartExp a -> ScopedExp b) -> AST.Fun aenv (a -> b) + cvtF1 :: TypeR a -> (SmartExp a -> ScopedExp b) -> AST.Fun aenv (a -> b) cvtF1 = convertSharingFun1 config alyt aenv' - cvtF2 :: TupleType a -> TupleType b -> (SmartExp a -> SmartExp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c) + cvtF2 :: TypeR a -> TypeR b -> (SmartExp a -> SmartExp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c) cvtF2 = convertSharingFun2 config alyt aenv' cvtAfun1 :: ArraysR a -> (SmartAcc a -> ScopedAcc b) -> AST.OpenAfun aenv (a -> b) @@ -292,14 +299,14 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) cvtAprj' :: forall a b c aenv1. PairIdx (a, b) c -> AST.OpenAcc aenv1 (a, b) -> AST.OpenAcc aenv1 c cvtAprj' PairIdxLeft (AST.OpenAcc (AST.Apair a _)) = a cvtAprj' PairIdxRight (AST.OpenAcc (AST.Apair _ b)) = b - cvtAprj' ix a = case declareVars $ AST.arraysRepr a of + cvtAprj' ix a = case declareVars $ AST.arraysR a of DeclareVars lhs _ value -> - AST.OpenAcc $ AST.Alet lhs a $ cvtAprj' ix $ avarsIn $ value weakenId + AST.OpenAcc $ AST.Alet lhs a $ cvtAprj' ix $ avarsIn AST.OpenAcc $ value weakenId in case preAcc of Atag repr i - -> let AST.OpenAcc a = avarsIn $ prjIdx ("de Bruijn conversion tag " ++ show i) showArraysR repr i alyt + -> let AST.OpenAcc a = avarsIn AST.OpenAcc $ prjIdx ("de Bruijn conversion tag " ++ show i) showArraysR matchArraysR repr i alyt in a Pipe reprA reprB reprC (afun1 :: SmartAcc as -> ScopedAcc bs) (afun2 :: SmartAcc bs -> ScopedAcc cs) acc @@ -310,11 +317,11 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) alyt' = PushLayout (incLayout k alyt) lhs (value weakenId) bodyAcc = AST.Apply reprC (convertSharingAfun1 config alyt' (noStableSharing : aenv') reprB afun2) - (avarsIn $ value weakenId) + (avarsIn AST.OpenAcc $ value weakenId) in AST.Alet lhs (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc) Aforeign repr ff afun acc - -> AST.Aforeign repr ff (convertSmartAfun1 config (arraysRepr acc) afun) (cvtA acc) + -> AST.Aforeign repr ff (convertSmartAfun1 config (Smart.arraysR acc) afun) (cvtA acc) Acond b acc1 acc2 -> AST.Acond (cvtE b) (cvtA acc1) (cvtA acc2) Awhile reprA pred iter init -> AST.Awhile (cvtAfun1 reprA pred) (cvtAfun1 reprA iter) (cvtA init) @@ -350,10 +357,10 @@ convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc)) -> AST.Stencil stencil tp (convertSharingStencilFun1 config alyt aenv' stencil f) - (convertSharingBoundary config alyt aenv' (stencilShape stencil) boundary) + (convertSharingBoundary config alyt aenv' (stencilShapeR stencil) boundary) (cvtA acc) Stencil2 stencil1 stencil2 tp f bndy1 acc1 bndy2 acc2 - | shr <- stencilShape stencil1 + | shr <- stencilShapeR stencil1 -> AST.Stencil2 stencil1 stencil2 tp @@ -570,37 +577,37 @@ convertSharingBoundary config alyt aenv shr = cvt -- In higher-order abstract syntax, this represents an n-ary, polyvariadic -- function. -- -convertFun :: Function f => f -> AST.Fun () (EltReprFunctionR f) +convertFun :: Function f => f -> AST.Fun () (EltFunctionR f) convertFun = convertFunWith $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing] } -convertFunWith :: Function f => Config -> f -> AST.Fun () (EltReprFunctionR f) +convertFunWith :: Function f => Config -> f -> AST.Fun () (EltFunctionR f) convertFunWith config = convertOpenFun config EmptyLayout data FunctionRepr f r reprr where FunctionReprBody - :: Elt b => FunctionRepr (Exp b) b (EltRepr b) + :: Elt b => FunctionRepr (Exp b) b (EltR b) FunctionReprLam :: Elt a => FunctionRepr b br breprr - -> FunctionRepr (Exp a -> b) (a -> br) (EltRepr a -> breprr) + -> FunctionRepr (Exp a -> b) (a -> br) (EltR a -> breprr) class Function f where type FunctionR f - type EltReprFunctionR f + type EltFunctionR f - functionRepr :: FunctionRepr f (FunctionR f) (EltReprFunctionR f) - convertOpenFun :: Config -> ELayout env env -> f -> AST.OpenFun env () (EltReprFunctionR f) + functionRepr :: FunctionRepr f (FunctionR f) (EltFunctionR f) + convertOpenFun :: Config -> ELayout env env -> f -> AST.OpenFun env () (EltFunctionR f) instance (Elt a, Function r) => Function (Exp a -> r) where type FunctionR (Exp a -> r) = a -> FunctionR r - type EltReprFunctionR (Exp a -> r) = EltRepr a -> EltReprFunctionR r + type EltFunctionR (Exp a -> r) = EltR a -> EltFunctionR r functionRepr = FunctionReprLam $ functionRepr @r convertOpenFun config lyt f - | tp <- eltType @a + | tp <- eltR @a , DeclareVars lhs k value <- declareVars tp = let e = Exp $ SmartExp $ Tag tp $ sizeLayout lyt @@ -610,12 +617,12 @@ instance (Elt a, Function r) => Function (Exp a -> r) where instance Elt b => Function (Exp b) where type FunctionR (Exp b) = b - type EltReprFunctionR (Exp b) = EltRepr b + type EltFunctionR (Exp b) = EltR b functionRepr = FunctionReprBody convertOpenFun config lyt (Exp body) = Body $ convertOpenExp config lyt body -convertSmartFun :: Config -> TupleType a -> (SmartExp a -> SmartExp b) -> AST.Fun () (a -> b) +convertSmartFun :: Config -> TypeR a -> (SmartExp a -> SmartExp b) -> AST.Fun () (a -> b) convertSmartFun config tp f | DeclareVars lhs _ value <- declareVars tp = let @@ -630,12 +637,12 @@ convertSmartFun config tp f -- | Convert a closed scalar expression to de Bruijn form while incorporating -- sharing information. -- -convertExp :: Exp e -> AST.Exp () (EltRepr e) +convertExp :: Exp e -> AST.Exp () (EltR e) convertExp = convertExpWith $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing] } -convertExpWith :: Config -> Exp e -> AST.Exp () (EltRepr e) +convertExpWith :: Config -> Exp e -> AST.Exp () (EltR e) convertExpWith config (Exp e) = convertOpenExp config EmptyLayout e convertOpenExp @@ -661,7 +668,7 @@ convertOpenExp config lyt exp = convertSharingExp :: forall t env aenv. Config - -> ELayout env env -- scalar environment + -> ELayout env env -- scalar environment -> ArrayLayout aenv aenv -- array environment -> [StableSharingExp] -- currently bound sharing variables of expressions -> [StableSharingAcc] -- currently bound sharing variables of array computations @@ -674,7 +681,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp cvt :: ScopedExp t' -> AST.OpenExp env aenv t' cvt (ScopedExp _ (VarSharing se tp)) - | Just i <- findIndex (matchStableExp se) env' = evars (prjIdx (ctx i) showType tp i lyt) + | Just i <- findIndex (matchStableExp se) env' = expVars (prjIdx (ctx i) shows matchTypeR tp i lyt) | otherwise = $internalError "convertSharingExp" msg where ctx i = printf "shared 'Exp' tree with stable name %d; i=%d" (hashStableNameHeight se) i @@ -722,14 +729,14 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp ] cvt (ScopedExp _ (LetSharing se@(StableSharingExp _ boundExp) bodyExp)) - | DeclareVars lhs k value <- declareVars $ expType boundExp + | DeclareVars lhs k value <- declareVars $ typeR boundExp = let lyt' = PushLayout (incLayout k lyt) lhs (value weakenId) in AST.Let lhs (cvt (ScopedExp [] boundExp)) (convertSharingExp config lyt' alyt (se:env') aenv bodyExp) cvt (ScopedExp _ (ExpSharing _ pexp)) = case pexp of - Tag tp i -> evars $ prjIdx ("de Bruijn conversion tag " ++ show i) showType tp i lyt + Tag tp i -> expVars $ prjIdx ("de Bruijn conversion tag " ++ show i) shows matchTypeR tp i lyt Const tp v -> AST.Const tp v Undef tp -> AST.Undef tp Prj idx e -> cvtPrj idx (cvt e) @@ -747,7 +754,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp LinearIndex _ a i -> AST.LinearIndex (cvtAvar a) (cvt i) Shape _ a -> AST.Shape (cvtAvar a) ShapeSize shr e -> AST.ShapeSize shr (cvt e) - Foreign repr ff f e -> AST.Foreign repr ff (convertSmartFun config (expType e) f) (cvt e) + Foreign repr ff f e -> AST.Foreign repr ff (convertSmartFun config (typeR e) f) (cvt e) Coerce t1 t2 e -> AST.Coerce t1 t2 (cvt e) cvtPrj :: forall a b c env1 aenv1. PairIdx (a, b) c -> AST.OpenExp env1 aenv1 (a, b) -> AST.OpenExp env1 aenv1 c @@ -755,7 +762,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp cvtPrj PairIdxRight (AST.Pair _ b) = b cvtPrj ix a | DeclareVars lhs _ value <- declareVars $ AST.expType a - = AST.Let lhs a $ cvtPrj ix $ evars $ value weakenId + = AST.Let lhs a $ cvtPrj ix $ expVars $ value weakenId cvtA :: ScopedAcc a -> AST.OpenAcc aenv a cvtA = convertSharingAcc config alyt aenv @@ -765,7 +772,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp AST.OpenAcc (AST.Avar var) -> var _ -> $internalError "convertSharingExp" "Expected array computation in expression to be floated out" - cvtFun1 :: TupleType a -> (SmartExp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b) + cvtFun1 :: TypeR a -> (SmartExp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b) cvtFun1 tp f | DeclareVars lhs k value <- declareVars tp = let @@ -788,7 +795,7 @@ convertSharingFun1 :: Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables - -> TupleType a + -> TypeR a -> (SmartExp a -> ScopedExp b) -> AST.Fun aenv (a -> b) convertSharingFun1 config alyt aenv tp f @@ -806,8 +813,8 @@ convertSharingFun2 :: Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables - -> TupleType a - -> TupleType b + -> TypeR a + -> TypeR b -> (SmartExp a -> SmartExp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c) convertSharingFun2 config alyt aenv ta tb f @@ -828,11 +835,11 @@ convertSharingStencilFun1 :: Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables - -> StencilR sh a stencil + -> R.StencilR sh a stencil -> (SmartExp stencil -> ScopedExp b) -> AST.Fun aenv (stencil -> b) -convertSharingStencilFun1 config alyt aenv stencil stencilFun - = convertSharingFun1 config alyt aenv (stencilType stencil) stencilFun +convertSharingStencilFun1 config alyt aenv sR1 stencil = + convertSharingFun1 config alyt aenv (R.stencilR sR1) stencil -- | Convert a binary stencil function -- @@ -840,12 +847,12 @@ convertSharingStencilFun2 :: Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables - -> StencilR sh a stencil1 - -> StencilR sh b stencil2 + -> R.StencilR sh a stencil1 + -> R.StencilR sh b stencil2 -> (SmartExp stencil1 -> SmartExp stencil2 -> ScopedExp c) -> AST.Fun aenv (stencil1 -> stencil2 -> c) -convertSharingStencilFun2 config alyt aenv stencil1 stencil2 stencilFun - = convertSharingFun2 config alyt aenv (stencilType stencil1) (stencilType stencil2) stencilFun +convertSharingStencilFun2 config alyt aenv sR1 sR2 stencil = + convertSharingFun2 config alyt aenv (R.stencilR sR1) (R.stencilR sR2) stencil -- Sharing recovery @@ -1037,10 +1044,10 @@ data SharingAcc acc exp arrs where AletSharing :: StableSharingAcc -> acc arrs -> SharingAcc acc exp arrs AccSharing :: StableAccName arrs -> PreSmartAcc acc exp arrs -> SharingAcc acc exp arrs -instance HasArraysRepr acc => HasArraysRepr (SharingAcc acc exp) where - arraysRepr (AvarSharing _ repr) = repr - arraysRepr (AletSharing _ acc) = arraysRepr acc - arraysRepr (AccSharing _ acc) = arraysRepr acc +instance HasArraysR acc => HasArraysR (SharingAcc acc exp) where + arraysR (AvarSharing _ repr) = repr + arraysR (AletSharing _ acc) = Smart.arraysR acc + arraysR (AccSharing _ acc) = Smart.arraysR acc -- Array expression with sharing but shared values have not been scoped; i.e. no let bindings. If @@ -1048,16 +1055,16 @@ instance HasArraysRepr acc => HasArraysRepr (SharingAcc acc exp) where -- immediate surrounding lambdas. data UnscopedAcc t = UnscopedAcc [Int] (SharingAcc UnscopedAcc RootExp t) -instance HasArraysRepr UnscopedAcc where - arraysRepr (UnscopedAcc _ acc) = arraysRepr acc +instance HasArraysR UnscopedAcc where + arraysR (UnscopedAcc _ acc) = Smart.arraysR acc -- 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) -instance HasArraysRepr ScopedAcc where - arraysRepr (ScopedAcc _ acc) = arraysRepr acc +instance HasArraysR ScopedAcc where + arraysR (ScopedAcc _ acc) = Smart.arraysR acc -- Stable name for an array computation associated with its sharing-annotated version. @@ -1100,30 +1107,30 @@ type StableExpName t = StableNameHeight (SmartExp t) -- do for array computations. -- data SharingExp acc exp t where - VarSharing :: StableExpName t -> TupleType t -> SharingExp acc exp t + VarSharing :: StableExpName t -> TypeR t -> SharingExp acc exp t LetSharing :: StableSharingExp -> exp t -> SharingExp acc exp t ExpSharing :: StableExpName t -> PreSmartExp acc exp t -> SharingExp acc exp t -instance HasExpType exp => HasExpType (SharingExp acc exp) where - expType (VarSharing _ tp) = tp - expType (LetSharing _ exp) = expType exp - expType (ExpSharing _ exp) = expType exp +instance HasTypeR exp => HasTypeR (SharingExp acc exp) where + typeR (VarSharing _ tp) = tp + typeR (LetSharing _ exp) = Smart.typeR exp + typeR (ExpSharing _ exp) = Smart.typeR exp -- 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) -instance HasExpType UnscopedExp where - expType (UnscopedExp _ exp) = expType exp +instance HasTypeR UnscopedExp where + typeR (UnscopedExp _ exp) = Smart.typeR exp -- 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) -instance HasExpType ScopedExp where - expType (ScopedExp _ exp) = expType exp +instance HasTypeR ScopedExp where + typeR (ScopedExp _ exp) = Smart.typeR exp -- Expressions rooted in 'SmartAcc' computations. -- @@ -1273,12 +1280,12 @@ makeOccMapSharingAcc -> IO (UnscopedAcc arrs, Int) makeOccMapSharingAcc config accOccMap = traverseAcc where - traverseFun1 :: Level -> TupleType a -> (SmartExp a -> SmartExp b) -> IO (SmartExp a -> RootExp b, Int) + traverseFun1 :: Level -> TypeR a -> (SmartExp a -> SmartExp b) -> IO (SmartExp a -> RootExp b, Int) traverseFun1 = makeOccMapFun1 config accOccMap traverseFun2 :: Level - -> TupleType a - -> TupleType b + -> TypeR a + -> TypeR b -> (SmartExp a -> SmartExp b -> SmartExp c) -> IO (SmartExp a -> SmartExp b -> RootExp c, Int) traverseFun2 = makeOccMapFun2 config accOccMap @@ -1333,7 +1340,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc reconstruct newAcc = case heightIfRepeatedOccurrence of Just height | acc_sharing `member` options config - -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height) (arraysRepr pacc)), height) + -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height) (Smart.arraysR pacc)), height) _ -> do (acc, height) <- newAcc return (UnscopedAcc [] (AccSharing (StableNameHeight sn height) acc), height) @@ -1415,12 +1422,12 @@ makeOccMapSharingAcc config accOccMap = traverseAcc return (Backpermute shr e' p' acc', h1 `max` h2 `max` h3 + 1) Stencil s tp f bnd acc -> do (f' , h1) <- makeOccMapStencil1 config accOccMap s lvl f - (bnd', h2) <- traverseBoundary lvl (stencilShape s) bnd + (bnd', h2) <- traverseBoundary lvl (stencilShapeR s) bnd (acc', h3) <- traverseAcc lvl acc return (Stencil s tp f' bnd' acc', h1 `max` h2 `max` h3 + 1) Stencil2 s1 s2 tp f bnd1 acc1 bnd2 acc2 -> do - let shr = stencilShape s1 + let shr = stencilShapeR s1 (f' , h1) <- makeOccMapStencil2 config accOccMap s1 s2 lvl f (bnd1', h2) <- traverseBoundary lvl shr bnd1 (acc1', h3) <- traverseAcc lvl acc1 @@ -1451,7 +1458,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc travF2A :: ((SmartExp b -> SmartExp c -> RootExp d) -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) - -> TupleType b -> TupleType c + -> TypeR b -> TypeR c -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartAcc arrs' -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travF2A c t1 t2 fun acc @@ -1461,7 +1468,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc return (c fun' acc', h1 `max` h2 + 1) travF2EA :: ((SmartExp b -> SmartExp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) - -> TupleType b -> TupleType c + -> TypeR b -> TypeR c -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartExp e -> SmartAcc arrs' -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travF2EA c t1 t2 fun exp acc @@ -1472,7 +1479,7 @@ makeOccMapSharingAcc config accOccMap = traverseAcc return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1) travF2A2 :: ((SmartExp b -> SmartExp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreSmartAcc UnscopedAcc RootExp arrs) - -> TupleType b -> TupleType c + -> TypeR b -> TypeR c -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartAcc arrs1 -> SmartAcc arrs2 -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travF2A2 c t1 t2 fun acc1 acc2 @@ -1540,7 +1547,7 @@ makeOccMapFun1 :: Config -> OccMapHash SmartAcc -> Level - -> TupleType a + -> TypeR a -> (SmartExp a -> SmartExp b) -> IO (SmartExp a -> RootExp b, Int) makeOccMapFun1 config accOccMap lvl tp f = do @@ -1553,8 +1560,8 @@ makeOccMapFun2 :: Config -> OccMapHash SmartAcc -> Level - -> TupleType a - -> TupleType b + -> TypeR a + -> TypeR b -> (SmartExp a -> SmartExp b -> SmartExp c) -> IO (SmartExp a -> SmartExp b -> RootExp c, Int) makeOccMapFun2 config accOccMap lvl t1 t2 f = do @@ -1568,12 +1575,12 @@ makeOccMapStencil1 :: forall sh a b stencil. Config -> OccMapHash SmartAcc - -> StencilR sh a stencil + -> R.StencilR sh a stencil -> Level -> (SmartExp stencil -> SmartExp b) -> IO (SmartExp stencil -> RootExp b, Int) makeOccMapStencil1 config accOccMap s lvl stencil = do - let x = SmartExp (Tag (stencilType s) lvl) + let x = SmartExp (Tag (R.stencilR s) lvl) -- (body, height) <- makeOccMapRootExp config accOccMap (lvl+1) [lvl] (stencil x) return (const body, height) @@ -1582,14 +1589,14 @@ makeOccMapStencil2 :: forall sh a b c stencil1 stencil2. Config -> OccMapHash SmartAcc - -> StencilR sh a stencil1 - -> StencilR sh b stencil2 + -> R.StencilR sh a stencil1 + -> R.StencilR sh b stencil2 -> Level -> (SmartExp stencil1 -> SmartExp stencil2 -> SmartExp c) -> IO (SmartExp stencil1 -> SmartExp stencil2 -> RootExp c, Int) -makeOccMapStencil2 config accOccMap s1 s2 lvl stencil = do - let x = SmartExp (Tag (stencilType s1) (lvl+1)) - y = SmartExp (Tag (stencilType s2) lvl) +makeOccMapStencil2 config accOccMap sR1 sR2 lvl stencil = do + let x = SmartExp (Tag (R.stencilR sR1) (lvl+1)) + y = SmartExp (Tag (R.stencilR sR2) lvl) -- (body, height) <- makeOccMapRootExp config accOccMap (lvl+2) [lvl, lvl+1] (stencil x y) return (\_ _ -> body, height) @@ -1652,7 +1659,7 @@ makeOccMapSharingExp config accOccMap expOccMap = travE reconstruct newExp = case heightIfRepeatedOccurrence of Just height | exp_sharing `member` options config - -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height) (expType pexp)), height) + -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height) (typeR pexp)), height) _ -> do (exp, height) <- newExp return (UnscopedExp [] (ExpSharing (StableNameHeight sn height) exp), height) @@ -1689,7 +1696,7 @@ makeOccMapSharingExp config accOccMap expOccMap = travE traverseAcc = makeOccMapSharingAcc config accOccMap traverseFun1 :: Level - -> TupleType a + -> TypeR a -> (SmartExp a -> SmartExp b) -> IO (SmartExp a -> UnscopedExp b, Int) traverseFun1 lvl tp f @@ -2337,7 +2344,7 @@ determineScopesSharingAcc config accOccMap = scopesAcc = let allCount = (StableSharingAcc sn sharingAcc `insertAccNode` newCount) in tracePure ("SHARED" ++ completed) (show allCount) - (ScopedAcc [] (AvarSharing sn $ arraysRepr newAcc), allCount) + (ScopedAcc [] (AvarSharing sn $ Smart.arraysR newAcc), allCount) -- neither shared nor free variable => leave it as it is | otherwise = tracePure ("Normal" ++ completed) (show newCount) @@ -2585,7 +2592,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp -> (ScopedAcc a, StableSharingAcc) abstract (ScopedAcc _ (AvarSharing _ _)) _ = $internalError "sharingAccToVar" "AvarSharing" abstract (ScopedAcc ssa (AletSharing sa acc)) lets = abstract acc (lets . ScopedAcc ssa . AletSharing sa) - abstract acc@(ScopedAcc ssa (AccSharing sn a)) lets = (ScopedAcc ssa (AvarSharing sn $ arraysRepr a), StableSharingAcc sn (lets acc)) + abstract acc@(ScopedAcc ssa (AccSharing sn a)) lets = (ScopedAcc ssa (AvarSharing sn $ Smart.arraysR a), StableSharingAcc sn (lets acc)) -- Occurrence count of the currently processed node expOccCount = let StableNameHeight sn' _ = sn @@ -2618,7 +2625,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp = let allCount = StableSharingExp sn sharingExp `insertExpNode` newCount in tracePure ("SHARED" ++ completed) (show allCount) - (ScopedExp [] (VarSharing sn $ expType newExp), allCount) + (ScopedExp [] (VarSharing sn $ typeR newExp), allCount) -- neither shared nor free variable => leave it as it is | otherwise = tracePure ("Normal" ++ completed) (show newCount) diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index a3d04a426..dccad0069 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -33,18 +33,30 @@ module Data.Array.Accelerate.Trafo.Shrink ( -- Shrinking - Shrink(..), ShrinkAcc, + shrinkExp, + shrinkFun, -- Occurrence counting UsesOfAcc, usesOfPreAcc, usesOfExp, ) where --- standard library -import Control.Applicative hiding ( Const ) -import Prelude hiding ( exp, seq ) -import Data.Maybe ( isJust ) +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.Environment +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Trafo.Substitution + +import qualified Data.Array.Accelerate.Debug.Stats as Stats + +import Control.Applicative hiding ( Const ) +import Prelude hiding ( exp, seq ) +import Data.Maybe ( isJust ) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup @@ -52,28 +64,11 @@ import Data.Semigroup import Data.Monoid #endif --- friends -import Data.Array.Accelerate.AST -import Data.Array.Accelerate.Trafo.Base -import Data.Array.Accelerate.Trafo.Substitution -import Data.Array.Accelerate.Error -import qualified Data.Array.Accelerate.Debug.Stats as Stats - - -class Shrink f where - shrink :: f -> f - shrink' :: f -> (Bool, f) - - shrink = snd . shrink' - -instance Shrink (OpenExp env aenv e) where - shrink' = shrinkExp - -instance Shrink (OpenFun env aenv f) where - shrink' = shrinkFun - -data VarsRange env = VarsRange !(Exists (Idx env)) !Int !(Maybe RangeTuple) -- rightmost variable, count, tuple +data VarsRange env = + VarsRange !(Exists (Idx env)) -- rightmost variable + {-# UNPACK #-} !Int -- count + !(Maybe RangeTuple) -- tuple data RangeTuple = RTNil @@ -217,6 +212,7 @@ strengthenShrunkLHS (LeftHandSidePair l h) (LeftHandSideWildcard t) k = streng strengthenShrunkLHS (LeftHandSideWildcard _) _ _ = $internalError "strengthenShrunkLHS" "Second LHS defines more variables" strengthenShrunkLHS _ _ _ = $internalError "strengthenShrunkLHS" "Mismatch LHS single with LHS pair" + -- Shrinking -- ========= @@ -520,8 +516,8 @@ usesOfPreAcc withShape countAcc idx = count where countIdx :: Idx aenv a -> Int countIdx this - | Just Refl <- match this idx = 1 - | otherwise = 0 + | Just Refl <- matchIdx this idx = 1 + | otherwise = 0 count :: PreOpenAcc acc aenv a -> Int count pacc = case pacc of diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index ec6f0f928..c217ca464 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -24,39 +24,36 @@ module Data.Array.Accelerate.Trafo.Simplify ( - Simplify(..), + simplifyFun, + simplifyExp ) where --- standard library -import Control.Applicative hiding ( Const ) -import Control.Lens hiding ( Const, ix ) -import Data.Maybe -import Data.Monoid -import Text.Printf -import Prelude hiding ( exp, iterate ) - --- friends -import Data.Array.Accelerate.AST hiding ( prj ) +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.Environment +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Array ( Array, ArrayR(..) ) +import Data.Array.Accelerate.Representation.Shape ( ShapeR(..), shapeToList ) import Data.Array.Accelerate.Trafo.Algebra -import Data.Array.Accelerate.Trafo.Base +import Data.Array.Accelerate.Trafo.Environment import Data.Array.Accelerate.Trafo.Shrink +import Data.Array.Accelerate.Trafo.Substitution import Data.Array.Accelerate.Type -import Data.Array.Accelerate.Array.Representation ( Array, shapeToList ) -import qualified Data.Array.Accelerate.Debug.Stats as Stats -import qualified Data.Array.Accelerate.Debug.Flags as Debug -import qualified Data.Array.Accelerate.Debug.Trace as Debug - -class Simplify f where - simplify :: f -> f +import qualified Data.Array.Accelerate.Debug.Stats as Stats +import qualified Data.Array.Accelerate.Debug.Flags as Debug +import qualified Data.Array.Accelerate.Debug.Trace as Debug -instance Simplify (Fun aenv f) where - simplify = simplifyFun - -instance Simplify (Exp aenv e) where - simplify = simplifyExp +import Control.Applicative hiding ( Const ) +import Control.Lens hiding ( Const, ix ) +import Data.Maybe +import Data.Monoid +import Text.Printf +import Prelude hiding ( exp, iterate ) -- Scalar optimisations @@ -268,10 +265,10 @@ simplifyOpenExp env = first getAny . cvtE -> (Any, OpenExp env aenv t) -> (Any, OpenExp 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 + | Const _ True <- p' = Stats.knownBranch "True" (yes t') + | Const _ False <- p' = Stats.knownBranch "False" (yes e') + | Just Refl <- matchOpenExp t' e' = Stats.knownBranch "redundant" (yes e') + | otherwise = Cond <$> p <*> t <*> e -- Shape manipulations -- @@ -293,16 +290,16 @@ simplifyOpenExp env = first getAny . cvtE -> (Any, OpenExp env aenv sh) -> (Any, OpenExp env aenv Int) toIndex _ (_,sh) (_,FromIndex _ sh' ix) - | Just Refl <- match sh sh' = Stats.ruleFired "toIndex/fromIndex" $ yes ix - toIndex shr sh ix = ToIndex shr <$> sh <*> ix + | Just Refl <- matchOpenExp sh sh' = Stats.ruleFired "toIndex/fromIndex" $ yes ix + toIndex shr sh ix = ToIndex shr <$> sh <*> ix fromIndex :: ShapeR sh -> (Any, OpenExp env aenv sh) -> (Any, OpenExp env aenv Int) -> (Any, OpenExp env aenv sh) fromIndex _ (_,sh) (_,ToIndex _ sh' ix) - | Just Refl <- match sh sh' = Stats.ruleFired "fromIndex/toIndex" $ yes ix - fromIndex shr sh ix = FromIndex shr <$> sh <*> ix + | Just Refl <- matchOpenExp sh sh' = Stats.ruleFired "fromIndex/toIndex" $ yes ix + fromIndex shr sh ix = FromIndex shr <$> sh <*> ix first :: (a -> a') -> (a,b) -> (a',b) first f (x,y) = (f x, y) @@ -336,10 +333,10 @@ lhsExpr (LeftHandSidePair l1 l2) env = lhsExpr l2 $ lhsExpr l1 env -- repeatedly until no more changes are made. -- simplifyExp :: Exp aenv t -> Exp aenv t -simplifyExp = iterate summariseOpenExp (simplifyOpenExp EmptyExp) +simplifyExp = iterate summariseOpenExp matchOpenExp shrinkExp (simplifyOpenExp EmptyExp) simplifyFun :: Fun aenv f -> Fun aenv f -simplifyFun = iterate summariseOpenFun (simplifyOpenFun EmptyExp) +simplifyFun = iterate summariseOpenFun matchOpenFun shrinkFun (simplifyOpenFun EmptyExp) -- NOTE: [Simplifier iterations] @@ -359,16 +356,15 @@ simplifyFun = iterate summariseOpenFun (simplifyOpenFun EmptyExp) -- 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)) + :: forall f a. (f a -> Stats) + -> (forall s t. f s -> f t -> Maybe (s :~: t)) -- match + -> (f a -> (Bool, f a)) -- shrink + -> (f a -> (Bool, f a)) -- simplify -> f a -> f a -iterate summarise f = fix 1 . setup +iterate summarise match shrink simplify = 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. @@ -377,18 +373,18 @@ iterate summarise f = fix 1 . setup -- lIMIT = 25 - simplify' = Stats.simplifierDone . f + simplify' = Stats.simplifierDone . simplify setup x = Debug.trace Debug.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 + | i > lIMIT = $internalWarning "simplify" "iteration limit reached" (not (x0 ==^ simplify x0)) x0 | not shrunk = x1 | not simplified = x2 | otherwise = fix (i+1) x2 where - (shrunk, x1) = trace i "shrink" $ shrink' x0 + (shrunk, x1) = trace i "shrink" $ shrink x0 (simplified, x2) = trace i "simplify" $ simplify' x1 -- debugging support diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index e4e3c7249..4fb6263b8 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -29,7 +29,7 @@ module Data.Array.Accelerate.Trafo.Substitution ( subTop, subAtop, -- ** Weakening - (:>), Sink(..), SinkExp(..), + (:>), Sink(..), SinkExp(..), weakenVars, -- ** Strengthening (:?>), strengthen, strengthenE, @@ -45,17 +45,22 @@ module Data.Array.Accelerate.Trafo.Substitution ( ) where -import Data.Kind -import Control.Applicative hiding ( Const ) -import Control.Monad -import Prelude hiding ( exp, seq ) - import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.Environment import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Representation import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Representation.Array import qualified Data.Array.Accelerate.Debug.Stats as Stats +import Data.Kind +import Control.Applicative hiding ( Const ) +import Control.Monad +import Prelude hiding ( exp, seq ) + -- NOTE: [Renaming and Substitution] -- @@ -88,11 +93,11 @@ lhsFullVars :: forall s a env1 env2. LeftHandSide s a env1 env2 -> Maybe (Vars s lhsFullVars = fmap snd . go weakenId where go :: forall env env' b. (env' :> env2) -> LeftHandSide s b env env' -> Maybe (env :> env2, Vars s env2 b) - go k (LeftHandSideWildcard TupRunit) = Just (k, VarsNil) - go k (LeftHandSideSingle s) = Just $ (weakenSucc $ k, VarsSingle $ Var s $ k >:> ZeroIdx) + go k (LeftHandSideWildcard TupRunit) = Just (k, TupRunit) + go k (LeftHandSideSingle s) = Just $ (weakenSucc $ k, TupRsingle $ Var s $ k >:> ZeroIdx) go k (LeftHandSidePair l1 l2) | Just (k', v2) <- go k l2 - , Just (k'', v1) <- go k' l1 = Just (k'', VarsPair v1 v2) + , Just (k'', v1) <- go k' l1 = Just (k'', TupRpair v1 v2) go _ _ = Nothing bindingIsTrivial :: LeftHandSide s a env1 env2 -> Vars s env2 b -> Maybe (a :~: b) @@ -131,18 +136,19 @@ inlineVars :: forall env env' aenv t1 t2. inlineVars lhsBound expr bound | Just vars <- lhsFullVars lhsBound = substitute (strengthenWithLHS lhsBound) weakenId vars expr where - substitute :: forall env1 env2 t. - env1 :?> env2 - -> env :> env2 - -> ExpVars env1 t1 - -> OpenExp env1 aenv t - -> Maybe (OpenExp env2 aenv t) + substitute + :: forall env1 env2 t. + env1 :?> env2 + -> env :> env2 + -> ExpVars env1 t1 + -> OpenExp env1 aenv t + -> Maybe (OpenExp env2 aenv t) substitute _ k2 vars (extractExpVars -> Just vars') | Just Refl <- matchVars vars vars' = Just $ weakenE k2 bound substitute k1 k2 vars e = case e of Let lhs e1 e2 | Exists lhs' <- rebuildLHS lhs - -> Let lhs' <$> travE e1 <*> substitute (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weaken` vars) e2 + -> Let lhs' <$> travE e1 <*> substitute (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weakenVars` vars) e2 Evar (Var t ix) -> Evar . Var t <$> k1 ix Foreign tp asm f e1 -> Foreign tp asm f <$> travE e1 Pair e1 e2 -> Pair <$> travE e1 <*> travE e2 @@ -180,7 +186,7 @@ inlineVars lhsBound expr bound -> Maybe (OpenFun env2 aenv t) substituteF k1 k2 vars (Body e) = Body <$> substitute k1 k2 vars e substituteF k1 k2 vars (Lam lhs f) - | Exists lhs' <- rebuildLHS lhs = Lam lhs' <$> substituteF (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weaken` vars) f + | Exists lhs' <- rebuildLHS lhs = Lam lhs' <$> substituteF (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weakenVars` vars) f inlineVars _ _ _ = Nothing @@ -362,11 +368,10 @@ instance Sink (Var s) where {-# INLINEABLE weaken #-} weaken k (Var s ix) = Var s (k >:> ix) -instance Sink (Vars s) where - {-# INLINEABLE weaken #-} - weaken _ VarsNil = VarsNil - weaken k (VarsSingle v) = VarsSingle $ weaken k v - weaken k (VarsPair v w) = VarsPair (weaken k v) (weaken k w) +weakenVars :: env :> env' -> Vars s env t -> Vars s env' t +weakenVars _ TupRunit = TupRunit +weakenVars k (TupRsingle v) = TupRsingle $ weaken k v +weakenVars k (TupRpair v w) = TupRpair (weakenVars k v) (weakenVars k w) rebuildWeakenVar :: env :> env' -> ArrayVar env (Array sh e) -> PreOpenAcc acc env' (Array sh e) rebuildWeakenVar k (Var s idx) = Avar $ Var s $ k >:> idx @@ -465,8 +470,8 @@ strengthenAfter (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k strengthenAfter (LeftHandSideSingle _) (LeftHandSideSingle _) k = \ix -> case ix of ZeroIdx -> Just ZeroIdx SuccIdx i -> SuccIdx <$> k i -strengthenAfter (LeftHandSidePair l1 l2) (LeftHandSidePair l1' l2') k - = strengthenAfter l2 l2' $ strengthenAfter l1 l1' k +strengthenAfter (LeftHandSidePair l1 l2) (LeftHandSidePair l1' l2') k = + strengthenAfter l2 l2' $ strengthenAfter l1 l1' k strengthenAfter _ _ _ = error "Substitution.strengthenAfter: left hand sides do not match" -- Simultaneous Substitution =================================================== @@ -783,8 +788,8 @@ rebuildC k v c = --} extractExpVars :: OpenExp env aenv a -> Maybe (ExpVars env a) -extractExpVars Nil = Just VarsNil -extractExpVars (Pair e1 e2) = VarsPair <$> extractExpVars e1 <*> extractExpVars e2 -extractExpVars (Evar v) = Just $ VarsSingle v +extractExpVars Nil = Just TupRunit +extractExpVars (Pair e1 e2) = TupRpair <$> extractExpVars e1 <*> extractExpVars e2 +extractExpVars (Evar v) = Just $ TupRsingle v extractExpVars _ = Nothing diff --git a/src/Data/Array/Accelerate/Trafo/Var.hs b/src/Data/Array/Accelerate/Trafo/Var.hs new file mode 100644 index 000000000..684874617 --- /dev/null +++ b/src/Data/Array/Accelerate/Trafo/Var.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Data.Array.Accelerate.Trafo.Var +-- Copyright : [2012..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Trafo.Var + where + +import Data.Array.Accelerate.AST +import Data.Array.Accelerate.AST.Environment +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Type + + +data DeclareVars s t aenv where + DeclareVars :: LeftHandSide s t env env' + -> (env :> env') + -> (forall env''. env' :> env'' -> Vars s env'' t) + -> DeclareVars s t env + +declareVars :: TupR s t -> DeclareVars s t env +declareVars TupRunit + = DeclareVars LeftHandSideUnit weakenId $ const $ TupRunit +declareVars (TupRsingle s) + = DeclareVars (LeftHandSideSingle s) (weakenSucc weakenId) $ \k -> TupRsingle $ Var s $ k >:> ZeroIdx +declareVars (TupRpair r1 r2) + | DeclareVars lhs1 subst1 a1 <- declareVars r1 + , DeclareVars lhs2 subst2 a2 <- declareVars r2 + = DeclareVars (LeftHandSidePair lhs1 lhs2) (subst2 .> subst1) $ \k -> a1 (k .> subst2) `TupRpair` a2 k + + +type InjectAcc acc = forall env t. PreOpenAcc acc env t -> acc env t +type ExtractAcc acc = forall env t. acc env t -> Maybe (PreOpenAcc acc env t) + +avarIn :: InjectAcc acc + -> ArrayVar aenv a + -> acc aenv a +avarIn inject v@(Var ArrayR{} _) = inject (Avar v) + +avarsIn :: forall acc aenv arrs. + InjectAcc acc + -> ArrayVars aenv arrs + -> acc aenv arrs +avarsIn inject = go + where + go :: ArrayVars aenv t -> acc aenv t + go TupRunit = inject Anil + go (TupRsingle v) = avarIn inject v + go (TupRpair a b) = inject (go a `Apair` go b) + +avarsOut + :: ExtractAcc acc + -> PreOpenAcc acc aenv a + -> Maybe (ArrayVars aenv a) +avarsOut extract = \case + Anil -> Just $ TupRunit + Avar v -> Just $ TupRsingle v + Apair al ar + | Just pl <- extract al + , Just pr <- extract ar + , Just as <- avarsOut extract pl + , Just bs <- avarsOut extract pr + -> Just (TupRpair as bs) + _ -> Nothing + + diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index c1ab078d0..eabd342b5 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -15,9 +15,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -#if __GLASGOW_HASKELL__ <= 800 -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif -- | -- Module : Data.Array.Accelerate.Type -- Copyright : [2008..2019] The Accelerate Team @@ -73,13 +70,11 @@ module Data.Array.Accelerate.Type ( ) where import Data.Array.Accelerate.Orphans () -- Prim Half +import Data.Primitive.Vec -import Control.Monad.ST import Data.Bits import Data.Int -import Data.Primitive.ByteArray import Data.Primitive.Types -import Data.Text.Prettyprint.Doc import Data.Type.Equality import Data.Word import Foreign.C.Types @@ -88,8 +83,6 @@ import Language.Haskell.TH import Numeric.Half import Text.Printf -import GHC.Base ( isTrue# ) -import GHC.Int import GHC.Prim import GHC.TypeLits @@ -99,6 +92,9 @@ import GHC.TypeLits -- Reified dictionaries -- +data SingleDict a where + SingleDict :: ( Eq a, Ord a, Show a, Storable a, Prim a ) + => SingleDict a data IntegralDict a where IntegralDict :: ( Bounded a, Eq a, Ord a, Show a @@ -171,9 +167,6 @@ data SingleType a where data VectorType a where VectorType :: KnownNat n => {-# UNPACK #-} !Int -> SingleType a -> VectorType (Vec n a) --- Showing type names --- - instance Show (IntegralType a) where show TypeInt = "Int" show TypeInt8 = "Int8" @@ -214,48 +207,42 @@ instance Show (ScalarType a) where show (SingleScalarType ty) = show ty show (VectorScalarType ty) = show ty --- Querying scalar type representations --- - --- | Integral types +-- | Querying Integral types -- class (IsSingle a, IsNum a, IsBounded a) => IsIntegral a where integralType :: IntegralType a --- | Floating types +-- | Querying Floating types -- class (Floating a, IsSingle a, IsNum a) => IsFloating a where floatingType :: FloatingType a --- | Non-numeric types +-- | Querying Non-numeric types -- class IsNonNum a where nonNumType :: NonNumType a --- | Numeric types +-- | Querying Numeric types -- class (Num a, IsSingle a) => IsNum a where numType :: NumType a --- | Bounded types +-- | Querying Bounded types -- class IsBounded a where boundedType :: BoundedType a --- | All single value types +-- | Querying single value types -- class IsScalar a => IsSingle a where singleType :: SingleType a --- | All scalar types +-- | Querying all scalar types -- class IsScalar a where scalarType :: ScalarType a --- Extract reified dictionaries --- - integralDict :: IntegralType a -> IntegralDict a integralDict TypeInt = IntegralDict integralDict TypeInt8 = IntegralDict @@ -277,35 +264,39 @@ nonNumDict :: NonNumType a -> NonNumDict a nonNumDict TypeBool = NonNumDict nonNumDict TypeChar = NonNumDict -showType :: TupleType tp -> ShowS -showType TupRunit = showString "()" -showType (TupRsingle tp) = showString $ showScalarType tp -showType (TupRpair t1 t2) = showString "(" . showType t1 . showString ", " . showType t2 . showString ")" - -showScalarType :: ScalarType tp -> String -showScalarType (SingleScalarType tp) = showSingleType tp -showScalarType (VectorScalarType (VectorType n tp)) = "Vec " ++ show n ++ " " ++ showSingleType tp - -showSingleType :: SingleType tp -> String -showSingleType (NumSingleType (IntegralNumType tp)) = case tp of - TypeInt -> "Int" - TypeInt8 -> "Int8" - TypeInt16 -> "Int16" - TypeInt32 -> "Int32" - TypeInt64 -> "Int64" - TypeWord -> "Word" - TypeWord8 -> "Word8" - TypeWord16 -> "Word16" - TypeWord32 -> "Word32" - TypeWord64 -> "Word64" -showSingleType (NumSingleType (FloatingNumType tp)) = case tp of - TypeHalf -> "Half" - TypeFloat -> "Float" - TypeDouble -> "Double" -showSingleType (NonNumSingleType TypeChar) = "Char" -showSingleType (NonNumSingleType TypeBool) = "Bool" - --- Common used types in the compiler. +singleDict :: SingleType a -> SingleDict a +singleDict = single + where + single :: SingleType a -> SingleDict a + single (NumSingleType t) = num t + single (NonNumSingleType t) = nonnum t + + nonnum :: NonNumType a -> SingleDict a + nonnum TypeChar = SingleDict + nonnum TypeBool = error "prim: We don't support vector of bools yet" + + num :: NumType a -> SingleDict a + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + integral :: IntegralType a -> SingleDict a + integral TypeInt = SingleDict + integral TypeInt8 = SingleDict + integral TypeInt16 = SingleDict + integral TypeInt32 = SingleDict + integral TypeInt64 = SingleDict + integral TypeWord = SingleDict + integral TypeWord8 = SingleDict + integral TypeWord16 = SingleDict + integral TypeWord32 = SingleDict + integral TypeWord64 = SingleDict + + floating :: FloatingType a -> SingleDict a + floating TypeHalf = SingleDict + floating TypeFloat = SingleDict + floating TypeDouble = SingleDict + + scalarTypeBool :: ScalarType Bool scalarTypeBool = SingleScalarType $ NonNumSingleType TypeBool @@ -321,59 +312,124 @@ scalarTypeWord8 = SingleScalarType $ NumSingleType $ IntegralNumType TypeWord8 scalarTypeWord32 :: ScalarType Word32 scalarTypeWord32 = SingleScalarType $ NumSingleType $ IntegralNumType TypeWord32 --- Tuple representation --- ------------------- --- --- Both arrays (Acc) and expressions (Exp) may form tuples. These are represented --- using as product types, consisting of: --- --- * unit (void) --- --- * single array / scalar types --- in case of expressions: 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 TupR s a where - TupRunit :: TupR s () - TupRsingle :: s a -> TupR s a - TupRpair :: TupR s a -> TupR s b -> TupR s (a, b) - -type TupleType = TupR ScalarType -- TODO: Rename to EltR - -instance Show (TupR ScalarType a) where - show TupRunit = "()" - show (TupRsingle t) = show t - show (TupRpair a b) = "(" ++ show a ++ "," ++ show b ++")" - -type Tup2 a b = (((), a), b) -type Tup3 a b c = ((((), a), b), c) -type Tup4 a b c d = (((((), a), b), c), d) -type Tup5 a b c d e = ((((((), a), b), c), d), e) -type Tup6 a b c d e f = (((((((), a), b), c), d), e), f) -type Tup7 a b c d e f g = ((((((((), a), b), c), d), e), f), g) -type Tup8 a b c d e f g h = (((((((((), a), b), c), d), e), f), g), h) -type Tup9 a b c d e f g h i = ((((((((((), a), b), c), d), e), f), g), h), i) -type Tup16 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) - -tupR2 :: TupR s t1 -> TupR s t2 -> TupR s (Tup2 t1 t2) -tupR2 t1 t2 = TupRunit `TupRpair` t1 `TupRpair` t2 - -tupR3 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s (Tup3 t1 t2 t3) -tupR3 t1 t2 t3 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 - -tupR5 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s t4 -> TupR s t5 -> TupR s (Tup5 t1 t2 t3 t4 t5) -tupR5 t1 t2 t3 t4 t5 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 `TupRpair` t4 `TupRpair` t5 - -tupR7 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s t4 -> TupR s t5 -> TupR s t6 -> TupR s t7 -> TupR s (Tup7 t1 t2 t3 t4 t5 t6 t7) -tupR7 t1 t2 t3 t4 t5 t6 t7 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 `TupRpair` t4 `TupRpair` t5 `TupRpair` t6 `TupRpair` t7 +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 (VectorType !_ 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 = () +rnfNonNumType TypeChar = () + +rnfIntegralType :: IntegralType t -> () +rnfIntegralType TypeInt = () +rnfIntegralType TypeInt8 = () +rnfIntegralType TypeInt16 = () +rnfIntegralType TypeInt32 = () +rnfIntegralType TypeInt64 = () +rnfIntegralType TypeWord = () +rnfIntegralType TypeWord8 = () +rnfIntegralType TypeWord16 = () +rnfIntegralType TypeWord32 = () +rnfIntegralType TypeWord64 = () + +rnfFloatingType :: FloatingType t -> () +rnfFloatingType TypeHalf = () +rnfFloatingType TypeFloat = () +rnfFloatingType TypeDouble = () + + +liftScalar :: ScalarType t -> t -> Q (TExp t) +liftScalar (SingleScalarType t) = liftSingle t +liftScalar (VectorScalarType t) = liftVector t + +liftSingle :: SingleType t -> t -> Q (TExp t) +liftSingle (NumSingleType t) = liftNum t +liftSingle (NonNumSingleType t) = liftNonNum t + +liftVector :: VectorType t -> t -> Q (TExp t) +liftVector VectorType{} = liftVec + +liftNum :: NumType t -> t -> Q (TExp t) +liftNum (IntegralNumType t) = liftIntegral t +liftNum (FloatingNumType t) = liftFloating t + +liftNonNum :: NonNumType t -> t -> Q (TExp t) +liftNonNum TypeBool{} x = [|| x ||] +liftNonNum TypeChar{} x = [|| 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 ||] +liftIntegral TypeWord{} x = [|| x ||] +liftIntegral TypeWord8{} x = [|| x ||] +liftIntegral TypeWord16{} x = [|| x ||] +liftIntegral TypeWord32{} x = [|| x ||] +liftIntegral TypeWord64{} x = [|| x ||] + +liftFloating :: FloatingType t -> t -> Q (TExp t) +liftFloating TypeHalf{} x = [|| x ||] +liftFloating TypeFloat{} x = [|| x ||] +liftFloating TypeDouble{} x = [|| x ||] + + +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 (VectorType n t) = [|| VectorType n $$(liftSingleType t) ||] + +liftNumType :: NumType t -> Q (TExp (NumType t)) +liftNumType (IntegralNumType t) = [|| IntegralNumType $$(liftIntegralType t) ||] +liftNumType (FloatingNumType t) = [|| FloatingNumType $$(liftFloatingType t) ||] + +liftNonNumType :: NonNumType t -> Q (TExp (NonNumType t)) +liftNonNumType TypeBool{} = [|| TypeBool ||] +liftNonNumType TypeChar{} = [|| TypeChar ||] + +liftBoundedType :: BoundedType t -> Q (TExp (BoundedType t)) +liftBoundedType (IntegralBoundedType t) = [|| IntegralBoundedType $$(liftIntegralType t) ||] +liftBoundedType (NonNumBoundedType t) = [|| NonNumBoundedType $$(liftNonNumType t) ||] + +liftIntegralType :: IntegralType t -> Q (TExp (IntegralType t)) +liftIntegralType TypeInt{} = [|| TypeInt ||] +liftIntegralType TypeInt8{} = [|| TypeInt8 ||] +liftIntegralType TypeInt16{} = [|| TypeInt16 ||] +liftIntegralType TypeInt32{} = [|| TypeInt32 ||] +liftIntegralType TypeInt64{} = [|| TypeInt64 ||] +liftIntegralType TypeWord{} = [|| TypeWord ||] +liftIntegralType TypeWord8{} = [|| TypeWord8 ||] +liftIntegralType TypeWord16{} = [|| TypeWord16 ||] +liftIntegralType TypeWord32{} = [|| TypeWord32 ||] +liftIntegralType TypeWord64{} = [|| TypeWord64 ||] + +liftFloatingType :: FloatingType t -> Q (TExp (FloatingType t)) +liftFloatingType TypeHalf{} = [|| TypeHalf ||] +liftFloatingType TypeFloat{} = [|| TypeFloat ||] +liftFloatingType TypeDouble{} = [|| TypeDouble ||] -tupR9 :: TupR s t1 -> TupR s t2 -> TupR s t3 -> TupR s t4 -> TupR s t5 -> TupR s t6 -> TupR s t7 -> TupR s t8 -> TupR s t9 -> TupR s (Tup9 t1 t2 t3 t4 t5 t6 t7 t8 t9) -tupR9 t1 t2 t3 t4 t5 t6 t7 t8 t9 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpair` t3 `TupRpair` t4 `TupRpair` t5 `TupRpair` t6 `TupRpair` t7 `TupRpair` t8 `TupRpair` t9 -- Type-level bit sizes -- -------------------- @@ -381,247 +437,9 @@ tupR9 t1 t2 t3 t4 t5 t6 t7 t8 t9 = TupRunit `TupRpair` t1 `TupRpair` t2 `TupRpai -- | 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 --- ----------------- - --- Note: [Representing SIMD vector types] --- --- A simple polymorphic representation of SIMD types such as the following: --- --- > data Vec2 a = Vec2 !a !a --- --- is not able to unpack the values into the constructor, meaning that --- 'Vec2' is storing pointers to (strict) values on the heap, which is --- a very inefficient representation. --- --- We might try defining a data family instead so that we can get efficient --- unboxed representations, and even make use of the unlifted SIMD types GHC --- knows about: --- --- > data family Vec2 a :: * --- > data instance Vec2 Float = Vec2_Float Float# Float# -- reasonable --- > data instance Vec2 Double = Vec2_Double DoubleX2# -- built in! --- --- However, this runs into the problem that GHC stores all values as word sized --- entities: --- --- > data instance Vec2 Int = Vec2_Int Int# Int# --- > data instance Vec2 Int8 = Vec2_Int8 Int8# Int8# -- Int8# does not exist; requires a full Int# --- --- which, again, is very memory inefficient. --- --- So, as a last resort, we'll just use a ByteArray# to ensure an efficient --- packed representation. --- --- One inefficiency of this approach is that the byte array does track its size, --- which redundant for our use case (derivable from type level information). --- -data Vec (n::Nat) a = Vec ByteArray# - -type role Vec nominal representational - -instance (Show a, Prim a, KnownNat n) => Show (Vec n a) where - show = vec . vecToArray - where - vec :: [a] -> String - vec = show - . group . encloseSep (flatAlt "< " "<") (flatAlt " >" ">") ", " - . map viaShow - -vecToArray :: forall a n. (Prim a, KnownNat n) => Vec n a -> [a] -vecToArray (Vec ba#) = go 0# - where - go :: Int# -> [a] - go i# | isTrue# (i# <# n#) = indexByteArray# ba# i# : go (i# +# 1#) - | otherwise = [] - - !(I# n#) = fromIntegral (natVal' (proxy# :: Proxy# n)) - -instance Eq (Vec n a) where - Vec ba1# == Vec ba2# = ByteArray ba1# == ByteArray ba2# - -data PrimDict a where - PrimDict :: Prim a => PrimDict a - -getPrim :: SingleType a -> PrimDict a -getPrim (NumSingleType (IntegralNumType tp)) = case tp of - TypeInt -> PrimDict - TypeInt8 -> PrimDict - TypeInt16 -> PrimDict - TypeInt32 -> PrimDict - TypeInt64 -> PrimDict - TypeWord -> PrimDict - TypeWord8 -> PrimDict - TypeWord16 -> PrimDict - TypeWord32 -> PrimDict - TypeWord64 -> PrimDict -getPrim (NumSingleType (FloatingNumType tp)) = case tp of - TypeHalf -> PrimDict - TypeFloat -> PrimDict - TypeDouble -> PrimDict -getPrim (NonNumSingleType TypeChar) = PrimDict -getPrim (NonNumSingleType TypeBool) = error "prim: We don't support vector of bools yet" - - --- Type synonyms for common SIMD vector types --- --- Note that non-power-of-two sized SIMD vectors are a bit dubious, and --- special care must be taken in the code generator. For example, LLVM will --- treat a Vec3 with alignment of _4_, meaning that reads and writes will --- be (without further action) incorrect. --- -type Vec2 a = Vec 2 a -type Vec3 a = Vec 3 a -type Vec4 a = Vec 4 a -type Vec8 a = Vec 8 a -type Vec16 a = Vec 16 a - -pattern Vec2 :: Prim a => a -> a -> Vec2 a -pattern Vec2 a b <- (unpackVec2 -> (a,b)) - where Vec2 = packVec2 -{-# COMPLETE Vec2 #-} - -pattern Vec3 :: Prim a => a -> a -> a -> Vec3 a -pattern Vec3 a b c <- (unpackVec3 -> (a,b,c)) - where Vec3 = packVec3 -{-# COMPLETE Vec3 #-} - -pattern Vec4 :: Prim a => a -> a -> a -> a -> Vec4 a -pattern Vec4 a b c d <- (unpackVec4 -> (a,b,c,d)) - where Vec4 = packVec4 -{-# COMPLETE Vec4 #-} - -pattern Vec8 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> Vec8 a -pattern Vec8 a b c d e f g h <- (unpackVec8 -> (a,b,c,d,e,f,g,h)) - where Vec8 = packVec8 -{-# COMPLETE Vec8 #-} - -pattern Vec16 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> Vec16 a -pattern Vec16 a b c d e f g h i j k l m n o p <- (unpackVec16 -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) - where Vec16 = packVec16 -{-# COMPLETE Vec16 #-} - -unpackVec2 :: Prim a => Vec2 a -> (a,a) -unpackVec2 (Vec ba#) = - ( indexByteArray# ba# 0# - , indexByteArray# ba# 1# - ) - -unpackVec3 :: Prim a => Vec3 a -> (a,a,a) -unpackVec3 (Vec ba#) = - ( indexByteArray# ba# 0# - , indexByteArray# ba# 1# - , indexByteArray# ba# 2# - ) - -unpackVec4 :: Prim a => Vec4 a -> (a,a,a,a) -unpackVec4 (Vec ba#) = - ( indexByteArray# ba# 0# - , indexByteArray# ba# 1# - , indexByteArray# ba# 2# - , indexByteArray# ba# 3# - ) - -unpackVec8 :: Prim a => Vec8 a -> (a,a,a,a,a,a,a,a) -unpackVec8 (Vec ba#) = - ( indexByteArray# ba# 0# - , indexByteArray# ba# 1# - , indexByteArray# ba# 2# - , indexByteArray# ba# 3# - , indexByteArray# ba# 4# - , indexByteArray# ba# 5# - , indexByteArray# ba# 6# - , indexByteArray# ba# 7# - ) - -unpackVec16 :: Prim a => Vec16 a -> (a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a) -unpackVec16 (Vec ba#) = - ( indexByteArray# ba# 0# - , indexByteArray# ba# 1# - , indexByteArray# ba# 2# - , indexByteArray# ba# 3# - , indexByteArray# ba# 4# - , indexByteArray# ba# 5# - , indexByteArray# ba# 6# - , indexByteArray# ba# 7# - , indexByteArray# ba# 8# - , indexByteArray# ba# 9# - , indexByteArray# ba# 10# - , indexByteArray# ba# 11# - , indexByteArray# ba# 12# - , indexByteArray# ba# 13# - , indexByteArray# ba# 14# - , indexByteArray# ba# 15# - ) - -packVec2 :: Prim a => a -> a -> Vec2 a -packVec2 a b = runST $ do - mba <- newByteArray (2 * sizeOf a) - writeByteArray mba 0 a - writeByteArray mba 1 b - ByteArray ba# <- unsafeFreezeByteArray mba - return $! Vec ba# - -packVec3 :: Prim a => a -> a -> a -> Vec3 a -packVec3 a b c = runST $ do - mba <- newByteArray (3 * sizeOf a) - writeByteArray mba 0 a - writeByteArray mba 1 b - writeByteArray mba 2 c - ByteArray ba# <- unsafeFreezeByteArray mba - return $! Vec ba# - -packVec4 :: Prim a => a -> a -> a -> a -> Vec4 a -packVec4 a b c d = runST $ do - mba <- newByteArray (4 * sizeOf a) - writeByteArray mba 0 a - writeByteArray mba 1 b - writeByteArray mba 2 c - writeByteArray mba 3 d - ByteArray ba# <- unsafeFreezeByteArray mba - return $! Vec ba# - -packVec8 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> Vec8 a -packVec8 a b c d e f g h = runST $ do - mba <- newByteArray (8 * sizeOf a) - writeByteArray mba 0 a - writeByteArray mba 1 b - writeByteArray mba 2 c - writeByteArray mba 3 d - writeByteArray mba 4 e - writeByteArray mba 5 f - writeByteArray mba 6 g - writeByteArray mba 7 h - ByteArray ba# <- unsafeFreezeByteArray mba - return $! Vec ba# - -packVec16 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> Vec16 a -packVec16 a b c d e f g h i j k l m n o p = runST $ do - mba <- newByteArray (16 * sizeOf a) - writeByteArray mba 0 a - writeByteArray mba 1 b - writeByteArray mba 2 c - writeByteArray mba 3 d - writeByteArray mba 4 e - writeByteArray mba 5 f - writeByteArray mba 6 g - writeByteArray mba 7 h - writeByteArray mba 8 i - writeByteArray mba 9 j - writeByteArray mba 10 k - writeByteArray mba 11 l - writeByteArray mba 12 m - writeByteArray mba 13 n - writeByteArray mba 14 o - writeByteArray mba 15 p - ByteArray ba# <- unsafeFreezeByteArray mba - return $! Vec ba# - - -- Instances -- --------- -- diff --git a/src/Data/Array/Accelerate/Unsafe.hs b/src/Data/Array/Accelerate/Unsafe.hs index ac4262de5..dcb8e95c7 100644 --- a/src/Data/Array/Accelerate/Unsafe.hs +++ b/src/Data/Array/Accelerate/Unsafe.hs @@ -22,8 +22,8 @@ module Data.Array.Accelerate.Unsafe ( ) where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt -- | The function 'coerce' allows you to convert a value between any two types @@ -36,7 +36,7 @@ import Data.Array.Accelerate.Smart -- -- Furthermore, as we typically declare newtype wrappers similarly to: -- --- > type instance EltRepr (Sum a) = ((), EltRepr a) +-- > type instance EltR (Sum a) = ((), EltR 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 @@ -47,6 +47,6 @@ import Data.Array.Accelerate.Smart -- -- @since 1.2.0.0 -- -coerce :: Coerce (EltRepr a) (EltRepr b) => Exp a -> Exp b +coerce :: Coerce (EltR a) (EltR b) => Exp a -> Exp b coerce = mkCoerce diff --git a/src/Data/Primitive/Vec.hs b/src/Data/Primitive/Vec.hs new file mode 100644 index 000000000..8ae7ff2d3 --- /dev/null +++ b/src/Data/Primitive/Vec.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Primitive.Vec +-- Copyright : [2008..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Primitive.Vec ( + + -- * SIMD vector types + Vec(..), + Vec2, pattern Vec2, + Vec3, pattern Vec3, + Vec4, pattern Vec4, + Vec8, pattern Vec8, + Vec16, pattern Vec16, + + listOfVec, + liftVec, + +) where + +import Control.Monad.ST +import Data.Primitive.ByteArray +import Data.Primitive.Types +import Data.Text.Prettyprint.Doc +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import GHC.Base ( isTrue# ) +import GHC.Int +import GHC.Prim +import GHC.TypeLits +import GHC.Word + + +-- Note: [Representing SIMD vector types] +-- +-- A simple polymorphic representation of SIMD types such as the following: +-- +-- > data Vec2 a = Vec2 !a !a +-- +-- is not able to unpack the values into the constructor, meaning that +-- 'Vec2' is storing pointers to (strict) values on the heap, which is +-- a very inefficient representation. +-- +-- We might try defining a data family instead so that we can get efficient +-- unboxed representations, and even make use of the unlifted SIMD types GHC +-- knows about: +-- +-- > data family Vec2 a :: * +-- > data instance Vec2 Float = Vec2_Float Float# Float# -- reasonable +-- > data instance Vec2 Double = Vec2_Double DoubleX2# -- built in! +-- +-- However, this runs into the problem that GHC stores all values as word sized +-- entities: +-- +-- > data instance Vec2 Int = Vec2_Int Int# Int# +-- > data instance Vec2 Int8 = Vec2_Int8 Int8# Int8# -- Int8# does not exist; requires a full Int# +-- +-- which, again, is very memory inefficient. +-- +-- So, as a last resort, we'll just use a ByteArray# to ensure an efficient +-- packed representation. +-- +-- One inefficiency of this approach is that the byte array does track its size, +-- which redundant for our use case (derivable from type level information). +-- +data Vec (n :: Nat) a = Vec ByteArray# + +type role Vec nominal representational + +instance (Show a, Prim a, KnownNat n) => Show (Vec n a) where + show = vec . listOfVec + where + vec :: [a] -> String + vec = show + . group . encloseSep (flatAlt "< " "<") (flatAlt " >" ">") ", " + . map viaShow + +listOfVec :: forall a n. (Prim a, KnownNat n) => Vec n a -> [a] +listOfVec (Vec ba#) = go 0# + where + go :: Int# -> [a] + go i# | isTrue# (i# <# n#) = indexByteArray# ba# i# : go (i# +# 1#) + | otherwise = [] + + !(I# n#) = fromIntegral (natVal' (proxy# :: Proxy# n)) + +instance Eq (Vec n a) where + Vec ba1# == Vec ba2# = ByteArray ba1# == ByteArray ba2# + +-- Type synonyms for common SIMD vector types +-- +-- Note that non-power-of-two sized SIMD vectors are a bit dubious, and +-- special care must be taken in the code generator. For example, LLVM will +-- treat a Vec3 with alignment of _4_, meaning that reads and writes will +-- be (without further action) incorrect. +-- +type Vec2 a = Vec 2 a +type Vec3 a = Vec 3 a +type Vec4 a = Vec 4 a +type Vec8 a = Vec 8 a +type Vec16 a = Vec 16 a + +pattern Vec2 :: Prim a => a -> a -> Vec2 a +pattern Vec2 a b <- (unpackVec2 -> (a,b)) + where Vec2 = packVec2 +{-# COMPLETE Vec2 #-} + +pattern Vec3 :: Prim a => a -> a -> a -> Vec3 a +pattern Vec3 a b c <- (unpackVec3 -> (a,b,c)) + where Vec3 = packVec3 +{-# COMPLETE Vec3 #-} + +pattern Vec4 :: Prim a => a -> a -> a -> a -> Vec4 a +pattern Vec4 a b c d <- (unpackVec4 -> (a,b,c,d)) + where Vec4 = packVec4 +{-# COMPLETE Vec4 #-} + +pattern Vec8 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> Vec8 a +pattern Vec8 a b c d e f g h <- (unpackVec8 -> (a,b,c,d,e,f,g,h)) + where Vec8 = packVec8 +{-# COMPLETE Vec8 #-} + +pattern Vec16 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> Vec16 a +pattern Vec16 a b c d e f g h i j k l m n o p <- (unpackVec16 -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) + where Vec16 = packVec16 +{-# COMPLETE Vec16 #-} + +unpackVec2 :: Prim a => Vec2 a -> (a,a) +unpackVec2 (Vec ba#) = + ( indexByteArray# ba# 0# + , indexByteArray# ba# 1# + ) + +unpackVec3 :: Prim a => Vec3 a -> (a,a,a) +unpackVec3 (Vec ba#) = + ( indexByteArray# ba# 0# + , indexByteArray# ba# 1# + , indexByteArray# ba# 2# + ) + +unpackVec4 :: Prim a => Vec4 a -> (a,a,a,a) +unpackVec4 (Vec ba#) = + ( indexByteArray# ba# 0# + , indexByteArray# ba# 1# + , indexByteArray# ba# 2# + , indexByteArray# ba# 3# + ) + +unpackVec8 :: Prim a => Vec8 a -> (a,a,a,a,a,a,a,a) +unpackVec8 (Vec ba#) = + ( indexByteArray# ba# 0# + , indexByteArray# ba# 1# + , indexByteArray# ba# 2# + , indexByteArray# ba# 3# + , indexByteArray# ba# 4# + , indexByteArray# ba# 5# + , indexByteArray# ba# 6# + , indexByteArray# ba# 7# + ) + +unpackVec16 :: Prim a => Vec16 a -> (a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a) +unpackVec16 (Vec ba#) = + ( indexByteArray# ba# 0# + , indexByteArray# ba# 1# + , indexByteArray# ba# 2# + , indexByteArray# ba# 3# + , indexByteArray# ba# 4# + , indexByteArray# ba# 5# + , indexByteArray# ba# 6# + , indexByteArray# ba# 7# + , indexByteArray# ba# 8# + , indexByteArray# ba# 9# + , indexByteArray# ba# 10# + , indexByteArray# ba# 11# + , indexByteArray# ba# 12# + , indexByteArray# ba# 13# + , indexByteArray# ba# 14# + , indexByteArray# ba# 15# + ) + +packVec2 :: Prim a => a -> a -> Vec2 a +packVec2 a b = runST $ do + mba <- newByteArray (2 * sizeOf a) + writeByteArray mba 0 a + writeByteArray mba 1 b + ByteArray ba# <- unsafeFreezeByteArray mba + return $! Vec ba# + +packVec3 :: Prim a => a -> a -> a -> Vec3 a +packVec3 a b c = runST $ do + mba <- newByteArray (3 * sizeOf a) + writeByteArray mba 0 a + writeByteArray mba 1 b + writeByteArray mba 2 c + ByteArray ba# <- unsafeFreezeByteArray mba + return $! Vec ba# + +packVec4 :: Prim a => a -> a -> a -> a -> Vec4 a +packVec4 a b c d = runST $ do + mba <- newByteArray (4 * sizeOf a) + writeByteArray mba 0 a + writeByteArray mba 1 b + writeByteArray mba 2 c + writeByteArray mba 3 d + ByteArray ba# <- unsafeFreezeByteArray mba + return $! Vec ba# + +packVec8 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> Vec8 a +packVec8 a b c d e f g h = runST $ do + mba <- newByteArray (8 * sizeOf a) + writeByteArray mba 0 a + writeByteArray mba 1 b + writeByteArray mba 2 c + writeByteArray mba 3 d + writeByteArray mba 4 e + writeByteArray mba 5 f + writeByteArray mba 6 g + writeByteArray mba 7 h + ByteArray ba# <- unsafeFreezeByteArray mba + return $! Vec ba# + +packVec16 :: Prim a => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> Vec16 a +packVec16 a b c d e f g h i j k l m n o p = runST $ do + mba <- newByteArray (16 * sizeOf a) + writeByteArray mba 0 a + writeByteArray mba 1 b + writeByteArray mba 2 c + writeByteArray mba 3 d + writeByteArray mba 4 e + writeByteArray mba 5 f + writeByteArray mba 6 g + writeByteArray mba 7 h + writeByteArray mba 8 i + writeByteArray mba 9 j + writeByteArray mba 10 k + writeByteArray mba 11 l + writeByteArray mba 12 m + writeByteArray mba 13 n + writeByteArray mba 14 o + writeByteArray mba 15 p + ByteArray ba# <- unsafeFreezeByteArray mba + return $! Vec ba# + +-- O(n) at runtime to copy from the Addr# to the ByteArray#. We should be able +-- to do this without copying, but I don't think the definition of ByteArray# is +-- exported (or it is deeply magical). +-- +liftVec :: Vec n a -> Q (TExp (Vec n a)) +liftVec (Vec ba#) + = unsafeTExpCoerce + [| runST $ \s -> + case newByteArray# $(liftInt# n#) s of { (# s1, mba# #) -> + case copyAddrToByteArray# $(litE (StringPrimL bytes)) mba# 0# $(liftInt# n#) s1 of { s2 -> + case unsafeFreezeByteArray# mba# s2 of { (# s3, ba'# #) -> + (# s3, Vec ba'# #) + }}} + |] + where + bytes :: [Word8] + bytes = go 0# + where + go i# | isTrue# (i# <# n#) = W8# (indexWord8Array# ba# i#) : go (i# +# 1#) + | otherwise = [] + + n# = sizeofByteArray# ba# + + -- XXX: Typed TH does not support unlifted types + -- + liftInt# :: Int# -> ExpQ + liftInt# i# = litE (IntPrimL (toInteger (I# i#))) + From 6c99aedc34e492597e858bd47852b107229db1d9 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 17 Jun 2020 10:41:35 +0200 Subject: [PATCH 245/316] stack/8.8: update lts --- stack-8.8.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-8.8.yaml b/stack-8.8.yaml index 529de0274..270bbce1c 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-15.15 +resolver: lts-16.1 packages: - . From acfd0412ea274483a52ea06c49d376d27021ff89 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 17 Jun 2020 10:52:23 +0200 Subject: [PATCH 246/316] icebox: old sequences tests --- icebox/Sequences.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/icebox/Sequences.hs b/icebox/Sequences.hs index f37edd6db..896b0c4f2 100644 --- a/icebox/Sequences.hs +++ b/icebox/Sequences.hs @@ -359,3 +359,23 @@ test_sequences' backend opt = testChunking2b = testProperty "chunking2b" (\ input -> (run backend (chunking2b input) ~?= chunking2Ref input)) + +foldE :: Elt e + => (Exp e -> Exp e -> Exp e) + -> Exp e + -> Seq [Scalar e] + -> Seq (Scalar e) +foldE f z = + S.fold + (\a s -> lift (a, elements s)) + (\(T2 a as) -> A.fold f (the a) as) + (unit z) + +sumMax + :: (Num a, Ord a, Bounded a) + => Acc (Vector a) + -> Acc (Scalar a, Scalar a) +sumMax (sliceInner -> xs) + = collect + $ lift ( foldE (+) 0 xs, foldE max minBound xs ) + From 632b3fe460bb59fefe6eb20df713d91798b6b494 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 17 Jun 2020 10:52:52 +0200 Subject: [PATCH 247/316] update .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 6ddeedcf3..c290d83ac 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ /stack.yaml /stack.yaml.lock .DS_Store +*.lock From 6be1dfbfe09b84be6c9b0b27554925cebda768b5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 19 Jun 2020 15:52:03 +0200 Subject: [PATCH 248/316] add generic elt instances for sum types * add tagsR field to Elt, to be used for pattern matching * Bool is no longer a primitive type --- accelerate.cabal | 1 + src/Data/Array/Accelerate.hs | 2 +- src/Data/Array/Accelerate/AST.hs | 54 +++--- src/Data/Array/Accelerate/Analysis/Hash.hs | 9 +- src/Data/Array/Accelerate/Analysis/Match.hs | 32 ++- src/Data/Array/Accelerate/Analysis/Type.hs | 1 - src/Data/Array/Accelerate/Array/Data.hs | 6 +- src/Data/Array/Accelerate/Classes/Bounded.hs | 6 +- src/Data/Array/Accelerate/Classes/Eq.hs | 39 ++-- src/Data/Array/Accelerate/Classes/Ord.hs | 40 ++-- .../Accelerate/Classes/RealFloat.hs-boot | 1 + src/Data/Array/Accelerate/Data/Bits.hs | 2 +- src/Data/Array/Accelerate/Data/Complex.hs | 23 ++- src/Data/Array/Accelerate/Data/Either.hs | 18 +- src/Data/Array/Accelerate/Data/Maybe.hs | 25 +-- src/Data/Array/Accelerate/Interpreter.hs | 157 ++++++--------- src/Data/Array/Accelerate/Language.hs | 18 +- src/Data/Array/Accelerate/Lift.hs | 3 +- src/Data/Array/Accelerate/Pretty/Print.hs | 1 - .../Array/Accelerate/Representation/Elt.hs | 123 ++++++++++-- .../Array/Accelerate/Representation/Tag.hs | 68 +++++++ .../Array/Accelerate/Representation/Type.hs | 1 - src/Data/Array/Accelerate/Smart.hs | 66 ++++--- src/Data/Array/Accelerate/Sugar/Array.hs | 3 + src/Data/Array/Accelerate/Sugar/Elt.hs | 183 +++++++++++++++--- src/Data/Array/Accelerate/Sugar/Shape.hs | 3 + src/Data/Array/Accelerate/Sugar/Vec.hs | 2 + src/Data/Array/Accelerate/Trafo/Algebra.hs | 122 +++++++----- src/Data/Array/Accelerate/Trafo/Fusion.hs | 6 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 7 +- src/Data/Array/Accelerate/Type.hs | 36 ++-- 31 files changed, 673 insertions(+), 385 deletions(-) create mode 100644 src/Data/Array/Accelerate/Representation/Tag.hs diff --git a/accelerate.cabal b/accelerate.cabal index 388ebad78..fb6fdeaef 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -340,6 +340,7 @@ Library Data.Array.Accelerate.Representation.Shape Data.Array.Accelerate.Representation.Slice Data.Array.Accelerate.Representation.Stencil + Data.Array.Accelerate.Representation.Tag Data.Array.Accelerate.Representation.Type Data.Array.Accelerate.Representation.Vec Data.Array.Accelerate.Smart diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 3cb76ce0b..0ddc996e3 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -435,7 +435,7 @@ import Data.Primitive.Vec import qualified Data.Array.Accelerate.Sugar.Array as S import qualified Data.Array.Accelerate.Sugar.Shape as S -import Prelude ( (.), ($), Show, undefined, error, const, otherwise ) +import Prelude ( (.), ($), Char, Show, undefined, error, const, otherwise ) import GHC.Generics ( Generic ) -- $setup diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index f8c668b4c..ef6e4b9a3 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -87,6 +87,7 @@ module Data.Array.Accelerate.AST ( Boundary(..), PrimConst(..), PrimFun(..), + PrimBool, -- ** Extracting type information HasArraysR(..), arrayR, @@ -137,6 +138,7 @@ import Data.Array.Accelerate.Representation.Elt import Data.Array.Accelerate.Representation.Shape import Data.Array.Accelerate.Representation.Slice import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Representation.Vec import Data.Array.Accelerate.Sugar.Foreign @@ -146,6 +148,7 @@ import Data.Primitive.Vec import Control.DeepSeq import Data.Kind import Language.Haskell.TH ( Q, TExp ) +import Prelude import GHC.TypeLits @@ -185,6 +188,9 @@ type ALeftHandSide = LeftHandSide ArrayR type ArrayVar = Var ArrayR type ArrayVars aenv = Vars ArrayR aenv +-- Bool is not a primitive type +type PrimBool = TAG + -- | Collective array computations parametrised over array variables -- represented with de Bruijn indices. @@ -251,14 +257,14 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- If-then-else for array-level computations -- - Acond :: Exp aenv Bool + Acond :: Exp aenv PrimBool -> acc aenv arrs -> acc aenv arrs -> PreOpenAcc acc aenv arrs -- Value-recursion for array-level computations -- - Awhile :: PreOpenAfun acc aenv (arrs -> Scalar Bool) -- continue iteration while true + Awhile :: PreOpenAfun acc aenv (arrs -> Scalar PrimBool) -- continue iteration while true -> PreOpenAfun acc aenv (arrs -> arrs) -- function to iterate -> acc aenv arrs -- initial value -> PreOpenAcc acc aenv arrs @@ -556,15 +562,15 @@ data OpenExp env aenv t where -> OpenExp env aenv sh -- Conditional expression (non-strict in 2nd and 3rd argument) - Cond :: OpenExp env aenv Bool + Cond :: OpenExp env aenv PrimBool -> OpenExp env aenv t -> OpenExp env aenv t -> OpenExp env aenv t -- Value recursion - While :: OpenFun env aenv (a -> Bool) -- continue while true - -> OpenFun env aenv (a -> a) -- function to iterate - -> OpenExp env aenv a -- initial value + While :: OpenFun env aenv (a -> PrimBool) -- continue while true + -> OpenFun env aenv (a -> a) -- function to iterate + -> OpenExp env aenv a -- initial value -> OpenExp env aenv a -- Constant values @@ -689,18 +695,18 @@ data PrimFun sig where -- operators from RealFloat PrimAtan2 :: FloatingType a -> PrimFun ((a, a) -> a) - PrimIsNaN :: FloatingType a -> PrimFun (a -> Bool) - PrimIsInfinite :: FloatingType a -> PrimFun (a -> Bool) + PrimIsNaN :: FloatingType a -> PrimFun (a -> PrimBool) + PrimIsInfinite :: FloatingType a -> PrimFun (a -> PrimBool) -- 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 ) + PrimLt :: SingleType a -> PrimFun ((a, a) -> PrimBool) + PrimGt :: SingleType a -> PrimFun ((a, a) -> PrimBool) + PrimLtEq :: SingleType a -> PrimFun ((a, a) -> PrimBool) + PrimGtEq :: SingleType a -> PrimFun ((a, a) -> PrimBool) + PrimEq :: SingleType a -> PrimFun ((a, a) -> PrimBool) + PrimNEq :: SingleType a -> PrimFun ((a, a) -> PrimBool) + PrimMax :: SingleType a -> PrimFun ((a, a) -> a) + PrimMin :: SingleType a -> PrimFun ((a, a) -> a) -- logical operators -- @@ -712,17 +718,14 @@ data PrimFun sig where -- short-circuiting, while (&&!) and (||!) are strict versions of these -- operators, which are defined using PrimLAnd and PrimLOr. -- - PrimLAnd :: PrimFun ((Bool, Bool) -> Bool) - PrimLOr :: PrimFun ((Bool, Bool) -> Bool) - PrimLNot :: PrimFun (Bool -> Bool) + PrimLAnd :: PrimFun ((PrimBool, PrimBool) -> PrimBool) + PrimLOr :: PrimFun ((PrimBool, PrimBool) -> PrimBool) + PrimLNot :: PrimFun (PrimBool -> PrimBool) -- 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) @@ -900,9 +903,6 @@ primFunType = \case PrimOrd -> unary char int PrimChr -> unary int char - -- boolean conversion - PrimBoolToInt -> unary bool int - -- general conversion between types PrimFromIntegral a b -> unary (integral a) (num b) PrimToFloating a b -> unary (num a) (floating b) @@ -919,7 +919,7 @@ primFunType = \case integral = num . IntegralNumType floating = num . FloatingNumType - bool = TupRsingle scalarTypeBool + bool = TupRsingle scalarTypeWord8 int = TupRsingle scalarTypeInt char = TupRsingle $ SingleScalarType $ NonNumSingleType TypeChar @@ -1136,7 +1136,6 @@ 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 @@ -1349,7 +1348,6 @@ 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) ||] diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 98df19d2f..3f79ec1b2 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -367,12 +367,7 @@ encodeVectorConst :: VectorType (Vec n t) -> Vec n t -> Builder encodeVectorConst (VectorType n t) (Vec ba#) = intHost $(hashQ "Vec") <> intHost n <> encodeSingleType t <> shortByteString (SBS ba#) encodeNonNumConst :: NonNumType t -> t -> Builder -encodeNonNumConst TypeBool{} x = intHost $(hashQ "Bool") <> word8 (fromBool x) -encodeNonNumConst TypeChar{} x = intHost $(hashQ "Char") <> charUtf8 x - -fromBool :: Bool -> Word8 -fromBool True = 1 -fromBool False = 0 +encodeNonNumConst TypeChar{} x = intHost $(hashQ "Char") <> charUtf8 x encodeNumConst :: NumType t -> t -> Builder encodeNumConst (IntegralNumType t) = encodeIntegralConst t @@ -465,7 +460,6 @@ 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") encodeTypeR :: TypeR t -> Builder @@ -495,7 +489,6 @@ encodeBoundedType (IntegralBoundedType t) = intHost $(hashQ "IntegralBoundedType encodeBoundedType (NonNumBoundedType t) = intHost $(hashQ "NonNumBoundedType") <> encodeNonNumType t encodeNonNumType :: NonNumType t -> Builder -encodeNonNumType TypeBool{} = intHost $(hashQ "Bool") encodeNonNumType TypeChar{} = intHost $(hashQ "Char") encodeNumType :: NumType t -> Builder diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index ab7ac7ced..1e8ce048e 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -700,7 +700,6 @@ 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 @@ -768,7 +767,6 @@ 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 @@ -873,30 +871,28 @@ 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 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 _ _ = 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 TypeHalf TypeHalf = Just Refl +matchFloatingType TypeFloat TypeFloat = Just Refl +matchFloatingType TypeDouble TypeDouble = 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 _ _ = Nothing +matchNonNumType TypeChar TypeChar = Just Refl -- Auxiliary diff --git a/src/Data/Array/Accelerate/Analysis/Type.hs b/src/Data/Array/Accelerate/Analysis/Type.hs index bf7435197..6528ce585 100644 --- a/src/Data/Array/Accelerate/Analysis/Type.hs +++ b/src/Data/Array/Accelerate/Analysis/Type.hs @@ -73,6 +73,5 @@ sizeOfNumType (IntegralNumType t) | IntegralDict <- integralDict t = F.sizeOf (u 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) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index edb009693..373566717 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -102,8 +102,7 @@ type family GArrayData a where type ScalarArrayData a = UniqueArray (ScalarArrayDataR a) -- | Mapping from scalar type to the type as represented in memory in an --- array. Booleans are stored as Word8, other types are represented as --- itself. +-- array. -- type family ScalarArrayDataR t where ScalarArrayDataR Int = Int @@ -119,7 +118,6 @@ type family ScalarArrayDataR t where ScalarArrayDataR Half = Half ScalarArrayDataR Float = Float ScalarArrayDataR Double = Double - -- ScalarArrayDataR Bool = Word8 ScalarArrayDataR Char = Char ScalarArrayDataR (Vec n t) = ScalarArrayDataR t @@ -150,7 +148,6 @@ scalarArrayDict = scalar nonnum :: NonNumType a -> ScalarArrayDict a nonnum TypeChar = ScalarArrayDict - nonnum TypeBool = undefined num :: NumType a -> ScalarArrayDict a num (IntegralNumType t) = integral t @@ -183,7 +180,6 @@ singleArrayDict = single nonnum :: NonNumType a -> SingleArrayDict a nonnum TypeChar = SingleArrayDict - nonnum TypeBool = undefined num :: NumType a -> SingleArrayDict a num (IntegralNumType t) = integral t diff --git a/src/Data/Array/Accelerate/Classes/Bounded.hs b/src/Data/Array/Accelerate/Classes/Bounded.hs index 12b04fdde..4d1fb7b97 100644 --- a/src/Data/Array/Accelerate/Classes/Bounded.hs +++ b/src/Data/Array/Accelerate/Classes/Bounded.hs @@ -27,7 +27,7 @@ import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Type -import Prelude ( ($), (<$>), Num(..), show, concat, map, mapM ) +import Prelude ( ($), (<$>), Num(..), Char, Bool, show, concat, map, mapM ) import Language.Haskell.TH hiding ( Exp ) import Language.Haskell.TH.Extra import qualified Prelude as P @@ -116,8 +116,8 @@ instance P.Bounded (Exp CULLong) where maxBound = mkBitcast (mkMaxBound @Word64) instance P.Bounded (Exp Bool) where - minBound = mkMinBound - maxBound = mkMaxBound + minBound = constant P.minBound + maxBound = constant P.maxBound instance P.Bounded (Exp Char) where minBound = mkMinBound diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 7577c2fe4..89d5b02d9 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -26,12 +26,15 @@ module Data.Array.Accelerate.Classes.Eq ( ) where -import Data.Array.Accelerate.Sugar.Elt -import Data.Array.Accelerate.Sugar.Shape +import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape import Data.Array.Accelerate.Type +import Data.Bool ( Bool(..) ) +import Data.Char ( Char ) import Text.Printf import Prelude ( ($), String, Num(..), show, error, return, concat, map, zipWith, foldr1, mapM ) import Language.Haskell.TH hiding ( Exp ) @@ -40,10 +43,11 @@ import qualified Prelude as P pattern True_ :: Exp Bool -pattern True_ = Exp (SmartExp (Const (SingleScalarType (NonNumSingleType TypeBool)) True)) +pattern True_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 1) `Pair` SmartExp Nil)) pattern False_ :: Exp Bool -pattern False_ = Exp (SmartExp (Const (SingleScalarType (NonNumSingleType TypeBool)) False)) +pattern False_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 0) `Pair` SmartExp Nil)) + {-# COMPLETE True_, False_ #-} @@ -55,7 +59,11 @@ infix 4 /= -- infixr 3 && (&&) :: Exp Bool -> Exp Bool -> Exp Bool -(&&) x y = cond x y $ constant False +(&&) (Exp x) (Exp y) = + mkExp $ SmartExp (Cond (SmartExp $ Prj PairIdxLeft x) + (SmartExp $ Prj PairIdxLeft y) + (SmartExp $ Const scalarTypeWord8 0)) + `Pair` SmartExp Nil -- | Conjunction: True if both arguments are true. This is a strict version of -- '(&&)': it will always evaluate both arguments, even when the first is false. @@ -70,7 +78,12 @@ infixr 3 &&! -- infixr 2 || (||) :: Exp Bool -> Exp Bool -> Exp Bool -(||) x y = cond x (constant True) y +(||) (Exp x) (Exp y) = + mkExp $ SmartExp (Cond (SmartExp $ Prj PairIdxLeft x) + (SmartExp $ Const scalarTypeWord8 1) + (SmartExp $ Prj PairIdxLeft y)) + `Pair` SmartExp Nil + -- | Disjunction: True if either argument is true. This is a strict version of -- '(||)': it will always evaluate both arguments, even when the first is true. @@ -110,6 +123,10 @@ instance Eq sh => Eq (sh :. Int) where x == y = indexHead x == indexHead y && indexTail x == indexTail y x /= y = indexHead x /= indexHead y || indexTail x /= indexTail y +instance Eq Bool where + x == y = mkCoerce x == (mkCoerce y :: Exp PrimBool) + x /= y = mkCoerce x /= (mkCoerce y :: Exp PrimBool) + -- 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. @@ -121,13 +138,6 @@ instance P.Eq (Exp a) where preludeError :: String -> String -> a preludeError x y = error (printf "Prelude.%s applied to EDSL types: use Data.Array.Accelerate.%s instead" x y) -cond :: Elt t - => Exp Bool -- ^ condition - -> Exp t -- ^ then-expression - -> Exp t -- ^ else-expression - -> Exp t -cond (Exp c) (Exp x) (Exp y) = mkExp $ Cond c x y - $(runQ $ do let integralTypes :: [Name] @@ -153,8 +163,7 @@ $(runQ $ do nonNumTypes :: [Name] nonNumTypes = - [ ''Bool - , ''Char + [ ''Char ] cTypes :: [Name] diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 344b54362..6c9389513 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -28,7 +28,7 @@ module Data.Array.Accelerate.Classes.Ord ( import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Pattern -import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Sugar.Shape @@ -39,10 +39,11 @@ import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Eq hiding ( (==) ) import qualified Data.Array.Accelerate.Classes.Eq as A -import Text.Printf -import Prelude ( ($), (.), (>>=), Ordering(..), Num(..), Maybe(..), String, show, error, unlines, return, concat, map, mapM, (==) ) +import Data.Char import Language.Haskell.TH hiding ( Exp ) import Language.Haskell.TH.Extra +import Prelude ( ($), (>>=), Ordering(..), Num(..), Maybe(..), String, show, error, unlines, return, concat, map, mapM, (==) ) +import Text.Printf import qualified Prelude as P infix 4 < @@ -51,13 +52,13 @@ infix 4 <= infix 4 >= pattern LT_ :: Exp Ordering -pattern LT_ = Exp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeInt8))) 0)) +pattern LT_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 0) `Pair` SmartExp Nil)) pattern EQ_ :: Exp Ordering -pattern EQ_ = Exp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeInt8))) 1)) +pattern EQ_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 1) `Pair` SmartExp Nil)) pattern GT_ :: Exp Ordering -pattern GT_ = Exp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeInt8))) 2)) +pattern GT_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 2) `Pair` SmartExp Nil)) {-# COMPLETE LT_, EQ_, GT_ #-} -- | The 'Ord' class for totally ordered datatypes @@ -88,7 +89,7 @@ class Eq a => Ord a where -- Local redefinition for use with RebindableSyntax (pulled forward from Prelude.hs) -- ifThenElse :: Elt a => Exp Bool -> Exp a -> Exp a -> Exp a -ifThenElse (Exp c) (Exp x) (Exp y) = Exp $ SmartExp $ Cond c x y +ifThenElse (Exp c) (Exp x) (Exp y) = Exp $ SmartExp $ Cond (mkCoerce' c) x y instance Ord () where (<) _ _ = constant False @@ -119,23 +120,19 @@ instance Ord sh => Ord (sh :. Int) where Just Refl -> constant True Nothing -> indexTail x > indexTail y -instance Elt Ordering where - type EltR Ordering = Int8 - eltR = TupRsingle scalarType - fromElt = P.fromIntegral . P.fromEnum - toElt = P.toEnum . P.fromIntegral +instance Elt Ordering instance Eq Ordering where - x == y = mkBitcast x A.== (mkBitcast y :: Exp Int8) - x /= y = mkBitcast x /= (mkBitcast y :: Exp Int8) + x == y = mkCoerce x A.== (mkCoerce y :: Exp TAG) + x /= y = mkCoerce x A./= (mkCoerce y :: Exp TAG) 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) + x < y = mkCoerce x < (mkCoerce y :: Exp TAG) + x > y = mkCoerce x > (mkCoerce y :: Exp TAG) + x <= y = mkCoerce x <= (mkCoerce y :: Exp TAG) + x >= y = mkCoerce x >= (mkCoerce y :: Exp TAG) + min x y = mkCoerce $ min (mkCoerce x) (mkCoerce y :: Exp TAG) + max x y = mkCoerce $ max (mkCoerce x) (mkCoerce y :: Exp TAG) -- Instances of 'Prelude.Ord' (mostly) don't make sense with the standard @@ -189,8 +186,7 @@ $(runQ $ do nonNumTypes :: [Name] nonNumTypes = - [ ''Bool - , ''Char + [ ''Char ] cTypes :: [Name] diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot b/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot index b2e83ed6a..6085b7841 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot @@ -20,6 +20,7 @@ import Data.Array.Accelerate.Classes.Floating import Data.Array.Accelerate.Classes.FromIntegral import {-# SOURCE #-} Data.Array.Accelerate.Classes.RealFrac +import Prelude ( Bool ) import qualified Prelude as P diff --git a/src/Data/Array/Accelerate/Data/Bits.hs b/src/Data/Array/Accelerate/Data/Bits.hs index a2ad1b3b6..58c746d2a 100644 --- a/src/Data/Array/Accelerate/Data/Bits.hs +++ b/src/Data/Array/Accelerate/Data/Bits.hs @@ -183,7 +183,7 @@ instance Bits Bool where rotate x _ = x bit i = i == 0 isSigned = isSignedDefault - popCount = mkBoolToInt + popCount = boolToInt instance Bits Int where (.&.) = mkBAnd diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index 3ad23ce6f..c2cf1107e 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -49,6 +49,7 @@ import Data.Array.Accelerate.Classes import Data.Array.Accelerate.Data.Functor import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Elt @@ -78,14 +79,25 @@ pattern r ::+ i <- (deconstructComplex -> (r, i)) -- instance Elt a => Elt (Complex a) where type EltR (Complex a) = ComplexR (EltR a) - eltR = case complexR tp of - ComplexVec s -> TupRsingle $ VectorScalarType $ VectorType 2 s - ComplexTup -> TupRunit `TupRpair` tp `TupRpair` tp - where - tp = eltR @a + eltR = let tR = eltR @a + in case complexR tR of + ComplexVec s -> TupRsingle $ VectorScalarType $ VectorType 2 s + ComplexTup -> TupRunit `TupRpair` tR `TupRpair` tR + + tagsR = let tR = eltR @a + in case complexR tR of + ComplexVec s -> [ TagRsingle (VectorScalarType (VectorType 2 s)) ] + ComplexTup -> let go :: TypeR t -> [TagR t] + go TupRunit = [TagRunit] + go (TupRsingle s) = [TagRsingle s] + go (TupRpair ta tb) = [TagRpair a b | a <- go ta, b <- go tb] + in + [ TagRunit `TagRpair` ta `TagRpair` tb | ta <- go tR, tb <- go tR ] + toElt = case complexR $ eltR @a of ComplexVec _ -> \(Vec2 r i) -> toElt r :+ toElt i ComplexTup -> \(((), r), i) -> toElt r :+ toElt i + fromElt (r :+ i) = case complexR $ eltR @a of ComplexVec _ -> Vec2 (fromElt r) (fromElt i) ComplexTup -> (((), fromElt r), fromElt i) @@ -128,7 +140,6 @@ complexR = tuple nonnum :: NonNumType a -> ComplexType a (ComplexR a) nonnum TypeChar = ComplexTup - nonnum TypeBool = ComplexTup num :: NumType a -> ComplexType a (ComplexR a) num (IntegralNumType t) = integral t diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index 02e575d92..f53e21eaa 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -52,7 +52,7 @@ import Data.Array.Accelerate.Data.Semigroup import Data.Either ( Either(..) ) import Data.Maybe -import Prelude ( (.), ($), const, otherwise ) +import Prelude ( (.), ($), const, otherwise, undefined ) pattern Left_ :: (Elt a, Elt b) => Exp a -> Exp (Either a b) @@ -152,18 +152,12 @@ tag :: (Elt a, Elt b) => Exp (Either a b) -> Exp Word8 tag x = t where T3 t _ _ = asTuple x -instance (Elt a, Elt b) => Elt (Either a b) where - type EltR (Either a b) = EltR (Word8,a,b) - eltR = eltR @(Word8,a,b) - toElt ((((),0),a),_) = Left (toElt a) - toElt (_ ,b) = Right (toElt b) - fromElt (Left a) = ((((),0), fromElt a ), evalUndef $ eltR @b) - fromElt (Right b) = ((((),1), evalUndef $ eltR @a), fromElt b) +instance (Elt a, Elt b) => Elt (Either 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) = toEither $ T3 (constant 0) (lift a) undef - lift (Right b) = toEither $ T3 (constant 1) undef (lift b) + -- lift (Left a) = toEither $ T3 (constant 0) (lift a) undef + -- lift (Right b) = toEither $ T3 (constant 1) undef (lift b) -- Utilities @@ -204,8 +198,8 @@ emptyArray :: (Shape sh, Elt e) => Acc (Array sh e) emptyArray = fill (constant empty) undef asTuple :: Exp (Either a b) -> Exp (Word8, a, b) -asTuple (Exp e) = Exp e +asTuple = undefined -- (Exp e) = Exp e toEither :: Exp (Word8, a, b) -> Exp (Either a b) -toEither (Exp e) = Exp e +toEither = undefined -- (Exp e) = Exp e diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index fbd4b643c..731835171 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -103,7 +103,7 @@ fromMaybe d x = cond (isNothing x) d (fromJust x) -- instead. -- fromJust :: Elt a => Exp (Maybe a) -> Exp a -fromJust (Exp x) = Exp $ SmartExp $ PairIdxRight `Prj` x +fromJust (Exp x) = Exp $ SmartExp (PairIdxRight `Prj` SmartExp (PairIdxRight `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; @@ -153,25 +153,18 @@ instance (Semigroup (Exp a), Elt a) => Semigroup (Exp (Maybe a)) where tag :: Elt a => Exp (Maybe a) -> Exp Word8 -tag (Exp x) = Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxLeft x +tag (Exp x) = Exp $ SmartExp $ Prj PairIdxLeft x - -instance Elt a => Elt (Maybe a) where - type EltR (Maybe a) = EltR (Word8, a) - eltR = eltR @(Word8,a) - toElt (((),0),_) = Nothing - toElt (_ ,x) = Just (toElt x) - fromElt Nothing = (((),0), evalUndef $ eltR @a) - fromElt (Just a) = (((),1), fromElt a) +instance Elt a => Elt (Maybe a) instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Maybe a) where type Plain (Maybe a) = Maybe (Plain a) - lift Nothing = Exp $ SmartExp $ Pair t $ unExp $ undef @(Plain a) - where - t = SmartExp $ Pair (SmartExp Nil) $ SmartExp $ Const scalarTypeWord8 0 - lift (Just x) = Exp $ SmartExp $ Pair t $ unExp $ lift x - where - t = SmartExp $ Pair (SmartExp Nil) $ SmartExp $ Const scalarTypeWord8 1 + -- lift Nothing = Exp $ SmartExp $ Pair t $ unExp $ undef @(Plain a) + -- where + -- t = SmartExp $ Pair (SmartExp Nil) (SmartExp $ Const scalarTypeWord8 0) + -- lift (Just x) = Exp $ SmartExp $ Pair t $ unExp $ lift x + -- where + -- t = SmartExp $ Pair (SmartExp Nil) $ SmartExp $ Const scalarTypeWord8 1 -- Utilities diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index ab786e1c0..a20b48c71 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -38,17 +38,17 @@ module Data.Array.Accelerate.Interpreter ( run, run1, runN, -- Internal (hidden) - evalPrim, evalPrimConst, evalUndef, evalUndefScalar, evalCoerceScalar, + evalPrim, evalPrimConst, evalCoerceScalar, ) where import Data.Array.Accelerate.AST hiding ( Boundary(..) ) import Data.Array.Accelerate.AST.Environment import Data.Array.Accelerate.AST.Var -import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Error import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Elt import Data.Array.Accelerate.Representation.Shape import Data.Array.Accelerate.Representation.Slice import Data.Array.Accelerate.Representation.Stencil @@ -63,6 +63,7 @@ import qualified Data.Array.Accelerate.AST as AST import qualified Data.Array.Accelerate.Debug as D import qualified Data.Array.Accelerate.Smart as Smart import qualified Data.Array.Accelerate.Sugar.Array as Sugar +import qualified Data.Array.Accelerate.Sugar.Elt as Sugar import qualified Data.Array.Accelerate.Trafo.Delayed as AST import Control.DeepSeq @@ -193,6 +194,10 @@ evalOpenAcc (AST.Manifest pacc) aenv = evalB :: AST.Boundary aenv t -> Boundary t evalB bnd = evalBoundary bnd aenv + + dir :: Direction -> t -> t -> t + dir LeftToRight l _ = l + dir RightToLeft _ r = r in case pacc of Avar (Var repr ix) -> (TupRsingle repr, prj ix aenv) @@ -206,7 +211,7 @@ evalOpenAcc (AST.Manifest pacc) aenv = Apply repr afun acc -> (repr, evalOpenAfun afun aenv $ snd $ manifest acc) Aforeign repr _ afun acc -> (repr, evalOpenAfun afun Empty $ snd $ manifest acc) Acond p acc1 acc2 - | evalE p -> manifest acc1 + | toBool (evalE p) -> manifest acc1 | otherwise -> manifest acc2 Awhile cond body acc -> (repr, go initial) @@ -215,8 +220,8 @@ evalOpenAcc (AST.Manifest pacc) aenv = p = evalOpenAfun cond aenv f = evalOpenAfun body aenv go !x - | (ArrayR ShapeRz (TupRsingle scalarTypeBool), p x) ! () = go (f x) - | otherwise = x + | toBool (linearIndexArray (Sugar.eltR @Word8) (p x) 0) = go (f x) + | otherwise = x Use repr arr -> (TupRsingle repr, arr) Unit tp e -> unitOp tp (evalE e) @@ -247,10 +252,7 @@ evalOpenAcc (AST.Manifest pacc) aenv = Stencil s tp sten b acc -> stencilOp s tp (evalF sten) (evalB b) (delayed acc) Stencil2 s1 s2 tp sten b1 a1 b2 a2 -> stencil2Op s1 s2 tp (evalF sten) (evalB b1) (delayed a1) (evalB b2) (delayed a2) - where - dir :: Direction -> t -> t -> t - dir LeftToRight l _ = l - dir RightToLeft _ r = r + -- Array primitives -- ---------------- @@ -909,7 +911,7 @@ evalOpenExp pexp env aenv = in evalOpenExp exp2 env' aenv Evar (Var _ ix) -> prj ix env Const _ c -> c - Undef tp -> evalUndefScalar tp + Undef tp -> undefElt (TupRsingle tp) PrimConst c -> evalPrimConst c PrimApp f x -> evalPrim f (evalE x) Nil -> () @@ -944,7 +946,7 @@ evalOpenExp pexp env aenv = ToIndex shr sh ix -> toIndex shr (evalE sh) (evalE ix) FromIndex shr sh ix -> fromIndex shr (evalE sh) (evalE ix) Cond c t e - | evalE c -> evalE t + | toBool (evalE c) -> evalE t | otherwise -> evalE e While cond body seed -> go (evalE seed) @@ -952,8 +954,8 @@ evalOpenExp pexp env aenv = f = evalF body p = evalF cond go !x - | p x = go (f x) - | otherwise = x + | toBool (p x) = go (f x) + | otherwise = x Index acc ix -> let (TupRsingle repr, a) = evalA acc in (repr, a) ! evalE ix @@ -966,43 +968,6 @@ evalOpenExp pexp env aenv = Coerce t1 t2 e -> evalCoerceScalar t1 t2 (evalE e) --- Constant values --- --------------- - -evalUndef :: TypeR a -> a -evalUndef TupRunit = () -evalUndef (TupRsingle tp) = evalUndefScalar tp -evalUndef (TupRpair t1 t2) = (evalUndef t1, evalUndef t2) - -evalUndefScalar :: ScalarType a -> a -evalUndefScalar = scalar - where - 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 (VectorType n t) = vec (n * sizeOfSingleType t) - - vec :: Int -> Vec n t - vec n = runST $ do - mba <- newByteArray n - ByteArray ba# <- unsafeFreezeByteArray mba - return $ Vec ba# - - 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 - - -- Coercions -- --------- @@ -1040,13 +1005,8 @@ evalCoerceScalar (SingleScalarType ta) VectorScalarType{} a = vector ta a floating TypeDouble{} = poke nonnum :: NonNumType a -> a -> Vec n b - nonnum TypeBool{} = bool nonnum TypeChar{} = poke - bool :: Bool -> Vec n b - bool False = poke (0::Word8) - bool True = poke (1::Word8) - {-# INLINE poke #-} poke :: forall a b n. Prim a => a -> Vec n b poke x = runST $ do @@ -1083,14 +1043,8 @@ evalCoerceScalar VectorScalarType{} (SingleScalarType tb) a = scalar tb a floating TypeDouble{} = peek nonnum :: NonNumType b -> Vec n a -> b - nonnum TypeBool{} = bool nonnum TypeChar{} = peek - bool :: Vec n a -> Bool - bool v = case peek @Word8 v of - 0 -> False - _ -> True - {-# INLINE peek #-} peek :: Prim a => Vec n b -> a peek (Vec ba#) = indexByteArray (ByteArray ba#) 0 @@ -1167,7 +1121,6 @@ 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 @@ -1175,14 +1128,22 @@ evalPrim (PrimToFloating ta tb) = evalToFloating ta tb -- Implementation of scalar primitives -- ----------------------------------- -evalLAnd :: (Bool, Bool) -> Bool -evalLAnd (x, y) = x && y +toBool :: PrimBool -> Bool +toBool 0 = False +toBool _ = True + +fromBool :: Bool -> PrimBool +fromBool False = 0 +fromBool True = 1 -evalLOr :: (Bool, Bool) -> Bool -evalLOr (x, y) = x || y +evalLAnd :: (PrimBool, PrimBool) -> PrimBool +evalLAnd (x, y) = fromBool (toBool x && toBool y) -evalLNot :: Bool -> Bool -evalLNot = not +evalLOr :: (PrimBool, PrimBool) -> PrimBool +evalLOr (x, y) = fromBool (toBool x || toBool y) + +evalLNot :: PrimBool -> PrimBool +evalLNot = fromBool . not . toBool evalOrd :: Char -> Int evalOrd = ord @@ -1190,10 +1151,6 @@ 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 @@ -1325,11 +1282,11 @@ evalCeiling ta tb evalAtan2 :: FloatingType a -> ((a, a) -> a) evalAtan2 ty | FloatingDict <- floatingDict ty = uncurry atan2 -evalIsNaN :: FloatingType a -> (a -> Bool) -evalIsNaN ty | FloatingDict <- floatingDict ty = isNaN +evalIsNaN :: FloatingType a -> (a -> PrimBool) +evalIsNaN ty | FloatingDict <- floatingDict ty = fromBool . isNaN -evalIsInfinite :: FloatingType a -> (a -> Bool) -evalIsInfinite ty | FloatingDict <- floatingDict ty = isInfinite +evalIsInfinite :: FloatingType a -> (a -> PrimBool) +evalIsInfinite ty | FloatingDict <- floatingDict ty = fromBool . isInfinite -- Methods of Num @@ -1440,35 +1397,35 @@ 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 (<) +evalLt :: SingleType a -> ((a, a) -> PrimBool) +evalLt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (<) +evalLt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (<) +evalLt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . 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 (>) +evalGt :: SingleType a -> ((a, a) -> PrimBool) +evalGt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (>) +evalGt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (>) +evalGt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . 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 (<=) +evalLtEq :: SingleType a -> ((a, a) -> PrimBool) +evalLtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (<=) +evalLtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (<=) +evalLtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . 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 (>=) +evalGtEq :: SingleType a -> ((a, a) -> PrimBool) +evalGtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (>=) +evalGtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (>=) +evalGtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . 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 (==) +evalEq :: SingleType a -> ((a, a) -> PrimBool) +evalEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (==) +evalEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (==) +evalEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . 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 (/=) +evalNEq :: SingleType a -> ((a, a) -> PrimBool) +evalNEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (/=) +evalNEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (/=) +evalNEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . uncurry (/=) evalMax :: SingleType a -> ((a, a) -> a) evalMax (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = uncurry max diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 082cd6a2b..c1d0fc8d4 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -123,7 +123,7 @@ import Data.Array.Accelerate.Classes.Integral import Data.Array.Accelerate.Classes.Num import Data.Array.Accelerate.Classes.Ord -import Prelude ( ($), (.), Maybe(..) ) +import Prelude ( ($), (.), Maybe(..), Char ) -- $setup @@ -1255,7 +1255,7 @@ acond :: Arrays a -> Acc a -- ^ then-array -> Acc a -- ^ else-array -> Acc a -acond = Acc $$$ applyAcc $ Acond +acond (Exp p) = Acc $$ applyAcc $ Acond (mkCoerce' p) -- | An array-level 'while' construct. Continue to apply the given function, -- starting with the initial value, until the test function evaluates to @@ -1266,7 +1266,11 @@ awhile :: forall a. Arrays a -> (Acc a -> Acc a) -- ^ function to apply -> Acc a -- ^ initial value -> Acc a -awhile = Acc $$$ applyAcc $ Awhile $ arraysR @a +awhile f = Acc $$ applyAcc $ Awhile (arraysR @a) (unAccFunction g) + where + -- FIXME: This should be a no-op! + g :: Acc a -> Acc (Scalar PrimBool) + g = map mkCoerce . f -- Shapes and indices @@ -1326,7 +1330,7 @@ cond :: Elt t -> Exp t -- ^ then-expression -> Exp t -- ^ else-expression -> Exp t -cond (Exp c) (Exp x) (Exp y) = mkExp $ Cond c x y +cond (Exp c) (Exp x) (Exp y) = mkExp $ Cond (mkCoerce' c) x y -- | While construct. Continue to apply the given function, starting with the -- initial value, until the test function evaluates to 'False'. @@ -1337,9 +1341,9 @@ while :: forall e. Elt e -> Exp e -- ^ initial value -> Exp e #if __GLASGOW_HASKELL__ < 804 -while c f (Exp e) = mkExp $ While @SmartAcc @SmartExp @(EltR e) (eltR @e) (unExp . c . Exp) (unExp . f . Exp) e +while c f (Exp e) = mkExp $ While @SmartAcc @SmartExp @(EltR e) (eltR @e) (mkCoerce' . unExp . c . Exp) (unExp . f . Exp) e #else -while c f (Exp e) = mkExp $ While @(EltR e) (eltR @e) (unExp . c . Exp) (unExp . f . Exp) e +while c f (Exp e) = mkExp $ While @(EltR e) (eltR @e) (mkCoerce' . unExp . c . Exp) (unExp . f . Exp) e #endif @@ -1500,7 +1504,7 @@ chr = mkChr -- into '1'. -- boolToInt :: Exp Bool -> Exp Int -boolToInt = mkBoolToInt +boolToInt = mkFromIntegral . mkCoerce @_ @Word8 -- |Reinterpret a value as another type. The two representations must have the -- same bit size. diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 153d1c63f..a6a4c79c4 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -281,7 +281,8 @@ instance Lift Exp CDouble where instance Lift Exp Bool where type Plain Bool = Bool - lift = expConst + lift True = Exp . SmartExp $ SmartExp (Const scalarType 1) `Pair` SmartExp Nil + lift False = Exp . SmartExp $ SmartExp (Const scalarType 0) `Pair` SmartExp Nil instance Lift Exp Char where type Plain Char = Char diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 1249ded7f..1d1c81d2e 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -661,7 +661,6 @@ primOperator PrimLOr = Operator "||" Infix R 2 primOperator PrimLNot = Operator "not" App L 10 primOperator PrimOrd = Operator "ord" App L 10 primOperator PrimChr = Operator "chr" App L 10 -primOperator PrimBoolToInt = Operator "boolToInt" App L 10 primOperator PrimFromIntegral{} = Operator "fromIntegral" App L 10 primOperator PrimToFloating{} = Operator "toFloating" App L 10 diff --git a/src/Data/Array/Accelerate/Representation/Elt.hs b/src/Data/Array/Accelerate/Representation/Elt.hs index d3f14524f..ce717520e 100644 --- a/src/Data/Array/Accelerate/Representation/Elt.hs +++ b/src/Data/Array/Accelerate/Representation/Elt.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Representation.Elt @@ -18,10 +20,103 @@ import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type import Data.Primitive.Vec +import Control.Monad.ST +import Data.Char import Data.List ( intercalate ) +import Data.Primitive.ByteArray +import Foreign.Storable import Language.Haskell.TH +undefElt :: TypeR t -> t +undefElt = tuple + where + tuple :: TypeR t -> t + tuple TupRunit = () + tuple (TupRpair ta tb) = (tuple ta, tuple tb) + tuple (TupRsingle t) = scalar t + + scalar :: ScalarType t -> t + scalar (SingleScalarType t) = single t + scalar (VectorScalarType t) = vector t + + vector :: VectorType t -> t + vector (VectorType n t) = runST $ do + mba <- newByteArray (n * bytesElt (TupRsingle (SingleScalarType t))) + ByteArray ba# <- unsafeFreezeByteArray mba + return (Vec ba#) + + single :: SingleType t -> t + single (NumSingleType t) = num t + single (NonNumSingleType t) = nonnum t + + nonnum :: NonNumType t -> t + nonnum TypeChar = chr 0 + + num :: NumType t -> t + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + integral :: IntegralType t -> t + integral TypeInt = 0 + integral TypeInt8 = 0 + integral TypeInt16 = 0 + integral TypeInt32 = 0 + integral TypeInt64 = 0 + integral TypeWord = 0 + integral TypeWord8 = 0 + integral TypeWord16 = 0 + integral TypeWord32 = 0 + integral TypeWord64 = 0 + + floating :: FloatingType t -> t + floating TypeHalf = 0 + floating TypeFloat = 0 + floating TypeDouble = 0 + +bytesElt :: TypeR e -> Int +bytesElt = tuple + where + tuple :: TypeR t -> Int + tuple TupRunit = 0 + tuple (TupRpair ta tb) = tuple ta + tuple tb + tuple (TupRsingle t) = scalar t + + scalar :: ScalarType t -> Int + scalar (SingleScalarType t) = single t + scalar (VectorScalarType t) = vector t + + vector :: VectorType t -> Int + vector (VectorType n t) = n * single t + + single :: SingleType t -> Int + single (NumSingleType t) = num t + single (NonNumSingleType t) = nonnum t + + nonnum :: NonNumType t -> Int + nonnum TypeChar = sizeOf (undefined::Char) + + num :: NumType t -> Int + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + integral :: IntegralType t -> Int + integral TypeInt = sizeOf (undefined::Int) + integral TypeInt8 = 1 + integral TypeInt16 = 2 + integral TypeInt32 = 4 + integral TypeInt64 = 8 + integral TypeWord = sizeOf (undefined::Word) + integral TypeWord8 = 1 + integral TypeWord16 = 2 + integral TypeWord32 = 4 + integral TypeWord64 = 8 + + floating :: FloatingType t -> Int + floating TypeHalf = 2 + floating TypeFloat = 4 + floating TypeDouble = 8 + showElt :: TypeR e -> e -> String showElt t v = showsElt t v "" @@ -46,25 +141,24 @@ showsElt = tuple num (FloatingNumType t) e = floating t e integral :: IntegralType e -> e -> String - integral TypeInt{} e = show e - integral TypeInt8{} e = show e - integral TypeInt16{} e = show e - integral TypeInt32{} e = show e - integral TypeInt64{} e = show e - integral TypeWord{} e = show e - integral TypeWord8{} e = show e - integral TypeWord16{} e = show e - integral TypeWord32{} e = show e - integral TypeWord64{} e = show e + integral TypeInt e = show e + integral TypeInt8 e = show e + integral TypeInt16 e = show e + integral TypeInt32 e = show e + integral TypeInt64 e = show e + integral TypeWord e = show e + integral TypeWord8 e = show e + integral TypeWord16 e = show e + integral TypeWord32 e = show e + integral TypeWord64 e = show e floating :: FloatingType e -> e -> String - floating TypeHalf{} e = show e - floating TypeFloat{} e = show e - floating TypeDouble{} e = show e + floating TypeHalf e = show e + floating TypeFloat e = show e + floating TypeDouble e = show e nonnum :: NonNumType e -> e -> String nonnum TypeChar e = show e - nonnum TypeBool e = show e vector :: VectorType (Vec n a) -> Vec n a -> String vector (VectorType _ s) vec @@ -76,4 +170,3 @@ liftElt TupRunit () = [|| () ||] liftElt (TupRsingle t) x = [|| $$(liftScalar t x) ||] liftElt (TupRpair ta tb) (a,b) = [|| ($$(liftElt ta a), $$(liftElt tb b)) ||] - diff --git a/src/Data/Array/Accelerate/Representation/Tag.hs b/src/Data/Array/Accelerate/Representation/Tag.hs new file mode 100644 index 000000000..8069e4286 --- /dev/null +++ b/src/Data/Array/Accelerate/Representation/Tag.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} +-- | +-- Module : Data.Array.Accelerate.Representation.Tag +-- Copyright : [2008..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Representation.Tag + where + +import Data.Array.Accelerate.Type + +import Language.Haskell.TH + + +-- | The type of the runtime value used to distinguish constructor +-- alternatives in a sum type. +-- +type TAG = Word8 + +-- | This structure both witnesses the layout of our representation types +-- (as TupR does) and represents a complete path of pattern matching +-- through this type. It indicates which fields of the structure represent +-- the union tags (TagRtag) or store undefined values (TagRundef). +-- +-- The function 'eltTags' produces all valid paths through the type. For +-- example the type '(Bool,Bool)' produces the following: +-- +-- ghci> putStrLn . unlines . map show $ eltTags @(Bool,Bool) +-- (((),(0#,())),(0#,())) -- (False, False) +-- (((),(0#,())),(1#,())) -- (False, True) +-- (((),(1#,())),(0#,())) -- (True, False) +-- (((),(1#,())),(1#,())) -- (True, True) +-- +data TagR a where + TagRunit :: TagR () + TagRsingle :: ScalarType a -> TagR a + TagRundef :: ScalarType a -> TagR a + TagRtag :: TAG -> TagR a -> TagR (TAG, a) + TagRpair :: TagR a -> TagR b -> TagR (a, b) + +instance Show (TagR a) where + show TagRunit = "()" + show TagRsingle{} = "." + show TagRundef{} = "undef" + show (TagRtag v t) = "(" ++ show v ++ "#," ++ show t ++ ")" + show (TagRpair ta tb) = "(" ++ show ta ++ "," ++ show tb ++ ")" + +rnfTag :: TagR a -> () +rnfTag TagRunit = () +rnfTag (TagRsingle t) = rnfScalarType t +rnfTag (TagRundef t) = rnfScalarType t +rnfTag (TagRtag v t) = v `seq` rnfTag t +rnfTag (TagRpair ta tb) = rnfTag ta `seq` rnfTag tb + +liftTag :: TagR a -> Q (TExp (TagR a)) +liftTag TagRunit = [|| TagRunit ||] +liftTag (TagRsingle t) = [|| TagRsingle $$(liftScalarType t) ||] +liftTag (TagRundef t) = [|| TagRundef $$(liftScalarType t) ||] +liftTag (TagRtag v t) = [|| TagRtag v $$(liftTag t) ||] +liftTag (TagRpair ta tb) = [|| TagRpair $$(liftTag ta) $$(liftTag tb) ||] + diff --git a/src/Data/Array/Accelerate/Representation/Type.hs b/src/Data/Array/Accelerate/Representation/Type.hs index 9e9ae3bd1..8cee6c724 100644 --- a/src/Data/Array/Accelerate/Representation/Type.hs +++ b/src/Data/Array/Accelerate/Representation/Type.hs @@ -86,7 +86,6 @@ liftTypeQ = tuple nonnum :: NonNumType t -> TypeQ nonnum TypeChar = [t| Char |] - nonnum TypeBool = [t| Bool |] num :: NumType t -> TypeQ num (IntegralNumType t) = integral t diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 9f4df497a..26e3368d2 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -36,6 +36,7 @@ module Data.Array.Accelerate.Smart ( Exp(..), SmartExp(..), PreSmartExp(..), Stencil(..), Boundary(..), PreBoundary(..), + PrimBool, -- ** Extracting type information HasArraysR(..), @@ -65,7 +66,7 @@ module Data.Array.Accelerate.Smart ( mkLAnd, mkLOr, mkLNot, mkIsNaN, mkIsInfinite, -- ** Smart constructors for type coercion functions - mkOrd, mkChr, mkBoolToInt, mkFromIntegral, mkToFloating, mkBitcast, mkCoerce, Coerce, + mkOrd, mkChr, mkFromIntegral, mkToFloating, mkBitcast, mkCoerce, Coerce(..), -- ** Auxiliary functions ($$), ($$$), ($$$$), ($$$$$), @@ -85,6 +86,7 @@ import Data.Array.Accelerate.Representation.Elt import Data.Array.Accelerate.Representation.Shape import Data.Array.Accelerate.Representation.Slice import Data.Array.Accelerate.Representation.Stencil hiding ( StencilR, stencilR ) +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Representation.Vec import Data.Array.Accelerate.Sugar.Array ( Arrays ) @@ -303,6 +305,7 @@ newtype SmartAcc a = SmartAcc (PreSmartAcc SmartAcc SmartExp a) -- the environment at the defining occurrence. -- type Level = Int +type PrimBool = TAG -- | Array-valued collective computations without a recursive knot -- @@ -327,13 +330,13 @@ data PreSmartAcc acc exp as where -> acc as -> PreSmartAcc acc exp bs - Acond :: exp Bool + Acond :: exp PrimBool -> acc as -> acc as -> PreSmartAcc acc exp as Awhile :: ArraysR arrs - -> (SmartAcc arrs -> acc (Scalar Bool)) + -> (SmartAcc arrs -> acc (Scalar PrimBool)) -> (SmartAcc arrs -> acc arrs) -> acc arrs -> PreSmartAcc acc exp arrs @@ -472,7 +475,7 @@ newtype SmartExp t = SmartExp (PreSmartExp SmartAcc SmartExp t) -- the type of collective array operations. -- data PreSmartExp acc exp t where - -- Needed for conversion to de Bruijn form + -- Needed for conversion to de Bruijn form Tag :: TypeR t -> Level -- environment size at defining occurrence -> PreSmartExp acc exp t @@ -513,13 +516,13 @@ data PreSmartExp acc exp t where -> exp Int -> PreSmartExp acc exp sh - Cond :: exp Bool + Cond :: exp PrimBool -> exp t -> exp t -> PreSmartExp acc exp t While :: TypeR t - -> (SmartExp t -> exp Bool) + -> (SmartExp t -> exp PrimBool) -> (SmartExp t -> exp t) -> exp t -> PreSmartExp acc exp t @@ -1095,32 +1098,32 @@ mkAtan2 :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp t -> Exp t mkAtan2 = mkPrimBinary $ PrimAtan2 floatingType mkIsNaN :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp Bool -mkIsNaN = mkPrimUnary $ PrimIsNaN floatingType +mkIsNaN = mkPrimUnaryBool $ PrimIsNaN floatingType mkIsInfinite :: (Elt t, IsFloating (EltR t)) => Exp t -> Exp Bool -mkIsInfinite = mkPrimUnary $ PrimIsInfinite floatingType +mkIsInfinite = mkPrimUnaryBool $ PrimIsInfinite floatingType -- FIXME: add missing operations from Floating, RealFrac & RealFloat -- Relational and equality operators mkLt :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool -mkLt = mkPrimBinary $ PrimLt singleType +mkLt = mkPrimBinaryBool $ PrimLt singleType mkGt :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool -mkGt = mkPrimBinary $ PrimGt singleType +mkGt = mkPrimBinaryBool $ PrimGt singleType mkLtEq :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool -mkLtEq = mkPrimBinary $ PrimLtEq singleType +mkLtEq = mkPrimBinaryBool $ PrimLtEq singleType mkGtEq :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool -mkGtEq = mkPrimBinary $ PrimGtEq singleType +mkGtEq = mkPrimBinaryBool $ PrimGtEq singleType mkEq :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool -mkEq = mkPrimBinary $ PrimEq singleType +mkEq = mkPrimBinaryBool $ PrimEq singleType mkNEq :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp Bool -mkNEq = mkPrimBinary $ PrimNEq singleType +mkNEq = mkPrimBinaryBool $ PrimNEq singleType mkMax :: (Elt t, IsSingle (EltR t)) => Exp t -> Exp t -> Exp t mkMax = mkPrimBinary $ PrimMax singleType @@ -1131,13 +1134,21 @@ mkMin = mkPrimBinary $ PrimMin singleType -- Logical operators mkLAnd :: Exp Bool -> Exp Bool -> Exp Bool -mkLAnd = mkPrimBinary PrimLAnd +mkLAnd (Exp a) (Exp b) = mkExp $ SmartExp (PrimApp PrimLAnd (SmartExp $ Pair x y)) `Pair` SmartExp Nil + where + x = SmartExp $ Prj PairIdxLeft a + y = SmartExp $ Prj PairIdxLeft b mkLOr :: Exp Bool -> Exp Bool -> Exp Bool -mkLOr = mkPrimBinary PrimLOr +mkLOr (Exp a) (Exp b) = mkExp $ SmartExp (PrimApp PrimLOr (SmartExp $ Pair x y)) `Pair` SmartExp Nil + where + x = SmartExp $ Prj PairIdxLeft a + y = SmartExp $ Prj PairIdxLeft b mkLNot :: Exp Bool -> Exp Bool -mkLNot = mkPrimUnary PrimLNot +mkLNot (Exp a) = mkExp $ SmartExp (PrimApp PrimLNot x) `Pair` SmartExp Nil + where + x = SmartExp $ Prj PairIdxLeft a -- Character conversions @@ -1157,9 +1168,6 @@ mkToFloating = mkPrimUnary $ PrimToFloating numType floatingType -- Other conversions -mkBoolToInt :: Exp Bool -> Exp Int -mkBoolToInt (Exp b) = mkExp $ PrimBoolToInt `PrimApp` b - -- NOTE: Restricted to scalar types with a type-level BitSizeEq constraint to -- make this version "safe" mkBitcast :: forall b a. (Elt a, Elt b, IsScalar (EltR a), IsScalar (EltR b), BitSizeEq (EltR a) (EltR b)) => Exp a -> Exp b @@ -1171,14 +1179,14 @@ mkCoerce (Exp a) = Exp $ mkCoerce' a class Coerce a b where mkCoerce' :: SmartExp a -> SmartExp b -instance (IsScalar a, IsScalar b, BitSizeEq a b) => Coerce a b where +instance {-# OVERLAPS #-} (IsScalar a, IsScalar b, BitSizeEq a b) => Coerce a b where mkCoerce' = SmartExp . Coerce (scalarType @a) (scalarType @b) instance (Coerce a1 b1, Coerce a2 b2) => Coerce (a1, a2) (b1, b2) where mkCoerce' a = SmartExp $ Pair (mkCoerce' $ SmartExp $ Prj PairIdxLeft a) (mkCoerce' $ SmartExp $ Prj PairIdxRight a) -instance Coerce () () where - mkCoerce' _ = SmartExp Nil +instance Coerce a a where + mkCoerce' = id instance Coerce ((), a) a where mkCoerce' a = SmartExp $ Prj PairIdxRight a @@ -1186,6 +1194,12 @@ instance Coerce ((), a) a where instance Coerce a ((), a) where mkCoerce' = SmartExp . Pair (SmartExp Nil) +instance Coerce (a, ()) a where + mkCoerce' a = SmartExp $ Prj PairIdxLeft a + +instance Coerce a (a, ()) where + mkCoerce' a = SmartExp (Pair a (SmartExp Nil)) + -- Auxiliary functions @@ -1231,6 +1245,12 @@ mkPrimUnary prim (Exp a) = mkExp $ PrimApp prim a mkPrimBinary :: (Elt a, Elt b, Elt c) => PrimFun ((EltR a, EltR b) -> EltR c) -> Exp a -> Exp b -> Exp c mkPrimBinary prim (Exp a) (Exp b) = mkExp $ PrimApp prim (SmartExp $ Pair a b) +mkPrimUnaryBool :: Elt a => PrimFun (EltR a -> PrimBool) -> Exp a -> Exp Bool +mkPrimUnaryBool = mkCoerce @PrimBool $$ mkPrimUnary + +mkPrimBinaryBool :: (Elt a, Elt b) => PrimFun ((EltR a, EltR b) -> PrimBool) -> Exp a -> Exp b -> Exp Bool +mkPrimBinaryBool = mkCoerce @PrimBool $$$ mkPrimBinary + unPair :: SmartExp (a, b) -> (SmartExp a, SmartExp b) unPair e = (SmartExp $ Prj PairIdxLeft e, SmartExp $ Prj PairIdxRight e) diff --git a/src/Data/Array/Accelerate/Sugar/Array.hs b/src/Data/Array/Accelerate/Sugar/Array.hs index f7c39c559..6efeace6e 100644 --- a/src/Data/Array/Accelerate/Sugar/Array.hs +++ b/src/Data/Array/Accelerate/Sugar/Array.hs @@ -38,6 +38,9 @@ import GHC.Exts ( IsList ) import GHC.Generics import qualified GHC.Exts as GHC +-- $setup +-- >>> :seti -XOverloadedLists + type Scalar = Array DIM0 -- ^ Scalar arrays hold a single element type Vector = Array DIM1 -- ^ Vectors are one-dimensional arrays diff --git a/src/Data/Array/Accelerate/Sugar/Elt.hs b/src/Data/Array/Accelerate/Sugar/Elt.hs index 85d0c977a..d692c687c 100644 --- a/src/Data/Array/Accelerate/Sugar/Elt.hs +++ b/src/Data/Array/Accelerate/Sugar/Elt.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -20,12 +21,15 @@ -- Portability : non-portable (GHC extensions) -- -module Data.Array.Accelerate.Sugar.Elt +module Data.Array.Accelerate.Sugar.Elt ( Elt(..) ) where +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type +import Data.Bits import Data.Kind import Language.Haskell.TH hiding ( Type ) import Language.Haskell.TH.Extra @@ -58,12 +62,15 @@ import GHC.Generics -- * -- * -- --- For simple product types it is possible to derive 'Elt' automatically, --- for example: +-- For simple types it is possible to derive 'Elt' automatically, for +-- example: -- -- > data Point = Point Int Float -- > deriving (Generic, Elt) -- +-- > data Option a = None | Just a +-- > deriving (Generic, Elt) +-- class Elt a where -- | Type representation mapping, which explains how to convert a type -- from the surface type into the internal representation type consisting @@ -73,66 +80,198 @@ class Elt a where type EltR a = GEltR () (Rep a) -- eltR :: TypeR (EltR a) + tagsR :: [TagR (EltR a)] fromElt :: a -> EltR a toElt :: EltR a -> a default eltR - :: (GElt (Rep a), EltR a ~ GEltR () (Rep a)) - => TypeR (EltR a) + :: (GElt (Rep a), EltR a ~ GEltR () (Rep a)) + => TypeR (EltR a) eltR = geltR @(Rep a) TupRunit + default tagsR + :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a)) + => [TagR (EltR a)] + tagsR = gtagsR @(Rep a) TagRunit + default fromElt - :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a)) - => a - -> EltR a + :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a)) + => a + -> EltR a fromElt = gfromElt () . from default toElt - :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a)) - => EltR a - -> a + :: (Generic a, GElt (Rep a), EltR a ~ GEltR () (Rep a)) + => EltR a + -> a toElt = to . snd . gtoElt @(Rep a) @() class GElt f where type GEltR t f geltR :: TypeR t -> TypeR (GEltR t f) + gtagsR :: TagR t -> [TagR (GEltR t f)] gfromElt :: t -> f a -> GEltR t f gtoElt :: GEltR t f -> (t, f a) + -- + gundef :: t -> GEltR t f + guntag :: TagR t -> TagR (GEltR t f) instance GElt U1 where type GEltR t U1 = t geltR t = t + gtagsR t = [t] gfromElt t U1 = t gtoElt t = (t, U1) + gundef t = t + guntag t = t instance GElt a => GElt (M1 i c a) where type GEltR t (M1 i c a) = GEltR t a geltR = geltR @a + gtagsR = gtagsR @a gfromElt t (M1 x) = gfromElt t x gtoElt x = let (t, x1) = gtoElt x in (t, M1 x1) + gundef = gundef @a + guntag = guntag @a instance Elt a => GElt (K1 i a) where type GEltR t (K1 i a) = (t, EltR a) geltR t = TupRpair t (eltR @a) + gtagsR t = TagRpair t <$> tagsR @a gfromElt t (K1 x) = (t, fromElt x) gtoElt (t, x) = (t, K1 (toElt x)) + gundef t = (t, undefElt (eltR @a)) + guntag t = TagRpair t (untag (eltR @a)) instance (GElt a, GElt b) => GElt (a :*: b) where type GEltR t (a :*: b) = GEltR (GEltR t a) b - geltR = geltR @b . geltR @a + geltR = geltR @b . geltR @a + gtagsR = concatMap (gtagsR @b) . gtagsR @a gfromElt t (a :*: b) = gfromElt (gfromElt t a) b gtoElt t = let (t1, b) = gtoElt t (t2, a) = gtoElt t1 in (t2, a :*: b) + gundef t = gundef @b (gundef @a t) + guntag t = guntag @b (guntag @a t) + +instance (GElt a, GElt b, GSumElt (a :+: b)) => GElt (a :+: b) where + type GEltR t (a :+: b) = (TAG, GSumEltR t (a :+: b)) + geltR t = TupRpair (TupRsingle scalarType) (gsumEltR @(a :+: b) t) + gtagsR t = uncurry TagRtag <$> gsumTagsR @(a :+: b) 0 t + gfromElt = gsumFromElt 0 + gtoElt (k,x) = gsumToElt k x + gundef t = (0xff, gsumUndef @(a :+: b) t) + guntag t = TagRpair (TagRundef scalarType) (gsumUntag @(a :+: b) t) + + +class GSumElt f where + type GSumEltR t f + gsumEltR :: TypeR t -> TypeR (GSumEltR t f) + gsumTagsR :: TAG -> TagR t -> [(TAG, TagR (GSumEltR t f))] + gsumFromElt :: TAG -> t -> f a -> (TAG, GSumEltR t f) + gsumToElt :: TAG -> GSumEltR t f -> (t, f a) + gsumUndef :: t -> GSumEltR t f + gsumUntag :: TagR t -> TagR (GSumEltR t f) + +instance GSumElt U1 where + type GSumEltR t U1 = t + gsumEltR t = t + gsumTagsR n t = [(n, t)] + gsumFromElt n t U1 = (n, t) + gsumToElt _ t = (t, U1) + gsumUndef t = t + gsumUntag t = t + +instance GSumElt a => GSumElt (M1 i c a) where + type GSumEltR t (M1 i c a) = GSumEltR t a + gsumEltR = gsumEltR @a + gsumTagsR = gsumTagsR @a + gsumFromElt n t (M1 x) = gsumFromElt n t x + gsumToElt k x = let (t, x') = gsumToElt k x in (t, M1 x') + gsumUntag = gsumUntag @a + gsumUndef = gsumUndef @a + +instance Elt a => GSumElt (K1 i a) where + type GSumEltR t (K1 i a) = (t, EltR a) + gsumEltR t = TupRpair t (eltR @a) + gsumTagsR n t = (n,) . TagRpair t <$> tagsR @a + gsumFromElt n t (K1 x) = (n, (t, fromElt x)) + gsumToElt _ (t, x) = (t, K1 (toElt x)) + gsumUntag t = TagRpair t (untag (eltR @a)) + gsumUndef t = (t, undefElt (eltR @a)) + +instance (GElt a, GElt b) => GSumElt (a :*: b) where + type GSumEltR t (a :*: b) = GEltR t (a :*: b) + gsumEltR = geltR @(a :*: b) + gsumTagsR n t = (n,) <$> gtagsR @(a :*: b) t + gsumFromElt n t (a :*: b) = (n, gfromElt (gfromElt t a) b) + gsumToElt _ t0 = + let (t1, b) = gtoElt t0 + (t2, a) = gtoElt t1 + in + (t2, a :*: b) + gsumUndef = gundef @(a :*: b) + gsumUntag = guntag @(a :*: b) + +instance (GSumElt a, GSumElt b) => GSumElt (a :+: b) where + type GSumEltR t (a :+: b) = GSumEltR (GSumEltR t a) b + gsumEltR = gsumEltR @b . gsumEltR @a + + gsumFromElt n t (L1 a) = let (m,r) = gsumFromElt n t a + in (shiftL m 1, gsumUndef @b r) + gsumFromElt n t (R1 b) = let (m,r) = gsumFromElt n (gsumUndef @a t) b + in (setBit (m `shiftL` 1) 0, r) + + gsumToElt k t0 = + let (t1, b) = gsumToElt (shiftR k 1) t0 + (t2, a) = gsumToElt (shiftR k 1) t1 + in + if testBit k 0 + then (t2, R1 b) + else (t2, L1 a) + + gsumTagsR k t = + let a = gsumTagsR @a k t + b = gsumTagsR @b k (gsumUntag @a t) + in + map (\(x,y) -> (x `shiftL` 1, gsumUntag @b y)) a ++ + map (\(x,y) -> (setBit (x `shiftL` 1) 0, y)) b + + gsumUndef t = gsumUndef @b (gsumUndef @a t) + gsumUntag t = gsumUntag @b (gsumUntag @a t) + + +class GTags (f :: Type -> Type) where + gtags :: TAG -> [(String, TAG)] + +instance GTags a => GTags (D1 c a) where + gtags = gtags @a + +instance Constructor c => GTags (C1 c a) where + gtags k = [ (conName (undefined :: D1 c a ()), k) ] + +instance (GTags a, GTags b) => GTags (a :+: b) where + gtags k = + let as = gtags @a k + bs = gtags @b k + in + map (\(x,y) -> (x, y `shiftL` 1) ) as ++ + map (\(x,y) -> (x, setBit (y `shiftL` 1) 0)) bs + + +untag :: TypeR t -> TagR t +untag TupRunit = TagRunit +untag (TupRsingle t) = TagRundef t +untag (TupRpair ta tb) = TagRpair (untag ta) (untag tb) -- Note: [Deriving Elt] -- --- We can't use the cunning generalised newtype deriving mechanism, because the --- generated 'eltType' function does not type check. For example, it will +-- We can't use the cunning generalised newtype deriving mechanism, because +-- the generated 'eltR function does not type check. For example, it will -- generate the following implementation for 'CShort': -- -- > eltR @@ -141,7 +280,7 @@ instance (GElt a, GElt b) => GElt (a :*: b) where -- > @(TypeR (EltR CShort)) -- > (eltR :: TypeR (EltR CShort)) -- --- Which yields the error "couldn't match type 'EltRepr a0' with 'Int16'". +-- Which yields the error "couldn't match type 'EltR a0' with 'Int16'". -- Since this function returns a type family type, the type signature on the -- result is not enough to fix the type 'a'. Instead, we require the use of -- (visible) type applications: @@ -157,11 +296,8 @@ instance (GElt a, GElt b) => GElt (a :*: b) where -- Instances for basic types are generated at the end of this module. -- -instance Elt () where - type EltR () = () - eltR = TupRunit - fromElt = id - toElt = id +instance Elt () +instance Elt Bool runQ $ do let @@ -190,8 +326,7 @@ runQ $ do nonNumTypes :: [Name] nonNumTypes = - [ ''Bool - , ''Char + [ ''Char ] newtypes :: [Name] @@ -217,7 +352,8 @@ runQ $ do in [d| instance Elt $t where type EltR $t = $t - eltR = TupRsingle scalarType + eltR = TupRsingle scalarType + tagsR = [TagRsingle scalarType] fromElt = id toElt = id |] @@ -257,6 +393,7 @@ runQ $ do [d| instance Elt $(conT name) where type EltR $(conT name) = $(conT base) eltR = TupRsingle scalarType + tagsR = [TagRsingle scalarType] fromElt $(conP (mkName (nameBase name)) [varP (mkName "x")]) = x toElt = $(conE (mkName (nameBase name))) |] diff --git a/src/Data/Array/Accelerate/Sugar/Shape.hs b/src/Data/Array/Accelerate/Sugar/Shape.hs index 987637470..276492b19 100644 --- a/src/Data/Array/Accelerate/Sugar/Shape.hs +++ b/src/Data/Array/Accelerate/Sugar/Shape.hs @@ -31,6 +31,7 @@ module Data.Array.Accelerate.Sugar.Shape where import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import qualified Data.Array.Accelerate.Representation.Shape as R import qualified Data.Array.Accelerate.Representation.Slice as R @@ -300,6 +301,7 @@ class (Slice (DivisionSlice sl)) => Division sl where instance (Elt t, Elt h) => Elt (t :. h) where type EltR (t :. h) = (EltR t, EltR h) eltR = TupRpair (eltR @t) (eltR @h) + tagsR = [TagRpair t h | t <- tagsR @t, h <- tagsR @h] fromElt (t:.h) = (fromElt t, fromElt h) toElt (t, h) = toElt t :. toElt h @@ -307,6 +309,7 @@ instance Elt (Any Z) instance Shape sh => Elt (Any (sh :. Int)) where type EltR (Any (sh :. Int)) = (EltR (Any sh), ()) eltR = TupRpair (eltR @(Any sh)) TupRunit + tagsR = [TagRpair t TagRunit | t <- tagsR @(Any sh)] fromElt _ = (fromElt (Any :: Any sh), ()) toElt _ = Any diff --git a/src/Data/Array/Accelerate/Sugar/Vec.hs b/src/Data/Array/Accelerate/Sugar/Vec.hs index f6d491555..488537793 100644 --- a/src/Data/Array/Accelerate/Sugar/Vec.hs +++ b/src/Data/Array/Accelerate/Sugar/Vec.hs @@ -18,6 +18,7 @@ module Data.Array.Accelerate.Sugar.Vec where import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type import Data.Primitive.Types @@ -32,6 +33,7 @@ type VecElt a = (Elt a, Prim a, IsSingle a, EltR a ~ a) instance (KnownNat n, VecElt a) => Elt (Vec n a) where type EltR (Vec n a) = Vec n a eltR = TupRsingle (VectorScalarType (VectorType (fromIntegral (natVal' (proxy# :: Proxy# n))) singleType)) + tagsR = [TagRsingle (VectorScalarType (VectorType (fromIntegral (natVal' (proxy# :: Proxy# n))) singleType))] toElt = id fromElt = id diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index 2d9408cbe..915790efa 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -149,7 +149,6 @@ evalPrimApp env f x 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 @@ -266,10 +265,34 @@ eval2 tp f (untup2 -> Just (x,y)) env , Just b <- propagate env y = Stats.substitution "constant fold" $ Just $ Const (SingleScalarType tp) (f a b) - eval2 _ _ _ _ = Nothing +fromBool :: Bool -> PrimBool +fromBool False = 0 +fromBool True = 1 + +toBool :: PrimBool -> Bool +toBool 0 = False +toBool _ = True + +bool1 :: (a -> Bool) -> a :-> PrimBool +bool1 f x env + | Just a <- propagate env x + = Stats.substitution "constant fold" + . Just $ Const scalarTypeWord8 (fromBool (f a)) +bool1 _ _ _ + = Nothing + +bool2 :: (a -> b -> Bool) -> (a,b) :-> PrimBool +bool2 f (untup2 -> Just (x,y)) env + | Just a <- propagate env x + , Just b <- propagate env y + = Stats.substitution "constant fold" + $ Just $ Const scalarTypeWord8 (fromBool (f a b)) +bool2 _ _ _ + = Nothing + tup2 :: (OpenExp env aenv a, OpenExp env aenv b) -> OpenExp env aenv (a, b) tup2 (a,b) = Pair a b @@ -593,62 +616,66 @@ evalAtan2 ty | FloatingDict <- floatingDict ty = eval2 (NumSingleType $ Floating evalTruncate :: FloatingType a -> IntegralType b -> a :-> b evalTruncate ta tb | FloatingDict <- floatingDict ta - , IntegralDict <- integralDict tb = eval1 (NumSingleType $ IntegralNumType tb) truncate + , IntegralDict <- integralDict tb + = eval1 (NumSingleType $ IntegralNumType tb) truncate evalRound :: FloatingType a -> IntegralType b -> a :-> b evalRound ta tb | FloatingDict <- floatingDict ta - , IntegralDict <- integralDict tb = eval1 (NumSingleType $ IntegralNumType tb) round + , IntegralDict <- integralDict tb + = eval1 (NumSingleType $ IntegralNumType tb) round evalFloor :: FloatingType a -> IntegralType b -> a :-> b evalFloor ta tb | FloatingDict <- floatingDict ta - , IntegralDict <- integralDict tb = eval1 (NumSingleType $ IntegralNumType tb) floor + , IntegralDict <- integralDict tb + = eval1 (NumSingleType $ IntegralNumType tb) floor evalCeiling :: FloatingType a -> IntegralType b -> a :-> b evalCeiling ta tb | FloatingDict <- floatingDict ta - , IntegralDict <- integralDict tb = eval1 (NumSingleType $ IntegralNumType tb) ceiling + , IntegralDict <- integralDict tb + = eval1 (NumSingleType $ IntegralNumType tb) ceiling -evalIsNaN :: FloatingType a -> a :-> Bool -evalIsNaN ty | FloatingDict <- floatingDict ty = eval1 (NonNumSingleType TypeBool) isNaN +evalIsNaN :: FloatingType a -> a :-> PrimBool +evalIsNaN ty | FloatingDict <- floatingDict ty = bool1 isNaN -evalIsInfinite :: FloatingType a -> a :-> Bool -evalIsInfinite ty | FloatingDict <- floatingDict ty = eval1 (NonNumSingleType TypeBool) isInfinite +evalIsInfinite :: FloatingType a -> a :-> PrimBool +evalIsInfinite ty | FloatingDict <- floatingDict ty = bool1 isInfinite -- Relational & Equality -- --------------------- -evalLt :: SingleType a -> (a,a) :-> Bool -evalLt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (<) -evalLt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (<) -evalLt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (<) +evalLt :: SingleType a -> (a,a) :-> PrimBool +evalLt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (<) +evalLt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (<) +evalLt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (<) -evalGt :: SingleType a -> (a,a) :-> Bool -evalGt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (>) -evalGt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (>) -evalGt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (>) +evalGt :: SingleType a -> (a,a) :-> PrimBool +evalGt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (>) +evalGt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (>) +evalGt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (>) -evalLtEq :: SingleType a -> (a,a) :-> Bool -evalLtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (<=) -evalLtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (<=) -evalLtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (<=) +evalLtEq :: SingleType a -> (a,a) :-> PrimBool +evalLtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (<=) +evalLtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (<=) +evalLtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (<=) -evalGtEq :: SingleType a -> (a,a) :-> Bool -evalGtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (>=) -evalGtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (>=) -evalGtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (>=) +evalGtEq :: SingleType a -> (a,a) :-> PrimBool +evalGtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (>=) +evalGtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (>=) +evalGtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (>=) -evalEq :: SingleType a -> (a,a) :-> Bool -evalEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (==) -evalEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (==) -evalEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (==) +evalEq :: SingleType a -> (a,a) :-> PrimBool +evalEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (==) +evalEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (==) +evalEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (==) -evalNEq :: SingleType a -> (a,a) :-> Bool -evalNEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = eval2 (NonNumSingleType TypeBool) (/=) -evalNEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = eval2 (NonNumSingleType TypeBool) (/=) -evalNEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = eval2 (NonNumSingleType TypeBool) (/=) +evalNEq :: SingleType a -> (a,a) :-> PrimBool +evalNEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (/=) +evalNEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (/=) +evalNEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (/=) evalMax :: SingleType a -> (a,a) :-> a evalMax ty@(NumSingleType (IntegralNumType ty')) | IntegralDict <- integralDict ty' = eval2 ty max @@ -663,35 +690,39 @@ evalMin ty@(NonNumSingleType ty') | NonNumDict <- nonNumDict ty -- Logical operators -- ----------------- -evalLAnd :: (Bool,Bool) :-> Bool +evalLAnd :: (PrimBool,PrimBool) :-> PrimBool evalLAnd (untup2 -> Just (x,y)) env | Just a <- propagate env x - = Just $ if a then Stats.ruleFired "True &&" y - else Stats.ruleFired "False &&" $ Const scalarTypeBool False + = Just + $ if toBool a then Stats.ruleFired "True &&" y + else Stats.ruleFired "False &&" $ Const scalarTypeWord8 0 | Just b <- propagate env y - = Just $ if b then Stats.ruleFired "True &&" x - else Stats.ruleFired "False &&" $ Const scalarTypeBool False + = Just + $ if toBool b then Stats.ruleFired "True &&" x + else Stats.ruleFired "False &&" $ Const scalarTypeWord8 0 evalLAnd _ _ = Nothing -evalLOr :: (Bool,Bool) :-> Bool +evalLOr :: (PrimBool,PrimBool) :-> PrimBool evalLOr (untup2 -> Just (x,y)) env | Just a <- propagate env x - = Just $ if a then Stats.ruleFired "True ||" $ Const scalarTypeBool True + = Just + $ if toBool a then Stats.ruleFired "True ||" $ Const scalarTypeWord8 1 else Stats.ruleFired "False ||" y | Just b <- propagate env y - = Just $ if b then Stats.ruleFired "True ||" $ Const scalarTypeBool True + = Just + $ if toBool b then Stats.ruleFired "True ||" $ Const scalarTypeWord8 1 else Stats.ruleFired "False ||" x evalLOr _ _ = Nothing -evalLNot :: Bool :-> Bool +evalLNot :: PrimBool :-> PrimBool evalLNot x _ | PrimApp PrimLNot x' <- x = Stats.ruleFired "not/not" $ Just x' -evalLNot x env = eval1 (NonNumSingleType TypeBool) not x env +evalLNot x env = bool1 (not . toBool) x env evalOrd :: Char :-> Int evalOrd = eval1 (NumSingleType $ IntegralNumType $ TypeInt) ord @@ -699,9 +730,6 @@ evalOrd = eval1 (NumSingleType $ IntegralNumType $ TypeInt) ord evalChr :: Int :-> Char evalChr = eval1 (NonNumSingleType $ TypeChar) chr -evalBoolToInt :: Bool :-> Int -evalBoolToInt = eval1 (NumSingleType $ IntegralNumType $ TypeInt) fromEnum - evalFromIntegral :: IntegralType a -> NumType b -> a :-> b evalFromIntegral ta (IntegralNumType tb) | IntegralDict <- integralDict ta diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 6c4db1efb..457ed9bb5 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -1571,13 +1571,13 @@ aletD' _ _ lhs (Embed env1 cc1) (Embed env0 cc0) -- acondD :: MatchAcc OpenAcc -> EmbedAcc OpenAcc - -> Exp aenv Bool + -> Exp aenv PrimBool -> OpenAcc aenv arrs -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs acondD matchAcc embedAcc p t e - | Const _ True <- p = Stats.knownBranch "True" $ embedAcc t - | Const _ False <- p = Stats.knownBranch "False" $ embedAcc e + | Const _ 1 <- p = Stats.knownBranch "True" $ embedAcc t + | Const _ 0 <- p = Stats.knownBranch "False" $ embedAcc e | Just Refl <- matchAcc t e = Stats.knownBranch "redundant" $ embedAcc e | otherwise = done $ Acond p (computeAcc (embedAcc t)) (computeAcc (embedAcc e)) diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index c217ca464..9a342255a 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -260,13 +260,13 @@ simplifyOpenExp env = first getAny . cvtE -- Simplify conditional expressions, in particular by eliminating branches -- when the predicate is a known constant. -- - cond :: (Any, OpenExp env aenv Bool) + cond :: (Any, OpenExp env aenv PrimBool) -> (Any, OpenExp env aenv t) -> (Any, OpenExp env aenv t) -> (Any, OpenExp 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') + | Const _ 1 <- p' = Stats.knownBranch "True" (yes t') + | Const _ 0 <- p' = Stats.knownBranch "False" (yes e') | Just Refl <- matchOpenExp t' e' = Stats.knownBranch "redundant" (yes e') | otherwise = Cond <$> p <*> t <*> e @@ -584,7 +584,6 @@ summariseOpenExp = (terms +~ 1) . goE PrimLNot -> zero PrimOrd -> zero PrimChr -> zero - PrimBoolToInt -> zero PrimFromIntegral i n -> travIntegralType i +++ travNumType n PrimToFloating n f -> travNumType n +++ travFloatingType f diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index eabd342b5..ef68d6aad 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -24,7 +24,7 @@ -- Stability : experimental -- Portability : non-portable (GHC extensions) -- --- /Scalar types supported in array computations/ +-- Primitive scalar types supported by Accelerate -- -- Integral types: -- * Int @@ -42,12 +42,8 @@ -- * Half -- * Float -- * Double --- --- Non-numeric types: --- * Bool --- * Char --- --- SIMD vector types: + +-- SIMD vector types of the above: -- * Vec2 -- * Vec3 -- * Vec4 @@ -61,7 +57,7 @@ module Data.Array.Accelerate.Type ( - Half(..), Float, Double, Char, Bool(..), + Half(..), Float, Double, module Data.Int, module Data.Word, module Foreign.C.Types, @@ -139,8 +135,7 @@ data FloatingType a where -- | Non-numeric types supported in array computations. -- data NonNumType a where - TypeBool :: NonNumType Bool -- marshalled to Word8 - TypeChar :: NonNumType Char + TypeChar :: NonNumType Char -- | Numeric element types implement Num & Real -- @@ -185,8 +180,7 @@ instance Show (FloatingType a) where show TypeDouble = "Double" instance Show (NonNumType a) where - show TypeBool = "Bool" - show TypeChar = "Char" + show TypeChar = "Char" instance Show (NumType a) where show (IntegralNumType ty) = show ty @@ -261,7 +255,6 @@ floatingDict TypeFloat = FloatingDict floatingDict TypeDouble = FloatingDict nonNumDict :: NonNumType a -> NonNumDict a -nonNumDict TypeBool = NonNumDict nonNumDict TypeChar = NonNumDict singleDict :: SingleType a -> SingleDict a @@ -273,7 +266,6 @@ singleDict = single nonnum :: NonNumType a -> SingleDict a nonnum TypeChar = SingleDict - nonnum TypeBool = error "prim: We don't support vector of bools yet" num :: NumType a -> SingleDict a num (IntegralNumType t) = integral t @@ -297,12 +289,12 @@ singleDict = single floating TypeDouble = SingleDict -scalarTypeBool :: ScalarType Bool -scalarTypeBool = SingleScalarType $ NonNumSingleType TypeBool - scalarTypeInt :: ScalarType Int scalarTypeInt = SingleScalarType $ NumSingleType $ IntegralNumType TypeInt +scalarTypeWord :: ScalarType Word +scalarTypeWord = SingleScalarType $ NumSingleType $ IntegralNumType TypeWord + scalarTypeInt32 :: ScalarType Int32 scalarTypeInt32 = SingleScalarType $ NumSingleType $ IntegralNumType TypeInt32 @@ -332,8 +324,7 @@ rnfNumType (IntegralNumType t) = rnfIntegralType t rnfNumType (FloatingNumType t) = rnfFloatingType t rnfNonNumType :: NonNumType t -> () -rnfNonNumType TypeBool = () -rnfNonNumType TypeChar = () +rnfNonNumType TypeChar = () rnfIntegralType :: IntegralType t -> () rnfIntegralType TypeInt = () @@ -369,7 +360,6 @@ liftNum (IntegralNumType t) = liftIntegral t liftNum (FloatingNumType t) = liftFloating t liftNonNum :: NonNumType t -> t -> Q (TExp t) -liftNonNum TypeBool{} x = [|| x ||] liftNonNum TypeChar{} x = [|| x ||] liftIntegral :: IntegralType t -> t -> Q (TExp t) @@ -406,7 +396,6 @@ liftNumType (IntegralNumType t) = [|| IntegralNumType $$(liftIntegralType t) ||] liftNumType (FloatingNumType t) = [|| FloatingNumType $$(liftFloatingType t) ||] liftNonNumType :: NonNumType t -> Q (TExp (NonNumType t)) -liftNonNumType TypeBool{} = [|| TypeBool ||] liftNonNumType TypeChar{} = [|| TypeChar ||] liftBoundedType :: BoundedType t -> Q (TExp (BoundedType t)) @@ -477,12 +466,11 @@ $(runQ $ do nonNumTypes :: [(Name, Integer)] nonNumTypes = - [ (''Bool, 8) -- stored as Word8 - , (''Char, 32) + [ (''Char, 32) ] vectorTypes :: [(Name, Integer)] - vectorTypes = integralTypes ++ floatingTypes ++ tail nonNumTypes -- not Bool, no ArrayElt instances + vectorTypes = integralTypes ++ floatingTypes ++ nonNumTypes mkIntegral :: Name -> Integer -> Q [Dec] mkIntegral t n = From 6bbda493945c7dbcf0a3ebb048baf9ada85401c2 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 19 Jun 2020 16:01:28 +0200 Subject: [PATCH 249/316] wibble imports --- src/Data/Array/Accelerate/Data/Fold.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Fold.hs b/src/Data/Array/Accelerate/Data/Fold.hs index 3163d1df0..a37581cce 100644 --- a/src/Data/Array/Accelerate/Data/Fold.hs +++ b/src/Data/Array/Accelerate/Data/Fold.hs @@ -26,12 +26,19 @@ module Data.Array.Accelerate.Data.Fold ( ) where -import Data.Array.Accelerate hiding ( fold, sum, product, length ) +import Data.Array.Accelerate.Classes.Floating as A +import Data.Array.Accelerate.Classes.Fractional as A +import Data.Array.Accelerate.Classes.Num as A import Data.Array.Accelerate.Data.Monoid -import qualified Data.Array.Accelerate as A +import Data.Array.Accelerate.Language as A +import Data.Array.Accelerate.Lift +import Data.Array.Accelerate.Smart ( Acc, Exp, constant ) +import Data.Array.Accelerate.Sugar.Array +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape -import Control.Applicative as P import Prelude hiding ( sum, product, length ) +import Control.Applicative as P import qualified Prelude as P From ba422058852e68a75682307c122d71fbf52dac3b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 19 Jun 2020 16:42:24 +0200 Subject: [PATCH 250/316] remove non-numeric types from the core --- src/Data/Array/Accelerate/AST.hs | 14 --- src/Data/Array/Accelerate/Analysis/Hash.hs | 15 +-- src/Data/Array/Accelerate/Analysis/Match.hs | 17 +-- src/Data/Array/Accelerate/Analysis/Type.hs | 7 +- src/Data/Array/Accelerate/Array/Data.hs | 18 +-- src/Data/Array/Accelerate/Data/Complex.hs | 6 +- src/Data/Array/Accelerate/Interpreter.hs | 37 +----- src/Data/Array/Accelerate/Language.hs | 4 +- src/Data/Array/Accelerate/Pretty/Print.hs | 2 - .../Array/Accelerate/Representation/Elt.hs | 19 +-- .../Array/Accelerate/Representation/Type.hs | 6 +- src/Data/Array/Accelerate/Smart.hs | 10 +- src/Data/Array/Accelerate/Sugar/Elt.hs | 15 ++- src/Data/Array/Accelerate/Trafo/Algebra.hs | 19 --- src/Data/Array/Accelerate/Trafo/Simplify.hs | 9 +- src/Data/Array/Accelerate/Type.hs | 111 ++++-------------- 16 files changed, 51 insertions(+), 258 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index ef6e4b9a3..7e9eba3f8 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -722,10 +722,6 @@ data PrimFun sig where PrimLOr :: PrimFun ((PrimBool, PrimBool) -> PrimBool) PrimLNot :: PrimFun (PrimBool -> PrimBool) - -- character conversions - PrimOrd :: PrimFun (Char -> Int) - PrimChr :: PrimFun (Int -> Char) - -- general conversion between types PrimFromIntegral :: IntegralType a -> NumType b -> PrimFun (a -> b) PrimToFloating :: NumType a -> FloatingType b -> PrimFun (a -> b) @@ -816,7 +812,6 @@ primConstType = \case where bounded :: BoundedType a -> SingleType a bounded (IntegralBoundedType t) = NumSingleType $ IntegralNumType t - bounded (NonNumBoundedType t) = NonNumSingleType t floating :: FloatingType t -> SingleType t floating = NumSingleType . FloatingNumType @@ -899,10 +894,6 @@ primFunType = \case PrimLOr -> binary' bool PrimLNot -> unary' bool - -- character conversions - PrimOrd -> unary char int - PrimChr -> unary int char - -- general conversion between types PrimFromIntegral a b -> unary (integral a) (num b) PrimToFloating a b -> unary (num a) (floating b) @@ -921,7 +912,6 @@ primFunType = \case bool = TupRsingle scalarTypeWord8 int = TupRsingle scalarTypeInt - char = TupRsingle $ SingleScalarType $ NonNumSingleType TypeChar -- Normal form data @@ -1134,8 +1124,6 @@ rnfPrimFun (PrimMin t) = rnfSingleType t rnfPrimFun PrimLAnd = () rnfPrimFun PrimLOr = () rnfPrimFun PrimLNot = () -rnfPrimFun PrimOrd = () -rnfPrimFun PrimChr = () rnfPrimFun (PrimFromIntegral i n) = rnfIntegralType i `seq` rnfNumType n rnfPrimFun (PrimToFloating n f) = rnfNumType n `seq` rnfFloatingType f @@ -1346,8 +1334,6 @@ liftPrimFun (PrimMin t) = [|| PrimMin $$(liftSingleType t) ||] liftPrimFun PrimLAnd = [|| PrimLAnd ||] liftPrimFun PrimLOr = [|| PrimLOr ||] liftPrimFun PrimLNot = [|| PrimLNot ||] -liftPrimFun PrimOrd = [|| PrimOrd ||] -liftPrimFun PrimChr = [|| PrimChr ||] liftPrimFun (PrimFromIntegral ta tb) = [|| PrimFromIntegral $$(liftIntegralType ta) $$(liftNumType tb) ||] liftPrimFun (PrimToFloating ta tb) = [|| PrimToFloating $$(liftNumType ta) $$(liftFloatingType tb) ||] diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 3f79ec1b2..98f880293 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -360,15 +360,11 @@ encodeScalarConst (SingleScalarType t) = encodeSingleConst t encodeScalarConst (VectorScalarType t) = encodeVectorConst t encodeSingleConst :: SingleType t -> t -> Builder -encodeSingleConst (NumSingleType t) = encodeNumConst t -encodeSingleConst (NonNumSingleType t) = encodeNonNumConst t +encodeSingleConst (NumSingleType t) = encodeNumConst t encodeVectorConst :: VectorType (Vec n t) -> Vec n t -> Builder encodeVectorConst (VectorType n t) (Vec ba#) = intHost $(hashQ "Vec") <> intHost n <> encodeSingleType t <> shortByteString (SBS ba#) -encodeNonNumConst :: NonNumType t -> t -> Builder -encodeNonNumConst TypeChar{} x = intHost $(hashQ "Char") <> charUtf8 x - encodeNumConst :: NumType t -> t -> Builder encodeNumConst (IntegralNumType t) = encodeIntegralConst t encodeNumConst (FloatingNumType t) = encodeFloatingConst t @@ -458,8 +454,6 @@ encodePrimFun (PrimToFloating a b) = intHost $(hashQ "PrimToFloating") 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") encodeTypeR :: TypeR t -> Builder @@ -478,18 +472,13 @@ encodeScalarType (SingleScalarType t) = intHost $(hashQ "SingleScalarType") <> e encodeScalarType (VectorScalarType t) = intHost $(hashQ "VectorScalarType") <> encodeVectorType t encodeSingleType :: SingleType t -> Builder -encodeSingleType (NumSingleType t) = intHost $(hashQ "NumSingleType") <> encodeNumType t -encodeSingleType (NonNumSingleType t) = intHost $(hashQ "NonNumSingleType") <> encodeNonNumType t +encodeSingleType (NumSingleType t) = intHost $(hashQ "NumSingleType") <> encodeNumType t encodeVectorType :: VectorType (Vec n t) -> Builder encodeVectorType (VectorType n t) = intHost $(hashQ "VectorType") <> intHost n <> encodeSingleType t encodeBoundedType :: BoundedType t -> Builder encodeBoundedType (IntegralBoundedType t) = intHost $(hashQ "IntegralBoundedType") <> encodeIntegralType t -encodeBoundedType (NonNumBoundedType t) = intHost $(hashQ "NonNumBoundedType") <> encodeNonNumType t - -encodeNonNumType :: NonNumType t -> Builder -encodeNonNumType TypeChar{} = intHost $(hashQ "Char") encodeNumType :: NumType t -> Builder encodeNumType (IntegralNumType t) = intHost $(hashQ "IntegralNumType") <> encodeIntegralType t diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index 1e8ce048e..3a9dd9d14 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -572,8 +572,7 @@ 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 (==) +evalEqSingle (NumSingleType t) = evalEqNum t evalEqVector :: VectorType a -> (a, a) -> Bool evalEqVector VectorType{} = uncurry (==) @@ -698,8 +697,6 @@ matchPrimFun (PrimToFloating _ s) (PrimToFloating _ t) = matchFloati 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 _ _ = Nothing @@ -765,8 +762,6 @@ matchPrimFun' (PrimToFloating s _) (PrimToFloating t _) = matchNumTy 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' (PrimLt s) (PrimLt t) | Just Refl <- matchSingleType s t @@ -842,9 +837,7 @@ 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 +matchSingleType (NumSingleType s) (NumSingleType t) = matchNumType s t {-# INLINEABLE matchVectorType #-} matchVectorType :: forall m n s t. VectorType (Vec n s) -> VectorType (Vec m t) -> Maybe (Vec n s :~: Vec m t) @@ -866,8 +859,6 @@ 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) @@ -890,10 +881,6 @@ matchFloatingType TypeFloat TypeFloat = Just Refl matchFloatingType TypeDouble TypeDouble = Just Refl matchFloatingType _ _ = Nothing -{-# INLINEABLE matchNonNumType #-} -matchNonNumType :: NonNumType s -> NonNumType t -> Maybe (s :~: t) -matchNonNumType TypeChar TypeChar = Just Refl - -- Auxiliary -- --------- diff --git a/src/Data/Array/Accelerate/Analysis/Type.hs b/src/Data/Array/Accelerate/Analysis/Type.hs index 6528ce585..c0043bae6 100644 --- a/src/Data/Array/Accelerate/Analysis/Type.hs +++ b/src/Data/Array/Accelerate/Analysis/Type.hs @@ -31,7 +31,6 @@ module Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType, sizeOfVectorType, sizeOfNumType, - sizeOfNonNumType, ) where @@ -62,8 +61,7 @@ sizeOfScalarType (SingleScalarType t) = sizeOfSingleType t sizeOfScalarType (VectorScalarType t) = sizeOfVectorType t sizeOfSingleType :: SingleType t -> Int -sizeOfSingleType (NumSingleType t) = sizeOfNumType t -sizeOfSingleType (NonNumSingleType t) = sizeOfNonNumType t +sizeOfSingleType (NumSingleType t) = sizeOfNumType t sizeOfVectorType :: VectorType t -> Int sizeOfVectorType (VectorType n t) = n * sizeOfSingleType t @@ -72,6 +70,3 @@ 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 t | NonNumDict <- nonNumDict t = F.sizeOf (undefined::t) - diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 373566717..aa1ed0c4f 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -138,17 +138,13 @@ scalarArrayDict = scalar scalar (VectorScalarType t) = vector t single :: SingleType a -> ScalarArrayDict a - single (NumSingleType t) = num t - single (NonNumSingleType t) = nonnum t + single (NumSingleType t) = num t vector :: VectorType a -> ScalarArrayDict a vector (VectorType _ s) | ScalarArrayDict <- single s = ScalarArrayDict - nonnum :: NonNumType a -> ScalarArrayDict a - nonnum TypeChar = ScalarArrayDict - num :: NumType a -> ScalarArrayDict a num (IntegralNumType t) = integral t num (FloatingNumType t) = floating t @@ -175,11 +171,7 @@ singleArrayDict :: SingleType a -> SingleArrayDict a singleArrayDict = single where single :: SingleType a -> SingleArrayDict a - single (NumSingleType t) = num t - single (NonNumSingleType t) = nonnum t - - nonnum :: NonNumType a -> SingleArrayDict a - nonnum TypeChar = SingleArrayDict + single (NumSingleType t) = num t num :: NumType a -> SingleArrayDict a num (IntegralNumType t) = integral t @@ -370,16 +362,12 @@ liftArrayData n = tuple = liftArrayData (w * n) (TupRsingle (SingleScalarType t)) single :: SingleType e -> ArrayData e -> Q (TExp (ArrayData e)) - single (NumSingleType t) = num t - single (NonNumSingleType t) = nonnum t + single (NumSingleType t) = num t num :: NumType e -> ArrayData e -> Q (TExp (ArrayData e)) num (IntegralNumType t) = integral t num (FloatingNumType t) = floating t - nonnum :: NonNumType e -> ArrayData e -> Q (TExp (ArrayData e)) - nonnum = undefined - integral :: IntegralType e -> ArrayData e -> Q (TExp (ArrayData e)) integral TypeInt = liftUniqueArray n integral TypeInt8 = liftUniqueArray n diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index c2cf1107e..494a2d678 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -135,11 +135,7 @@ complexR = tuple scalar VectorScalarType{} = ComplexTup single :: SingleType a -> ComplexType a (ComplexR a) - single (NumSingleType t) = num t - single (NonNumSingleType t) = nonnum t - - nonnum :: NonNumType a -> ComplexType a (ComplexR a) - nonnum TypeChar = ComplexTup + single (NumSingleType t) = num t num :: NumType a -> ComplexType a (ComplexR a) num (IntegralNumType t) = integral t diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index a20b48c71..e70e58c5a 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -71,7 +71,6 @@ import Control.Exception import Control.Monad import Control.Monad.ST import Data.Bits -import Data.Char ( chr, ord ) import Data.Primitive.ByteArray import Data.Primitive.Types import System.IO.Unsafe ( unsafePerformIO ) @@ -980,8 +979,7 @@ evalCoerceScalar VectorScalarType{} VectorScalarType{} a = unsafeCoerce a -- evalCoerceScalar (SingleScalarType ta) VectorScalarType{} a = vector ta a where vector :: SingleType a -> a -> Vec n b - vector (NumSingleType t) = num t - vector (NonNumSingleType t) = nonnum t + vector (NumSingleType t) = num t num :: NumType a -> a -> Vec n b num (IntegralNumType t) = integral t @@ -1004,9 +1002,6 @@ evalCoerceScalar (SingleScalarType ta) VectorScalarType{} a = vector ta a floating TypeFloat{} = poke floating TypeDouble{} = poke - nonnum :: NonNumType a -> a -> Vec n b - nonnum TypeChar{} = poke - {-# INLINE poke #-} poke :: forall a b n. Prim a => a -> Vec n b poke x = runST $ do @@ -1018,8 +1013,7 @@ evalCoerceScalar (SingleScalarType ta) VectorScalarType{} a = vector ta a evalCoerceScalar VectorScalarType{} (SingleScalarType tb) a = scalar tb a where scalar :: SingleType b -> Vec n a -> b - scalar (NumSingleType t) = num t - scalar (NonNumSingleType t) = nonnum t + scalar (NumSingleType t) = num t num :: NumType b -> Vec n a -> b num (IntegralNumType t) = integral t @@ -1042,9 +1036,6 @@ evalCoerceScalar VectorScalarType{} (SingleScalarType tb) a = scalar tb a floating TypeFloat{} = peek floating TypeDouble{} = peek - nonnum :: NonNumType b -> Vec n a -> b - nonnum TypeChar{} = peek - {-# INLINE peek #-} peek :: Prim a => Vec n b -> a peek (Vec ba#) = indexByteArray (ByteArray ba#) 0 @@ -1119,8 +1110,6 @@ evalPrim (PrimMin ty) = evalMin ty evalPrim PrimLAnd = evalLAnd evalPrim PrimLOr = evalLOr evalPrim PrimLNot = evalLNot -evalPrim PrimOrd = evalOrd -evalPrim PrimChr = evalChr evalPrim (PrimFromIntegral ta tb) = evalFromIntegral ta tb evalPrim (PrimToFloating ta tb) = evalToFloating ta tb @@ -1145,12 +1134,6 @@ evalLOr (x, y) = fromBool (toBool x || toBool y) evalLNot :: PrimBool -> PrimBool evalLNot = fromBool . not . toBool -evalOrd :: Char -> Int -evalOrd = ord - -evalChr :: Int -> Char -evalChr = chr - evalFromIntegral :: IntegralType a -> NumType b -> a -> b evalFromIntegral ta (IntegralNumType tb) | IntegralDict <- integralDict ta @@ -1185,19 +1168,11 @@ 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 -- @@ -1400,42 +1375,34 @@ evalRecip ty | FloatingDict <- floatingDict ty = recip evalLt :: SingleType a -> ((a, a) -> PrimBool) evalLt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (<) evalLt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (<) -evalLt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . uncurry (<) evalGt :: SingleType a -> ((a, a) -> PrimBool) evalGt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (>) evalGt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (>) -evalGt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . uncurry (>) evalLtEq :: SingleType a -> ((a, a) -> PrimBool) evalLtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (<=) evalLtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (<=) -evalLtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . uncurry (<=) evalGtEq :: SingleType a -> ((a, a) -> PrimBool) evalGtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (>=) evalGtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (>=) -evalGtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . uncurry (>=) evalEq :: SingleType a -> ((a, a) -> PrimBool) evalEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (==) evalEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (==) -evalEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . uncurry (==) evalNEq :: SingleType a -> ((a, a) -> PrimBool) evalNEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = fromBool . uncurry (/=) evalNEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = fromBool . uncurry (/=) -evalNEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = fromBool . 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 {-- diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index c1d0fc8d4..70fe07281 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1493,12 +1493,12 @@ x ^^ n -- |Convert a character to an 'Int'. -- ord :: Exp Char -> Exp Int -ord = mkOrd +ord = mkCoerce -- |Convert an 'Int' into a character. -- chr :: Exp Int -> Exp Char -chr = mkChr +chr = mkCoerce -- |Convert a Boolean value to an 'Int', where 'False' turns into '0' and 'True' -- into '1'. diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 1d1c81d2e..f27ed3635 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -659,8 +659,6 @@ primOperator PrimMin{} = Operator "min" App L 1 primOperator PrimLAnd = Operator "&&" Infix R 3 primOperator PrimLOr = Operator "||" Infix R 2 primOperator PrimLNot = Operator "not" App L 10 -primOperator PrimOrd = Operator "ord" App L 10 -primOperator PrimChr = Operator "chr" App L 10 primOperator PrimFromIntegral{} = Operator "fromIntegral" App L 10 primOperator PrimToFloating{} = Operator "toFloating" App L 10 diff --git a/src/Data/Array/Accelerate/Representation/Elt.hs b/src/Data/Array/Accelerate/Representation/Elt.hs index ce717520e..478a65206 100644 --- a/src/Data/Array/Accelerate/Representation/Elt.hs +++ b/src/Data/Array/Accelerate/Representation/Elt.hs @@ -21,7 +21,6 @@ import Data.Array.Accelerate.Type import Data.Primitive.Vec import Control.Monad.ST -import Data.Char import Data.List ( intercalate ) import Data.Primitive.ByteArray import Foreign.Storable @@ -47,11 +46,7 @@ undefElt = tuple return (Vec ba#) single :: SingleType t -> t - single (NumSingleType t) = num t - single (NonNumSingleType t) = nonnum t - - nonnum :: NonNumType t -> t - nonnum TypeChar = chr 0 + single (NumSingleType t) = num t num :: NumType t -> t num (IntegralNumType t) = integral t @@ -90,11 +85,7 @@ bytesElt = tuple vector (VectorType n t) = n * single t single :: SingleType t -> Int - single (NumSingleType t) = num t - single (NonNumSingleType t) = nonnum t - - nonnum :: NonNumType t -> Int - nonnum TypeChar = sizeOf (undefined::Char) + single (NumSingleType t) = num t num :: NumType t -> Int num (IntegralNumType t) = integral t @@ -133,8 +124,7 @@ showsElt = tuple scalar (VectorScalarType t) e = showString $ vector t e single :: SingleType e -> e -> String - single (NumSingleType t) e = num t e - single (NonNumSingleType t) e = nonnum t e + single (NumSingleType t) e = num t e num :: NumType e -> e -> String num (IntegralNumType t) e = integral t e @@ -157,9 +147,6 @@ showsElt = tuple floating TypeFloat e = show e floating TypeDouble e = show e - nonnum :: NonNumType e -> e -> String - nonnum TypeChar e = show e - vector :: VectorType (Vec n a) -> Vec n a -> String vector (VectorType _ s) vec | SingleDict <- singleDict s diff --git a/src/Data/Array/Accelerate/Representation/Type.hs b/src/Data/Array/Accelerate/Representation/Type.hs index 8cee6c724..f0d8d974e 100644 --- a/src/Data/Array/Accelerate/Representation/Type.hs +++ b/src/Data/Array/Accelerate/Representation/Type.hs @@ -81,11 +81,7 @@ liftTypeQ = tuple vector (VectorType n t) = [t| Vec $(litT (numTyLit (toInteger n))) $(single t) |] single :: SingleType t -> TypeQ - single (NumSingleType t) = num t - single (NonNumSingleType t) = nonnum t - - nonnum :: NonNumType t -> TypeQ - nonnum TypeChar = [t| Char |] + single (NumSingleType t) = num t num :: NumType t -> TypeQ num (IntegralNumType t) = integral t diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 26e3368d2..09a2c8b65 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -66,7 +66,7 @@ module Data.Array.Accelerate.Smart ( mkLAnd, mkLOr, mkLNot, mkIsNaN, mkIsInfinite, -- ** Smart constructors for type coercion functions - mkOrd, mkChr, mkFromIntegral, mkToFloating, mkBitcast, mkCoerce, Coerce(..), + mkFromIntegral, mkToFloating, mkBitcast, mkCoerce, Coerce(..), -- ** Auxiliary functions ($$), ($$$), ($$$$), ($$$$$), @@ -1150,14 +1150,6 @@ mkLNot (Exp a) = mkExp $ SmartExp (PrimApp PrimLNot x) `Pair` SmartExp Nil where x = SmartExp $ Prj PairIdxLeft a --- Character conversions - -mkOrd :: Exp Char -> Exp Int -mkOrd = mkPrimUnary PrimOrd - -mkChr :: Exp Int -> Exp Char -mkChr = mkPrimUnary PrimChr - -- Numeric conversions mkFromIntegral :: (Elt a, Elt b, IsIntegral (EltR a), IsNum (EltR b)) => Exp a -> Exp b diff --git a/src/Data/Array/Accelerate/Sugar/Elt.hs b/src/Data/Array/Accelerate/Sugar/Elt.hs index d692c687c..16c6eb1ad 100644 --- a/src/Data/Array/Accelerate/Sugar/Elt.hs +++ b/src/Data/Array/Accelerate/Sugar/Elt.hs @@ -30,6 +30,7 @@ import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type import Data.Bits +import Data.Char import Data.Kind import Language.Haskell.TH hiding ( Type ) import Language.Haskell.TH.Extra @@ -299,6 +300,13 @@ untag (TupRpair ta tb) = TagRpair (untag ta) (untag tb) instance Elt () instance Elt Bool +instance Elt Char where + type EltR Char = Int + eltR = TupRsingle scalarType + tagsR = [TagRsingle scalarType] + toElt = chr + fromElt = ord + runQ $ do let -- XXX: we might want to do the digItOut trick used by FromIntegral? @@ -324,11 +332,6 @@ runQ $ do , ''Double ] - nonNumTypes :: [Name] - nonNumTypes = - [ ''Char - ] - newtypes :: [Name] newtypes = [ ''CShort @@ -398,7 +401,7 @@ runQ $ do toElt = $(conE (mkName (nameBase name))) |] -- - ss <- mapM mkSimple (integralTypes ++ floatingTypes ++ nonNumTypes) + ss <- mapM mkSimple (integralTypes ++ floatingTypes) ns <- mapM mkNewtype newtypes ts <- mapM mkTuple [2..16] -- vs <- sequence [ mkVecElt t n | t <- integralTypes ++ floatingTypes, n <- [2,3,4,8,16] ] diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index 915790efa..8a7191a10 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -38,7 +38,6 @@ import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Debug.Stats as Stats import Data.Bits -import Data.Char import Data.Monoid import Data.Text ( Text ) import Data.Text.Prettyprint.Doc @@ -147,8 +146,6 @@ evalPrimApp env f x PrimLAnd -> evalLAnd x env PrimLOr -> evalLOr x env PrimLNot -> evalLNot x env - PrimOrd -> evalOrd x env - PrimChr -> evalChr x env PrimFromIntegral ta tb -> evalFromIntegral ta tb x env PrimToFloating ta tb -> evalToFloating ta tb x env @@ -650,42 +647,34 @@ evalIsInfinite ty | FloatingDict <- floatingDict ty = bool1 isInfinite evalLt :: SingleType a -> (a,a) :-> PrimBool evalLt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (<) evalLt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (<) -evalLt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (<) evalGt :: SingleType a -> (a,a) :-> PrimBool evalGt (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (>) evalGt (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (>) -evalGt (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (>) evalLtEq :: SingleType a -> (a,a) :-> PrimBool evalLtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (<=) evalLtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (<=) -evalLtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (<=) evalGtEq :: SingleType a -> (a,a) :-> PrimBool evalGtEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (>=) evalGtEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (>=) -evalGtEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (>=) evalEq :: SingleType a -> (a,a) :-> PrimBool evalEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (==) evalEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (==) -evalEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (==) evalNEq :: SingleType a -> (a,a) :-> PrimBool evalNEq (NumSingleType (IntegralNumType ty)) | IntegralDict <- integralDict ty = bool2 (/=) evalNEq (NumSingleType (FloatingNumType ty)) | FloatingDict <- floatingDict ty = bool2 (/=) -evalNEq (NonNumSingleType ty) | NonNumDict <- nonNumDict ty = bool2 (/=) evalMax :: SingleType a -> (a,a) :-> a evalMax ty@(NumSingleType (IntegralNumType ty')) | IntegralDict <- integralDict ty' = eval2 ty max evalMax ty@(NumSingleType (FloatingNumType ty')) | FloatingDict <- floatingDict ty' = eval2 ty max -evalMax ty@(NonNumSingleType ty') | NonNumDict <- nonNumDict ty' = eval2 ty max evalMin :: SingleType a -> (a,a) :-> a evalMin ty@(NumSingleType (IntegralNumType ty')) | IntegralDict <- integralDict ty' = eval2 ty min evalMin ty@(NumSingleType (FloatingNumType ty')) | FloatingDict <- floatingDict ty' = eval2 ty min -evalMin ty@(NonNumSingleType ty') | NonNumDict <- nonNumDict ty' = eval2 ty min -- Logical operators -- ----------------- @@ -724,12 +713,6 @@ evalLNot :: PrimBool :-> PrimBool evalLNot x _ | PrimApp PrimLNot x' <- x = Stats.ruleFired "not/not" $ Just x' evalLNot x env = bool1 (not . toBool) x env -evalOrd :: Char :-> Int -evalOrd = eval1 (NumSingleType $ IntegralNumType $ TypeInt) ord - -evalChr :: Int :-> Char -evalChr = eval1 (NonNumSingleType $ TypeChar) chr - evalFromIntegral :: IntegralType a -> NumType b -> a :-> b evalFromIntegral ta (IntegralNumType tb) | IntegralDict <- integralDict ta @@ -774,11 +757,9 @@ 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 diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index 9a342255a..af1e9596c 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -457,9 +457,6 @@ summariseOpenExp = (terms +~ 1) . goE 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 @@ -472,15 +469,13 @@ summariseOpenExp = (terms +~ 1) . goE 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 + travSingleType (NumSingleType t) = travNumType t & types +~ 1 -- travVectorType :: VectorType t -> Stats -- travVectorType (Vector2Type t) = travSingleType t & types +~ 1 @@ -582,8 +577,6 @@ summariseOpenExp = (terms +~ 1) . goE PrimLAnd -> zero PrimLOr -> zero PrimLNot -> zero - PrimOrd -> zero - PrimChr -> zero PrimFromIntegral i n -> travIntegralType i +++ travNumType n PrimToFloating n f -> travNumType n +++ travFloatingType f diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index ef68d6aad..51b2bb8c1 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -42,7 +42,7 @@ -- * Half -- * Float -- * Double - +-- -- SIMD vector types of the above: -- * Vec2 -- * Vec3 @@ -103,10 +103,6 @@ data FloatingDict a where , 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 -- @@ -132,11 +128,6 @@ data FloatingType a where TypeFloat :: FloatingType Float TypeDouble :: FloatingType Double --- | Non-numeric types supported in array computations. --- -data NonNumType a where - TypeChar :: NonNumType Char - -- | Numeric element types implement Num & Real -- data NumType a where @@ -147,7 +138,6 @@ data NumType a where -- data BoundedType a where IntegralBoundedType :: IntegralType a -> BoundedType a - NonNumBoundedType :: NonNumType a -> BoundedType a -- | All scalar element types implement Eq & Ord -- @@ -156,31 +146,27 @@ data ScalarType a where VectorScalarType :: VectorType (Vec n a) -> ScalarType (Vec n a) data SingleType a where - NumSingleType :: NumType a -> SingleType a - NonNumSingleType :: NonNumType a -> SingleType a + NumSingleType :: NumType a -> SingleType a data VectorType a where - VectorType :: KnownNat n => {-# UNPACK #-} !Int -> SingleType a -> VectorType (Vec n a) + VectorType :: KnownNat n => {-# UNPACK #-} !Int -> SingleType a -> VectorType (Vec n a) 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 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" instance Show (FloatingType a) where - show TypeHalf = "Half" - show TypeFloat = "Float" - show TypeDouble = "Double" - -instance Show (NonNumType a) where - show TypeChar = "Char" + show TypeHalf = "Half" + show TypeFloat = "Float" + show TypeDouble = "Double" instance Show (NumType a) where show (IntegralNumType ty) = show ty @@ -188,14 +174,12 @@ instance Show (NumType a) where 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 + show (NumSingleType ty) = show ty instance Show (VectorType a) where - show (VectorType n ty) = printf "<%d x %s>" n (show ty) + show (VectorType n ty) = printf "<%d x %s>" n (show ty) instance Show (ScalarType a) where show (SingleScalarType ty) = show ty @@ -211,11 +195,6 @@ class (IsSingle a, IsNum a, IsBounded a) => IsIntegral a where class (Floating a, IsSingle a, IsNum a) => IsFloating a where floatingType :: FloatingType a --- | Querying Non-numeric types --- -class IsNonNum a where - nonNumType :: NonNumType a - -- | Querying Numeric types -- class (Num a, IsSingle a) => IsNum a where @@ -254,18 +233,11 @@ floatingDict TypeHalf = FloatingDict floatingDict TypeFloat = FloatingDict floatingDict TypeDouble = FloatingDict -nonNumDict :: NonNumType a -> NonNumDict a -nonNumDict TypeChar = NonNumDict - singleDict :: SingleType a -> SingleDict a singleDict = single where single :: SingleType a -> SingleDict a single (NumSingleType t) = num t - single (NonNumSingleType t) = nonnum t - - nonnum :: NonNumType a -> SingleDict a - nonnum TypeChar = SingleDict num :: NumType a -> SingleDict a num (IntegralNumType t) = integral t @@ -309,23 +281,18 @@ rnfScalarType (SingleScalarType t) = rnfSingleType t rnfScalarType (VectorScalarType t) = rnfVectorType t rnfSingleType :: SingleType t -> () -rnfSingleType (NumSingleType t) = rnfNumType t -rnfSingleType (NonNumSingleType t) = rnfNonNumType t +rnfSingleType (NumSingleType t) = rnfNumType t rnfVectorType :: VectorType t -> () rnfVectorType (VectorType !_ 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 TypeChar = () - rnfIntegralType :: IntegralType t -> () rnfIntegralType TypeInt = () rnfIntegralType TypeInt8 = () @@ -349,8 +316,7 @@ liftScalar (SingleScalarType t) = liftSingle t liftScalar (VectorScalarType t) = liftVector t liftSingle :: SingleType t -> t -> Q (TExp t) -liftSingle (NumSingleType t) = liftNum t -liftSingle (NonNumSingleType t) = liftNonNum t +liftSingle (NumSingleType t) = liftNum t liftVector :: VectorType t -> t -> Q (TExp t) liftVector VectorType{} = liftVec @@ -359,9 +325,6 @@ liftNum :: NumType t -> t -> Q (TExp t) liftNum (IntegralNumType t) = liftIntegral t liftNum (FloatingNumType t) = liftFloating t -liftNonNum :: NonNumType t -> t -> Q (TExp t) -liftNonNum TypeChar{} x = [|| x ||] - liftIntegral :: IntegralType t -> t -> Q (TExp t) liftIntegral TypeInt{} x = [|| x ||] liftIntegral TypeInt8{} x = [|| x ||] @@ -385,8 +348,7 @@ 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) ||] +liftSingleType (NumSingleType t) = [|| NumSingleType $$(liftNumType t) ||] liftVectorType :: VectorType t -> Q (TExp (VectorType t)) liftVectorType (VectorType n t) = [|| VectorType n $$(liftSingleType t) ||] @@ -395,12 +357,8 @@ liftNumType :: NumType t -> Q (TExp (NumType t)) liftNumType (IntegralNumType t) = [|| IntegralNumType $$(liftIntegralType t) ||] liftNumType (FloatingNumType t) = [|| FloatingNumType $$(liftFloatingType t) ||] -liftNonNumType :: NonNumType t -> Q (TExp (NonNumType t)) -liftNonNumType TypeChar{} = [|| TypeChar ||] - liftBoundedType :: BoundedType t -> Q (TExp (BoundedType t)) liftBoundedType (IntegralBoundedType t) = [|| IntegralBoundedType $$(liftIntegralType t) ||] -liftBoundedType (NonNumBoundedType t) = [|| NonNumBoundedType $$(liftNonNumType t) ||] liftIntegralType :: IntegralType t -> Q (TExp (IntegralType t)) liftIntegralType TypeInt{} = [|| TypeInt ||] @@ -464,13 +422,8 @@ $(runQ $ do , (''Double, 64) ] - nonNumTypes :: [(Name, Integer)] - nonNumTypes = - [ (''Char, 32) - ] - vectorTypes :: [(Name, Integer)] - vectorTypes = integralTypes ++ floatingTypes ++ nonNumTypes + vectorTypes = integralTypes ++ floatingTypes mkIntegral :: Name -> Integer -> Q [Dec] mkIntegral t n = @@ -509,23 +462,6 @@ $(runQ $ do 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))) - - 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 KnownNat n => IsScalar (Vec n $(conT t)) where @@ -536,9 +472,8 @@ $(runQ $ do -- is <- mapM (uncurry mkIntegral) integralTypes fs <- mapM (uncurry mkFloating) floatingTypes - ns <- mapM (uncurry mkNonNum) nonNumTypes vs <- mapM (uncurry mkVector) vectorTypes -- - return (concat is ++ concat fs ++ concat ns ++ concat vs) + return (concat is ++ concat fs ++ concat vs) ) From 199a49c3144ae7bedf0aea3e2e8cf8c5d9d9b9c7 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 19 Jun 2020 17:04:10 +0200 Subject: [PATCH 251/316] remove obsolete modules --- accelerate.cabal | 3 --- {src/Data/Array/Accelerate => icebox}/Analysis/Shape.hs | 0 {src/Data/Array/Accelerate => icebox}/Analysis/Stencil.hs | 0 {src/Data/Array/Accelerate => icebox}/Analysis/Type.hs | 0 src/Data/Array/Accelerate/Array/Remote/LRU.hs | 5 +++-- 5 files changed, 3 insertions(+), 5 deletions(-) rename {src/Data/Array/Accelerate => icebox}/Analysis/Shape.hs (100%) rename {src/Data/Array/Accelerate => icebox}/Analysis/Stencil.hs (100%) rename {src/Data/Array/Accelerate => icebox}/Analysis/Type.hs (100%) diff --git a/accelerate.cabal b/accelerate.cabal index fb6fdeaef..e401b4254 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -321,9 +321,6 @@ Library Data.Array.Accelerate.AST.Var Data.Array.Accelerate.Analysis.Hash Data.Array.Accelerate.Analysis.Match - Data.Array.Accelerate.Analysis.Shape - Data.Array.Accelerate.Analysis.Stencil - Data.Array.Accelerate.Analysis.Type Data.Array.Accelerate.Array.Data Data.Array.Accelerate.Array.Remote Data.Array.Accelerate.Array.Remote.Class diff --git a/src/Data/Array/Accelerate/Analysis/Shape.hs b/icebox/Analysis/Shape.hs similarity index 100% rename from src/Data/Array/Accelerate/Analysis/Shape.hs rename to icebox/Analysis/Shape.hs diff --git a/src/Data/Array/Accelerate/Analysis/Stencil.hs b/icebox/Analysis/Stencil.hs similarity index 100% rename from src/Data/Array/Accelerate/Analysis/Stencil.hs rename to icebox/Analysis/Stencil.hs diff --git a/src/Data/Array/Accelerate/Analysis/Type.hs b/icebox/Analysis/Type.hs similarity index 100% rename from src/Data/Array/Accelerate/Analysis/Type.hs rename to icebox/Analysis/Type.hs diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs index c5b884cd2..858594079 100644 --- a/src/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/src/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -38,12 +38,13 @@ module Data.Array.Accelerate.Array.Remote.LRU ( ) where import Data.Array.Accelerate.Analysis.Match ( matchSingleType, (:~:)(..) ) -import Data.Array.Accelerate.Analysis.Type ( sizeOfSingleType ) import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Array.Remote.Class import Data.Array.Accelerate.Array.Remote.Table ( StableArray, makeWeakArrayData ) import Data.Array.Accelerate.Array.Unique ( touchUniqueArray ) import Data.Array.Accelerate.Error ( internalError ) +import Data.Array.Accelerate.Representation.Elt +import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Array.Remote.Table as Basic import qualified Data.Array.Accelerate.Debug as D @@ -311,7 +312,7 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do eldest prev _ = return prev remoteBytes :: SingleType e -> Int -> Int64 - remoteBytes tp n = fromIntegral (sizeOfSingleType tp) * fromIntegral n + remoteBytes tp n = fromIntegral (bytesElt (TupRsingle (SingleScalarType tp))) * fromIntegral n evictable :: Status -> Bool evictable Clean = True From 4c82ab14f2aef98c85a8a36d723004a0ba2b2f01 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 19 Jun 2020 17:11:09 +0200 Subject: [PATCH 252/316] wibble --- .../Array/Accelerate/Representation/Elt.hs | 59 ++++++++++--------- 1 file changed, 30 insertions(+), 29 deletions(-) diff --git a/src/Data/Array/Accelerate/Representation/Elt.hs b/src/Data/Array/Accelerate/Representation/Elt.hs index 478a65206..ea6b468b5 100644 --- a/src/Data/Array/Accelerate/Representation/Elt.hs +++ b/src/Data/Array/Accelerate/Representation/Elt.hs @@ -120,37 +120,38 @@ showsElt = tuple tuple (TupRsingle tp) val = scalar tp val scalar :: ScalarType e -> e -> ShowS - scalar (SingleScalarType t) e = showString $ single t e - scalar (VectorScalarType t) e = showString $ vector t e - - single :: SingleType e -> e -> String - single (NumSingleType t) e = num t e - - num :: NumType e -> e -> String - num (IntegralNumType t) e = integral t e - num (FloatingNumType t) e = floating t e - - integral :: IntegralType e -> e -> String - integral TypeInt e = show e - integral TypeInt8 e = show e - integral TypeInt16 e = show e - integral TypeInt32 e = show e - integral TypeInt64 e = show e - integral TypeWord e = show e - integral TypeWord8 e = show e - integral TypeWord16 e = show e - integral TypeWord32 e = show e - integral TypeWord64 e = show e - - floating :: FloatingType e -> e -> String - floating TypeHalf e = show e - floating TypeFloat e = show e - floating TypeDouble e = show e - - vector :: VectorType (Vec n a) -> Vec n a -> String + scalar (SingleScalarType t) e = single t e + scalar (VectorScalarType t) e = vector t e + + single :: SingleType e -> e -> ShowS + single (NumSingleType t) = num t + + num :: NumType e -> e -> ShowS + num (IntegralNumType t) = integral t + num (FloatingNumType t) = floating t + + integral :: IntegralType e -> e -> ShowS + integral TypeInt = shows + integral TypeInt8 = shows + integral TypeInt16 = shows + integral TypeInt32 = shows + integral TypeInt64 = shows + integral TypeWord = shows + integral TypeWord8 = shows + integral TypeWord16 = shows + integral TypeWord32 = shows + integral TypeWord64 = shows + + floating :: FloatingType e -> e -> ShowS + floating TypeHalf = shows + floating TypeFloat = shows + floating TypeDouble = shows + + vector :: VectorType (Vec n a) -> Vec n a -> ShowS vector (VectorType _ s) vec | SingleDict <- singleDict s - = "<" ++ intercalate ", " (single s <$> listOfVec vec) ++ ">" + = showString + $ "<" ++ intercalate ", " ((\v -> single s v "") <$> listOfVec vec) ++ ">" liftElt :: TypeR t -> t -> Q (TExp t) liftElt TupRunit () = [|| () ||] From eaeb835b0c250569ab8e689d4abdb1d4d7ae7522 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 21 Jun 2020 14:33:48 +0200 Subject: [PATCH 253/316] you had ONE JOB cabal MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Don’t let cabal compile .c files, which perpetually leads to linking problems. Instead use TH to tell GHC about these files directly. --- accelerate.cabal | 15 +------- cbits/flags_debug.c | 15 -------- cbits/monitoring_debug.c | 13 ------- src/Data/Array/Accelerate/Debug/Clock.hs | 27 ++++++++++++++ src/Data/Array/Accelerate/Debug/Flags.hs | 36 +++++++++++++++++-- src/Data/Array/Accelerate/Debug/Monitoring.hs | 15 +++++--- src/Data/Array/Accelerate/Debug/Timed.hs | 11 +++--- src/Data/Array/Accelerate/Debug/Trace.hs | 5 +-- src/Data/Atomic.hs | 9 +++++ 9 files changed, 86 insertions(+), 60 deletions(-) delete mode 100644 cbits/flags_debug.c delete mode 100644 cbits/monitoring_debug.c create mode 100644 src/Data/Array/Accelerate/Debug/Clock.hs diff --git a/accelerate.cabal b/accelerate.cabal index e401b4254..5f5b8a85f 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -378,6 +378,7 @@ Library Data.Array.Accelerate.Classes.RealFloat Data.Array.Accelerate.Classes.RealFrac Data.Array.Accelerate.Classes.ToFloating + Data.Array.Accelerate.Debug.Clock Data.Array.Accelerate.Debug.Flags Data.Array.Accelerate.Debug.Monitoring Data.Array.Accelerate.Debug.Stats @@ -477,10 +478,6 @@ Library hs-source-dirs: src - c-sources: - cbits/atomic.c - cbits/clock.c - if flag(debug) || flag(ekg) ghc-options: -optc-DACCELERATE_DEBUG @@ -488,16 +485,6 @@ Library cpp-options: -DACCELERATE_DEBUG - -- Weird handling of C files because Cabal is not recompile C files on - -- changes to cc-options: - c-sources: - cbits/flags_debug.c - cbits/monitoring_debug.c - else - c-sources: - cbits/flags.c - cbits/monitoring.c - if flag(ekg) cpp-options: -DACCELERATE_MONITORING diff --git a/cbits/flags_debug.c b/cbits/flags_debug.c deleted file mode 100644 index 8a551900c..000000000 --- a/cbits/flags_debug.c +++ /dev/null @@ -1,15 +0,0 @@ -/* - * Module : Data.Array.Accelerate.Debug.Flags - * Copyright : [2017..2019] The Accelerate Team - * License : BSD3 - * - * Maintainer : Trevor L. McDonell - * Stability : experimental - * Portability : non-portable (GHC extensions) - * - * This is a hack to (try to) work around - */ - -#define ACCELERATE_DEBUG -#include "flags.c" - diff --git a/cbits/monitoring_debug.c b/cbits/monitoring_debug.c deleted file mode 100644 index 058817eac..000000000 --- a/cbits/monitoring_debug.c +++ /dev/null @@ -1,13 +0,0 @@ -/* - * Module : Data.Array.Accelerate.Debug.Monitoring - * Copyright : [2016..2019] The Accelerate Team - * License : BSD3 - * - * Maintainer : Trevor L. McDonell - * Stability : experimental - * Portability : non-portable (GHC extensions) - */ - -#define ACCELERATE_DEBUG -#include "monitoring.c" - diff --git a/src/Data/Array/Accelerate/Debug/Clock.hs b/src/Data/Array/Accelerate/Debug/Clock.hs new file mode 100644 index 000000000..b75433266 --- /dev/null +++ b/src/Data/Array/Accelerate/Debug/Clock.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fobject-code #-} +-- | +-- Module : Data.Array.Accelerate.Debug.Clock +-- Copyright : [2016..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Debug.Clock + where + +import Language.Haskell.TH.Syntax + +foreign import ccall unsafe "clock_gettime_monotonic_seconds" getMonotonicTime :: IO Double +foreign import ccall unsafe "clock_gettime_elapsed_seconds" getProgramTime :: IO Double + +-- SEE: [linking to .c files] +-- +runQ $ do + addForeignFilePath LangC "cbits/clock.c" + return [] + diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index e6195c01a..19e59b3df 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fobject-code #-} -- SEE: [linking to .c files] #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} #endif @@ -45,13 +47,15 @@ module Data.Array.Accelerate.Debug.Flags ( ) where +import Control.Monad.IO.Class ( MonadIO, liftIO ) import Data.Bits import Data.Int import Data.Word import Foreign.Ptr import Foreign.Storable - -import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Language.Haskell.TH.Syntax +import System.Directory +import System.FilePath import qualified Control.Monad as M newtype Flag = Flag Int @@ -159,11 +163,11 @@ clearFlags = mapM_ clearFlag -- notEnabled = error $ unlines [ "Data.Array.Accelerate: Debugging options are disabled." -- , "Reinstall package 'accelerate' with '-fdebug' to enable them." ] - -- Import the underlying flag variables. These are defined in the file -- cbits/flags.h as a bitfield and initialised at program initialisation. -- -- SEE: [layout of command line options bitfield] +-- SEE: [linking to .c files] -- foreign import ccall "&__cmd_line_flags" __cmd_line_flags :: Ptr Word32 @@ -205,3 +209,29 @@ dump_asm = Flag 24 -- trace assembler dump_exec = Flag 25 -- trace execution dump_sched = Flag 26 -- trace scheduler + +-- Note: [linking to .c files] +-- +-- We use Template Haskell to tell GHC which .c files need to be compiled +-- for a particular module, rather than relying on Cabal as is traditional. +-- Using Cabal: +-- +-- * loading Accelerate into GHCi only works _after_ compiling the entire +-- package (which defeats the purpose), presumably because the .c files +-- are compiled last. This would often lead to errors such "can not find +-- symbol __cmd_line_flags" etc. +-- +-- * Cabal would refuse to re-compile .c files when changing command +-- line flags, see: https://github.com/haskell/cabal/issues/4937 +-- +-- * Linking problems also prevented us from using Template Haskell in +-- some locations, because GHC was unable to load the project into the +-- interpreter to run the splices. +-- +-- Note that for this fix to work in GHCi we also require modules using it +-- to be loaded as object code. +-- +runQ $ do + addForeignFilePath LangC "cbits/flags.c" + return [] + diff --git a/src/Data/Array/Accelerate/Debug/Monitoring.hs b/src/Data/Array/Accelerate/Debug/Monitoring.hs index a0a1263f4..c2be9b2bf 100644 --- a/src/Data/Array/Accelerate/Debug/Monitoring.hs +++ b/src/Data/Array/Accelerate/Debug/Monitoring.hs @@ -3,6 +3,8 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fobject-code #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Debug.Monitoring @@ -37,6 +39,7 @@ module Data.Array.Accelerate.Debug.Monitoring ( import System.Metrics import System.Remote.Monitoring +import Control.Monad import Control.Concurrent import Control.Concurrent.Async import Data.IORef @@ -48,9 +51,8 @@ import qualified Data.HashMap.Strict as Map import Data.Atomic ( Atomic ) import qualified Data.Atomic as Atomic -import Control.Monad import Data.Int -import Prelude +import Language.Haskell.TH.Syntax -- | Launch a monitoring server that will collect statistics on the running @@ -345,9 +347,6 @@ estimateProcessorLoad !var !ref = do 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 @@ -409,3 +408,9 @@ foreign import ccall "&__total_bytes_evicted_from_remote" __total_bytes_evicted_ 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 +-- SEE: [linking to .c files] +-- +runQ $ do + addForeignFilePath LangC "cbits/monitoring.c" + return [] + diff --git a/src/Data/Array/Accelerate/Debug/Timed.hs b/src/Data/Array/Accelerate/Debug/Timed.hs index 18bb673df..4d382e934 100644 --- a/src/Data/Array/Accelerate/Debug/Timed.hs +++ b/src/Data/Array/Accelerate/Debug/Timed.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} -- | -- Module : Data.Array.Accelerate.Debug.Timed -- Copyright : [2016..2019] The Accelerate Team @@ -18,13 +17,15 @@ module Data.Array.Accelerate.Debug.Timed ( ) where -import Data.Array.Accelerate.Debug.Trace import Data.Array.Accelerate.Debug.Flags +import Data.Array.Accelerate.Debug.Trace import Control.Monad.Trans ( MonadIO ) import Text.Printf #if ACCELERATE_DEBUG +import Data.Array.Accelerate.Debug.Clock + import Control.Applicative import Control.Monad.Trans ( liftIO ) import Data.List @@ -76,8 +77,6 @@ timed_simpl fmt action = do 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 diff --git a/src/Data/Array/Accelerate/Debug/Trace.hs b/src/Data/Array/Accelerate/Debug/Trace.hs index c33cbc0ed..f252535ca 100644 --- a/src/Data/Array/Accelerate/Debug/Trace.hs +++ b/src/Data/Array/Accelerate/Debug/Trace.hs @@ -30,6 +30,7 @@ import Data.Array.Accelerate.Debug.Flags import Numeric #ifdef ACCELERATE_DEBUG +import Data.Array.Accelerate.Debug.Clock import System.IO.Unsafe import Text.Printf import qualified Debug.Trace as D @@ -142,7 +143,3 @@ traceEventIO f msg = do traceEventIO _ _ = return () #endif -#ifdef ACCELERATE_DEBUG -foreign import ccall unsafe "clock_gettime_elapsed_seconds" getProgramTime :: IO Double -#endif - diff --git a/src/Data/Atomic.hs b/src/Data/Atomic.hs index b83c1c249..e200e40df 100644 --- a/src/Data/Atomic.hs +++ b/src/Data/Atomic.hs @@ -1,7 +1,9 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fobject-code #-} -- | -- Module : Data.Atomic -- Copyright : [2016..2019] The Accelerate Team @@ -22,6 +24,7 @@ module Data.Atomic ( ) where import Data.Int +import Language.Haskell.TH.Syntax import GHC.Ptr import GHC.Base @@ -66,3 +69,9 @@ foreign import ccall unsafe "atomic_fetch_and_and_64" and :: Atomic -> Int64 -> -- foreign import ccall unsafe "atomic_fetch_and_sub_64" subtract :: Atomic -> Int64 -> IO Int64 +-- SEE: [linking to .c files] +-- +runQ $ do + addForeignFilePath LangC "cbits/atomic.c" + return [] + From 2dda61a4d2daaccb1acb835e30f8d5b997481534 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 23 Jun 2020 19:30:56 +0200 Subject: [PATCH 254/316] Haskell Char is a wide char (32-bits) --- src/Data/Array/Accelerate/Language.hs | 4 ++-- src/Data/Array/Accelerate/Sugar/Elt.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 70fe07281..990bcc099 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1493,12 +1493,12 @@ x ^^ n -- |Convert a character to an 'Int'. -- ord :: Exp Char -> Exp Int -ord = mkCoerce +ord = mkFromIntegral -- |Convert an 'Int' into a character. -- chr :: Exp Int -> Exp Char -chr = mkCoerce +chr = mkFromIntegral -- |Convert a Boolean value to an 'Int', where 'False' turns into '0' and 'True' -- into '1'. diff --git a/src/Data/Array/Accelerate/Sugar/Elt.hs b/src/Data/Array/Accelerate/Sugar/Elt.hs index 16c6eb1ad..032937c67 100644 --- a/src/Data/Array/Accelerate/Sugar/Elt.hs +++ b/src/Data/Array/Accelerate/Sugar/Elt.hs @@ -301,11 +301,11 @@ instance Elt () instance Elt Bool instance Elt Char where - type EltR Char = Int + type EltR Char = Word32 eltR = TupRsingle scalarType tagsR = [TagRsingle scalarType] - toElt = chr - fromElt = ord + toElt = chr . fromIntegral + fromElt = fromIntegral . ord runQ $ do let From 12545f8192e33ebacc7d737e832a439fc6d423e4 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 24 Jun 2020 14:29:40 +0200 Subject: [PATCH 255/316] add ghc-8.10, drop 8.2, 8.4 Technically this restriction is based on template-haskell, which is required to work around limitations of Cabal --- .github/workflows/ci.yml | 9 +++-- accelerate.cabal | 2 +- src/Data/Array/Accelerate/Debug/Monitoring.hs | 5 ++- src/Data/Array/Accelerate/Debug/Timed.hs | 2 +- src/Data/Array/Accelerate/Lift.hs | 2 +- src/Data/Array/Accelerate/Pattern.hs | 12 +++---- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 2 +- .../Test/NoFib/Spectral/RadixSort.hs | 2 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 2 +- src/Language/Haskell/TH/Extra.hs | 16 ++++++++- stack-8.2.yaml => stack-8.10.yaml | 27 +++++++------- stack-8.4.yaml | 35 ------------------- 12 files changed, 49 insertions(+), 67 deletions(-) rename stack-8.2.yaml => stack-8.10.yaml (59%) delete mode 100644 stack-8.4.yaml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 15ec95764..0b85bfbe2 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -21,19 +21,18 @@ jobs: os: [ubuntu-latest] allow_failure: [false] ghc: + - "8.10" - "8.8" - "8.6" - - "8.4" - - "8.2" include: - os: macOS-latest - ghc: 8.8 + ghc: 8.10 allow_failure: false # ghc-8.8 currently doesn't work on the windows test machines due to a # 32-bit linker problem, failing with the error: # Access violation in generated code when writing 0x0 - os: windows-latest - ghc: 8.6 + ghc: 8.10 allow_failure: false env: STACK_FLAGS: "--system-ghc --no-install-ghc --fast --flag accelerate:nofib" @@ -68,5 +67,5 @@ jobs: - name: Test run: | stack test accelerate:doctest $STACK_FLAGS - stack test accelerate:nofib-interpreter $STACK_FLAGS --test-arguments='--hedgehog-tests 25' + stack test accelerate:nofib-interpreter $STACK_FLAGS diff --git a/accelerate.cabal b/accelerate.cabal index 5f5b8a85f..54965b4e5 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -268,7 +268,7 @@ Flag nofib Library Build-depends: - base >= 4.10 && < 4.14 + base >= 4.12 && < 4.15 , ansi-terminal >= 0.6.2 , base-orphans >= 0.3 , bytestring >= 0.10.2 diff --git a/src/Data/Array/Accelerate/Debug/Monitoring.hs b/src/Data/Array/Accelerate/Debug/Monitoring.hs index c2be9b2bf..545b1c521 100644 --- a/src/Data/Array/Accelerate/Debug/Monitoring.hs +++ b/src/Data/Array/Accelerate/Debug/Monitoring.hs @@ -39,7 +39,6 @@ module Data.Array.Accelerate.Debug.Monitoring ( import System.Metrics import System.Remote.Monitoring -import Control.Monad import Control.Concurrent import Control.Concurrent.Async import Data.IORef @@ -48,6 +47,10 @@ import Text.Printf import qualified Data.HashMap.Strict as Map #endif +#if defined(ACCELERATE_MONITORING) || defined(ACCELERATE_DEBUG) +import Control.Monad +#endif + import Data.Atomic ( Atomic ) import qualified Data.Atomic as Atomic diff --git a/src/Data/Array/Accelerate/Debug/Timed.hs b/src/Data/Array/Accelerate/Debug/Timed.hs index 4d382e934..a0955a07a 100644 --- a/src/Data/Array/Accelerate/Debug/Timed.hs +++ b/src/Data/Array/Accelerate/Debug/Timed.hs @@ -28,7 +28,7 @@ import Data.Array.Accelerate.Debug.Clock import Control.Applicative import Control.Monad.Trans ( liftIO ) -import Data.List +import Data.List ( intercalate ) import System.CPUTime import Prelude diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index a6a4c79c4..e2819cf85 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -46,7 +46,7 @@ import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Sugar.Shape import Data.Array.Accelerate.Type -import Language.Haskell.TH hiding ( Exp ) +import Language.Haskell.TH hiding ( Exp, tupP, tupE ) import Language.Haskell.TH.Extra diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 71b1d9011..feeffe5ea 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -47,8 +47,9 @@ import Data.Array.Accelerate.Sugar.Vec import Data.Array.Accelerate.Type import Data.Primitive.Vec -import Language.Haskell.TH hiding ( Exp ) +import Language.Haskell.TH hiding ( Exp, Match, match, tupP, tupE ) import Language.Haskell.TH.Extra +import qualified Language.Haskell.TH as TH -- | A pattern synonym for working with (product) data types. You can declare @@ -109,16 +110,15 @@ runQ $ do -- Type variables for the elements xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] -- Last argument to `IsPattern`, eg (Exp, a, Exp b) in the example - b = foldl (\ts t -> appT ts (appT (conT con) (varT t))) (tupleT n) xs + b = tupT (map (\t -> [t| $(conT con) $(varT t)|]) xs) -- Representation as snoc-list of pairs, eg (((), EltR a), EltR b) snoc = foldl (\sn t -> [t| ($sn, $(appT repr $ varT t)) |]) [t| () |] xs -- Constraints for the type class, consisting of Elt constraints on all type variables, -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`. - contexts = appT cst [t| $(varT a) |] + context = tupT + $ appT cst [t| $(varT a) |] : [t| $repr $(varT a) ~ $snoc |] - : map (\t -> appT cst (varT t)) xs - -- Store all constraints in a tuple - context = foldl (\ts t -> appT ts t) (tupleT $ length contexts) contexts + : map (\t -> [t| $cst $(varT t)|]) xs -- get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 2eb73a213..2ddf6b846 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -49,7 +49,7 @@ 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.List ( nub, partition ) import Data.Maybe import Data.String import Data.Text.Prettyprint.Doc diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs index 2850a3ebb..1c9576fb6 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs @@ -23,7 +23,7 @@ module Data.Array.Accelerate.Test.NoFib.Spectral.RadixSort ( ) where import Data.Function -import Data.List +import Data.List ( sortBy ) import Prelude as P import qualified Data.Bits as P diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index db898d039..3fd0c04c3 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -72,7 +72,7 @@ import qualified Data.Array.Accelerate.Representation.Stencil as R import Control.Applicative hiding ( Const ) import Control.Monad.Fix import Data.Hashable -import Data.List hiding ( (\\) ) +import Data.List ( elemIndex, findIndex, groupBy, intercalate, partition ) import Data.Maybe import System.IO.Unsafe ( unsafePerformIO ) import System.Mem.StableName diff --git a/src/Language/Haskell/TH/Extra.hs b/src/Language/Haskell/TH/Extra.hs index b115540cc..ae0e25984 100644 --- a/src/Language/Haskell/TH/Extra.hs +++ b/src/Language/Haskell/TH/Extra.hs @@ -12,11 +12,25 @@ module Language.Haskell.TH.Extra where -import Language.Haskell.TH +import Language.Haskell.TH hiding ( tupP, tupE ) +import qualified Language.Haskell.TH as TH tupT :: [TypeQ] -> TypeQ +tupT [t] = t tupT tup = let n = length tup in foldl (\ts t -> [t| $ts $t |]) (tupleT n) tup +tupP :: [PatQ] -> PatQ +tupP [p] = p +tupP ps = TH.tupP ps + +tupE :: [ExpQ] -> ExpQ +tupE [t] = t +tupE ts = TH.tupE ts + +tyVarBndrName :: TyVarBndr -> Name +tyVarBndrName (PlainTV n) = n +tyVarBndrName (KindedTV n _) = n + diff --git a/stack-8.2.yaml b/stack-8.10.yaml similarity index 59% rename from stack-8.2.yaml rename to stack-8.10.yaml index af12a8d71..ec88bef2c 100644 --- a/stack-8.2.yaml +++ b/stack-8.10.yaml @@ -1,35 +1,36 @@ -# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md -# vim: nospell +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ -resolver: lts-11.22 +resolver: nightly-2020-06-24 packages: - . -extra-deps: -- half-0.3 +# extra-deps: # Override default flag values for local packages and extra-deps # flags: {} -# Extra global and per-package GHC options -# ghc-options: {} - # Extra package databases containing global packages # extra-package-dbs: [] # Control whether we use the GHC we find on the path # system-ghc: true - +# # Require a specific version of stack, using version ranges # require-stack-version: -any # Default -# require-stack-version: >= 0.1.4.0 - +# require-stack-version: ">=1.9" +# # Override the architecture used by stack, especially useful on Windows # arch: i386 # arch: x86_64 - +# # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] # extra-lib-dirs: [/path/to/dir] - +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor +# +# vim: nospell diff --git a/stack-8.4.yaml b/stack-8.4.yaml deleted file mode 100644 index a8c2177a9..000000000 --- a/stack-8.4.yaml +++ /dev/null @@ -1,35 +0,0 @@ -# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md -# vim: nospell - -resolver: lts-12.26 - -packages: -- . - -extra-deps: -- primitive-0.6.4.0 - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra global and per-package GHC options -# ghc-options: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true - -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: >= 0.1.4.0 - -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 - -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] - From 565acd05d52b4782f56a184624237f148cd1c16c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 24 Jun 2020 15:05:37 +0200 Subject: [PATCH 256/316] fix ci.yml --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0b85bfbe2..737f3677d 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -26,13 +26,13 @@ jobs: - "8.6" include: - os: macOS-latest - ghc: 8.10 + ghc: "8.10" allow_failure: false # ghc-8.8 currently doesn't work on the windows test machines due to a # 32-bit linker problem, failing with the error: # Access violation in generated code when writing 0x0 - os: windows-latest - ghc: 8.10 + ghc: "8.10" allow_failure: false env: STACK_FLAGS: "--system-ghc --no-install-ghc --fast --flag accelerate:nofib" From 359b20d26e2bbbdea0b2877d43c2e12b3ffff69f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 25 Jun 2020 20:58:16 +0200 Subject: [PATCH 257/316] add embedded pattern matching --- src/Data/Array/Accelerate.hs | 2 +- src/Data/Array/Accelerate/AST.hs | 27 ++- src/Data/Array/Accelerate/AST/LeftHandSide.hs | 4 +- src/Data/Array/Accelerate/Analysis/Hash.hs | 13 +- src/Data/Array/Accelerate/Classes/Eq.hs | 10 +- src/Data/Array/Accelerate/Classes/Ord.hs | 14 +- src/Data/Array/Accelerate/Data/Either.hs | 46 ++--- src/Data/Array/Accelerate/Data/Maybe.hs | 38 +--- src/Data/Array/Accelerate/Interpreter.hs | 18 ++ src/Data/Array/Accelerate/Pattern.hs | 174 +++++++++++++++++- src/Data/Array/Accelerate/Prelude.hs | 88 +++++++-- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 1 + src/Data/Array/Accelerate/Pretty/Print.hs | 34 ++++ src/Data/Array/Accelerate/Smart.hs | 19 +- src/Data/Array/Accelerate/Trafo/Fusion.hs | 8 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 58 ++++-- src/Data/Array/Accelerate/Trafo/Shrink.hs | 17 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 9 + .../Array/Accelerate/Trafo/Substitution.hs | 7 +- 19 files changed, 454 insertions(+), 133 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 0ddc996e3..145fe2166 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -361,7 +361,7 @@ module Data.Array.Accelerate ( fst, afst, snd, asnd, curry, uncurry, -- *** Flow control - (?), caseof, cond, while, iterate, + (?), match, cond, while, iterate, -- *** Scalar reduction sfoldl, diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 7e9eba3f8..c9a2e366a 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -133,6 +133,7 @@ module Data.Array.Accelerate.AST ( import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.AST.LeftHandSide import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Error import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Representation.Elt import Data.Array.Accelerate.Representation.Shape @@ -561,6 +562,11 @@ data OpenExp env aenv t where -> OpenExp env aenv Int -- index into linear representation -> OpenExp env aenv sh + -- Case statement + Case :: OpenExp env aenv a + -> [(TagR a, OpenExp env aenv b)] + -> OpenExp env aenv b + -- Conditional expression (non-strict in 2nd and 3rd argument) Cond :: OpenExp env aenv PrimBool -> OpenExp env aenv t @@ -694,9 +700,9 @@ data PrimFun sig where -- PrimProperFraction :: FloatingType a -> IntegralType b -> PrimFun (a -> (b, a)) -- operators from RealFloat - PrimAtan2 :: FloatingType a -> PrimFun ((a, a) -> a) - PrimIsNaN :: FloatingType a -> PrimFun (a -> PrimBool) - PrimIsInfinite :: FloatingType a -> PrimFun (a -> PrimBool) + PrimAtan2 :: FloatingType a -> PrimFun ((a, a) -> a) + PrimIsNaN :: FloatingType a -> PrimFun (a -> PrimBool) + PrimIsInfinite :: FloatingType a -> PrimFun (a -> PrimBool) -- relational and equality operators PrimLt :: SingleType a -> PrimFun ((a, a) -> PrimBool) @@ -791,6 +797,8 @@ expType = \case IndexFull si _ _ -> shapeType $ sliceDomainR si ToIndex{} -> TupRsingle scalarTypeInt FromIndex shr _ _ -> shapeType shr + Case _ ((_,e):_) -> expType e + Case _ [] -> $internalError "expType" "empty case encountered" Cond _ e _ -> expType e While _ (Lam lhs _) _ -> lhsToTupR lhs While{} -> error "What's the matter, you're running in the shadows" @@ -1010,6 +1018,12 @@ rnfMaybe :: (a -> ()) -> Maybe a -> () rnfMaybe _ Nothing = () rnfMaybe f (Just x) = f x +rnfList :: (a -> ()) -> [a] -> () +rnfList r = go + where + go [] = () + go (x:xs) = r x `seq` go xs + rnfOpenFun :: OpenFun env aenv t -> () rnfOpenFun (Body b) = rnfOpenExp b rnfOpenFun (Lam lhs f) = rnfELeftHandSide lhs `seq` rnfOpenFun f @@ -1037,6 +1051,7 @@ rnfOpenExp topExp = IndexFull slice slix sl -> rnfSliceIndex slice `seq` rnfE slix `seq` rnfE sl ToIndex shr sh ix -> rnfShapeR shr `seq` rnfE sh `seq` rnfE ix FromIndex shr sh ix -> rnfShapeR shr `seq` rnfE sh `seq` rnfE ix + Case e rhs -> rnfE e `seq` rnfList (\(t,c) -> rnfTag t `seq` rnfE c) rhs 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 @@ -1209,6 +1224,10 @@ liftMaybe :: (a -> Q (TExp a)) -> Maybe a -> Q (TExp (Maybe a)) liftMaybe _ Nothing = [|| Nothing ||] liftMaybe f (Just x) = [|| Just $$(f x) ||] +liftList :: (a -> Q (TExp a)) -> [a] -> Q (TExp [a]) +liftList _ [] = [|| [] ||] +liftList f (x:xs) = [|| $$(f x) : $$(liftList f xs) ||] + liftOpenFun :: OpenFun env aenv t -> Q (TExp (OpenFun env aenv t)) @@ -1241,6 +1260,7 @@ liftOpenExp pexp = IndexFull slice slix sl -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||] ToIndex shr sh ix -> [|| ToIndex $$(liftShapeR shr) $$(liftE sh) $$(liftE ix) ||] FromIndex shr sh ix -> [|| FromIndex $$(liftShapeR shr) $$(liftE sh) $$(liftE ix) ||] + Case p rhs -> [|| Case $$(liftE p) $$(liftList (\(t,c) -> [|| ($$(liftTag t), $$(liftE c)) ||]) rhs) ||] 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) ||] @@ -1383,6 +1403,7 @@ showExpOp IndexSlice{} = "IndexSlice" showExpOp IndexFull{} = "IndexFull" showExpOp ToIndex{} = "ToIndex" showExpOp FromIndex{} = "FromIndex" +showExpOp Case{} = "Case" showExpOp Cond{} = "Cond" showExpOp While{} = "While" showExpOp PrimConst{} = "PrimConst" diff --git a/src/Data/Array/Accelerate/AST/LeftHandSide.hs b/src/Data/Array/Accelerate/AST/LeftHandSide.hs index 3ef297d18..fe019a64e 100644 --- a/src/Data/Array/Accelerate/AST/LeftHandSide.hs +++ b/src/Data/Array/Accelerate/AST/LeftHandSide.hs @@ -45,12 +45,12 @@ pattern LeftHandSideUnit => LeftHandSide s v env env' pattern LeftHandSideUnit = LeftHandSideWildcard TupRunit -lhsToTupR :: LeftHandSide s arrs aenv aenv' -> TupR s arrs +lhsToTupR :: LeftHandSide s v env env' -> TupR s v lhsToTupR (LeftHandSideSingle s) = TupRsingle s lhsToTupR (LeftHandSideWildcard r) = r lhsToTupR (LeftHandSidePair as bs) = TupRpair (lhsToTupR as) (lhsToTupR bs) -rnfLeftHandSide :: (forall b. s b -> ()) -> LeftHandSide s arrs env env' -> () +rnfLeftHandSide :: (forall b. s b -> ()) -> LeftHandSide s v env env' -> () rnfLeftHandSide f (LeftHandSideWildcard r) = rnfTupR f r rnfLeftHandSide f (LeftHandSideSingle s) = f s rnfLeftHandSide f (LeftHandSidePair as bs) = rnfLeftHandSide f as `seq` rnfLeftHandSide f bs diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 98f880293..fb5e00565 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -37,13 +37,14 @@ module Data.Array.Accelerate.Analysis.Hash ( import Data.Array.Accelerate.AST import Data.Array.Accelerate.AST.Idx -import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.AST.LeftHandSide +import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Analysis.Hash.TH import Data.Array.Accelerate.Representation.Array -import Data.Array.Accelerate.Representation.Stencil import Data.Array.Accelerate.Representation.Shape import Data.Array.Accelerate.Representation.Slice +import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type import Data.Primitive.Vec @@ -328,6 +329,7 @@ encodeOpenExp exp = 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 + Case e rhs -> intHost $(hashQ "Case") <> travE e <> mconcat [ encodeTag t <> travE c | (t,c) <- rhs ] 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 @@ -342,6 +344,13 @@ encodeOpenExp exp = encodeArrayVar :: ArrayVar aenv a -> Builder encodeArrayVar (Var repr v) = encodeArrayType repr <> encodeIdx v +encodeTag :: TagR t -> Builder +encodeTag TagRunit = intHost $(hashQ "TagRunit") +encodeTag (TagRsingle t) = intHost $(hashQ "TagRsingle") <> encodeScalarType t +encodeTag (TagRundef t) = intHost $(hashQ "TagRundef") <> encodeScalarType t +encodeTag (TagRtag t a) = intHost $(hashQ "TagRtag") <> word8 t <> encodeTag a +encodeTag (TagRpair ta tb) = intHost $(hashQ "TagRpair") <> encodeTag ta <> encodeTag tb + {-# INLINEABLE encodeOpenFun #-} encodeOpenFun :: OpenFun env aenv f diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 89d5b02d9..6e83a846b 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Eq @@ -42,14 +43,7 @@ import Language.Haskell.TH.Extra import qualified Prelude as P -pattern True_ :: Exp Bool -pattern True_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 1) `Pair` SmartExp Nil)) - -pattern False_ :: Exp Bool -pattern False_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 0) `Pair` SmartExp Nil)) - - -{-# COMPLETE True_, False_ #-} +mkPatterns ''Bool infix 4 == infix 4 /= diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 6c9389513..59ed43157 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Ord @@ -46,21 +47,14 @@ import Prelude ( ($), (>>=) import Text.Printf import qualified Prelude as P + +mkPatterns ''Ordering + infix 4 < infix 4 > infix 4 <= infix 4 >= -pattern LT_ :: Exp Ordering -pattern LT_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 0) `Pair` SmartExp Nil)) - -pattern EQ_ :: Exp Ordering -pattern EQ_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 1) `Pair` SmartExp Nil)) - -pattern GT_ :: Exp Ordering -pattern GT_ = Exp (SmartExp (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) 2) `Pair` SmartExp Nil)) -{-# COMPLETE LT_, EQ_, GT_ #-} - -- | The 'Ord' class for totally ordered datatypes -- class Eq a => Ord a where diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index f53e21eaa..d3d4e3172 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -4,10 +4,12 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Either @@ -24,20 +26,20 @@ module Data.Array.Accelerate.Data.Either ( Either(..), pattern Left_, pattern Right_, - left, right, either, isLeft, isRight, fromLeft, fromRight, lefts, rights, ) where +import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Sugar.Array ( Array, Vector ) -import Data.Array.Accelerate.Sugar.Elt -import Data.Array.Accelerate.Sugar.Shape ( Shape, Slice, Z(..), (:.), empty ) -import Data.Array.Accelerate.Language hiding ( chr ) -import Data.Array.Accelerate.Prelude hiding ( filter ) import Data.Array.Accelerate.Interpreter +import Data.Array.Accelerate.Language hiding ( chr ) import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Prelude hiding ( filter ) import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Array ( Array, Vector ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Sugar.Shape ( Shape, Slice, Z(..), (:.), empty ) import Data.Array.Accelerate.Type import Data.Array.Accelerate.Classes.Eq @@ -52,16 +54,11 @@ import Data.Array.Accelerate.Data.Semigroup import Data.Either ( Either(..) ) import Data.Maybe -import Prelude ( (.), ($), const, otherwise, undefined ) +import Prelude ( (.), ($), const, otherwise ) -pattern Left_ :: (Elt a, Elt b) => Exp a -> Exp (Either a b) -pattern Left_ <- _ - where Left_ = left +mkPatterns ''Either -pattern Right_ :: (Elt a, Elt b) => Exp b -> Exp (Either a b) -pattern Right_ <- _ - where Right_ = right -- | Lift a value into the 'Left' constructor -- @@ -91,16 +88,14 @@ isRight x = tag x == 1 -- instead. -- fromLeft :: (Elt a, Elt b) => Exp (Either a b) -> Exp a -fromLeft x = a - where T3 _ a _ = asTuple x +fromLeft x = let T3 _ a _ = asTuple x in a -- | 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 = b - where T3 _ _ b = asTuple x +fromRight x = let T3 _ _ b = asTuple x in b -- | 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@, @@ -149,15 +144,14 @@ instance (Elt a, Elt b) => Semigroup (Exp (Either a b)) where #endif tag :: (Elt a, Elt b) => Exp (Either a b) -> Exp Word8 -tag x = t - where T3 t _ _ = asTuple x +tag x = let T3 t _ _ = asTuple x in t instance (Elt a, Elt b) => Elt (Either 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) = toEither $ T3 (constant 0) (lift a) undef - -- lift (Right b) = toEither $ T3 (constant 1) undef (lift b) + lift (Left a) = Left_ (lift a) + lift (Right b) = Right_ (lift b) -- Utilities @@ -197,9 +191,9 @@ filter' keep arr emptyArray :: (Shape sh, Elt e) => Acc (Array sh e) emptyArray = fill (constant empty) undef -asTuple :: Exp (Either a b) -> Exp (Word8, a, b) -asTuple = undefined -- (Exp e) = Exp e - -toEither :: Exp (Word8, a, b) -> Exp (Either a b) -toEither = undefined -- (Exp e) = Exp e +asTuple :: (Elt a, Elt b) => Exp (Either a b) -> Exp (Word8, a, b) +asTuple (Exp e) = + T3 (Exp $ SmartExp $ Prj PairIdxLeft e) + (Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxLeft $ SmartExp $ Prj PairIdxRight e) + (Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxRight e) diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index 731835171..49c07ccc0 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -4,10 +4,12 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Maybe @@ -24,7 +26,6 @@ module Data.Array.Accelerate.Data.Maybe ( Maybe(..), pattern Nothing_, pattern Just_, - just, nothing, maybe, isJust, isNothing, fromMaybe, fromJust, justs, ) where @@ -33,6 +34,7 @@ import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Interpreter import Data.Array.Accelerate.Language hiding ( chr ) +import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude hiding ( filter ) import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Array ( Array, Vector ) @@ -54,32 +56,8 @@ import Data.Maybe ( Maybe(..) import Prelude ( ($), const, otherwise ) -pattern Nothing_ :: Elt a => Exp (Maybe a) -pattern Nothing_ <- _ - where Nothing_ = nothing +mkPatterns ''Maybe -pattern Just_ :: Elt a => Exp a -> Exp (Maybe a) -pattern Just_ <- _ - where Just_ = just - --- | 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' -- @@ -159,12 +137,8 @@ instance Elt a => Elt (Maybe a) instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Maybe a) where type Plain (Maybe a) = Maybe (Plain a) - -- lift Nothing = Exp $ SmartExp $ Pair t $ unExp $ undef @(Plain a) - -- where - -- t = SmartExp $ Pair (SmartExp Nil) (SmartExp $ Const scalarTypeWord8 0) - -- lift (Just x) = Exp $ SmartExp $ Pair t $ unExp $ lift x - -- where - -- t = SmartExp $ Pair (SmartExp Nil) $ SmartExp $ Const scalarTypeWord8 1 + lift Nothing = Nothing_ + lift (Just a) = Just_ (lift a) -- Utilities diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index e70e58c5a..0f2c169fb 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -52,6 +52,7 @@ import Data.Array.Accelerate.Representation.Elt import Data.Array.Accelerate.Representation.Shape import Data.Array.Accelerate.Representation.Slice import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Representation.Vec import Data.Array.Accelerate.Trafo @@ -944,6 +945,23 @@ evalOpenExp pexp env aenv = ToIndex shr sh ix -> toIndex shr (evalE sh) (evalE ix) FromIndex shr sh ix -> fromIndex shr (evalE sh) (evalE ix) + Case e rhs -> evalE (caseof (evalE e) rhs) + where + caseof :: a -> [(TagR a, OpenExp env aenv b)] -> OpenExp env aenv b + caseof v = go + where + go ((t,cont):cs) + | eqTag t v = cont + | otherwise = go cs + go [] = $internalError "case" "unmatched case" + + eqTag :: TagR a -> a -> Bool + eqTag TagRunit () = True + eqTag TagRsingle{} _ = True + eqTag TagRundef{} _ = True + eqTag (TagRtag tag aR) (t,a) = tag == t && eqTag aR a + eqTag (TagRpair aR bR) (a,b) = eqTag aR a && eqTag bR b + Cond c t e | toBool (evalE c) -> evalE t | otherwise -> evalE e diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index feeffe5ea..22e10149b 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -35,18 +36,24 @@ module Data.Array.Accelerate.Pattern ( pattern V2, pattern V3, pattern V4, pattern V8, pattern V16, + mkPatterns, + ) where import Data.Array.Accelerate.AST.Idx -import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Vec +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Array import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Sugar.Shape -import Data.Array.Accelerate.Sugar.Array import Data.Array.Accelerate.Sugar.Vec import Data.Array.Accelerate.Type import Data.Primitive.Vec +import Control.Monad +import Data.Bits +import Data.List ( foldl' ) import Language.Haskell.TH hiding ( Exp, Match, match, tupP, tupE ) import Language.Haskell.TH.Extra import qualified Language.Haskell.TH as TH @@ -63,7 +70,6 @@ class IsPattern con a t where construct :: t -> con a destruct :: con a -> t - -- | Pattern synonyms for indices, which may be more convenient to use than -- 'Data.Array.Accelerate.Lift.lift' and -- 'Data.Array.Accelerate.Lift.unlift'. @@ -77,6 +83,7 @@ pattern (::.) :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) pattern a ::. b = Pattern (a :. b) {-# COMPLETE (::.) #-} +infixl 3 `Ix` pattern Ix :: (Elt a, Elt b) => Exp a -> Exp b -> Exp (a :. b) pattern a `Ix` b = a ::. b {-# COMPLETE Ix #-} @@ -95,6 +102,167 @@ instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where -- newtype VecPattern a = VecPattern a + +mkPatterns :: Name -> DecsQ +mkPatterns nm = do + info <- reify nm + case info of + TyConI dec -> mkDec dec + _ -> fail "mkPatterns: expected the name of a newtype or datatype" + +mkDec :: Dec -> DecsQ +mkDec dec = + case dec of + DataD _ nm tv _ cs _ -> mkDataD nm tv cs + NewtypeD _ nm tv _ c _ -> mkNewtypeD nm tv c + _ -> fail "mkPatterns: expected the name of a newtype or datatype" + +mkNewtypeD :: Name -> [TyVarBndr] -> Con -> DecsQ +mkNewtypeD tn tvs c = mkDataD tn tvs [c] + +mkDataD :: Name -> [TyVarBndr] -> [Con] -> DecsQ +mkDataD tn tvs cs = do + (pats, decs) <- unzip <$> go [] fts cs cts + comp <- pragCompleteD pats Nothing + return $ comp : concat decs + where + fieldTys (NormalC _ fs) = map snd fs + fieldTys (RecC _ fs) = map (\(_,_,t) -> t) fs + fieldTys (InfixC a _ b) = [snd a, snd b] + fieldTys _ = error "mkPatterns: only constructors for \"vanilla\" syntax are supported" + + st = length cs > 1 + fts = map fieldTys cs + + -- TODO: The GTags class demonstrates a way to generate the tags for + -- a given constructor, rather than backwards-engineering the structure + -- as we've done here. We should use that instead! + -- + cts = + let n = length cs + m = n `quot` 2 + l = take m (iterate (True:) [False]) + r = take (n-m) (iterate (True:) [True]) + in + map bitsToTag (l ++ r) + + bitsToTag = foldl' f 0 + where + f n False = n `shiftL` 1 + f n True = setBit (n `shiftL` 1) 0 + + go prev (this:next) (con:cons) (tag:tags) = do + r <- mkCon st tn tvs prev next tag con + rs <- go (this:prev) next cons tags + return (r : rs) + go _ [] [] [] = return [] + go _ _ _ _ = fail "mkPatterns: unexpected error" + +mkCon :: Bool -> Name -> [TyVarBndr] -> [[Type]] -> [[Type]] -> Word8 -> Con -> Q (Name, [Dec]) +mkCon st tn tvs prev next tag = \case + NormalC nm fs -> mkNormalC st tn (map tyVarBndrName tvs) tag nm prev (map snd fs) next + -- RecC nm fs -> undefined + -- InfixC a nm b -> undefined + _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" + +mkNormalC :: Bool -> Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) +mkNormalC st tn tvs tag cn ps fs ns = do + (fun_mk, dec_mk) <- mkNormalC_mk st tn tvs tag cn ps fs ns + (fun_match, dec_match) <- mkNormalC_match st tn tvs tag cn ps fs ns + (pat, dec_pat) <- mkNormalC_pattern tn tvs cn fs fun_mk fun_match + return $ (pat, concat [dec_pat, dec_mk, dec_match]) + +mkNormalC_pattern :: Name -> [Name] -> Name -> [Type] -> Name -> Name -> Q (Name, [Dec]) +mkNormalC_pattern tn tvs cn fs mk match = do + xs <- replicateM (length fs) (newName "_x") + r <- sequence [ patSynSigD pat sig + , patSynD pat + (prefixPatSyn xs) + (explBidir [clause [] (normalB (varE mk)) []]) + (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) + ] + return (pat, r) + where + pat = mkName (nameBase cn ++ "_") + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + +mkNormalC_mk :: Bool -> Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) +mkNormalC_mk sum_type tn tvs tag cn fs0 fs fs1 = do + fun <- newName ("_mk" ++ nameBase cn) + xs <- replicateM (length fs) (newName "_x") + let + vs = foldl' (\es e -> [| SmartExp ($es `Pair` $e) |]) [| SmartExp Nil |] + $ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat (reverse fs0)) + ++ map varE xs + ++ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat fs1) + + body = clause (map (\x -> [p| (Exp $(varP x)) |]) xs) (normalB tagged) [] + where + tagged + | sum_type = [| Exp $ SmartExp $ Pair (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) $(litE (IntegerL (toInteger tag))))) $vs |] + | otherwise = [| Exp $vs |] + + r <- sequence [ sigD fun sig + , funD fun [body] + ] + return (fun, r) + where + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + +mkNormalC_match :: Bool -> Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) +mkNormalC_match sum_type tn tvs tag cn fs0 fs fs1 = do + fun <- newName ("_match" ++ nameBase cn) + e <- newName "_e" + x <- newName "_x" + (ps,es) <- extract vs (if sum_type then [| Prj PairIdxRight $(varE x) |] else varE x) [] [] + let + lhs = [p| (Exp $(varP e)) |] + body = normalB $ caseE (varE e) + [ TH.match (conP 'SmartExp [(conP 'Match [matchP ps, varP x])]) (normalB [| Just $(tupE es) |]) [] + , TH.match (conP 'SmartExp [(recP 'Match [])]) (normalB [| Nothing |]) [] + , TH.match wildP (normalB [| error "Pattern synonym used outside 'match' context" |]) [] + ] + + r <- sequence [ sigD fun sig + , funD fun [clause [lhs] body []] + ] + return (fun, r) + where + sig = + forallT [] + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) + -> Maybe $(tupT (map (\t -> [t| Exp $(return t) |]) fs)) |] + + matchP us + | sum_type = [p| TagRtag $(litP (IntegerL (toInteger tag))) $pat |] + | otherwise = pat + where + pat = [p| $(foldl (\ps p -> [p| TagRpair $ps $p |]) [p| TagRunit |] us) |] + + extract [] _ ps es = return (ps, es) + extract (u:us) x ps es = do + _u <- newName "_u" + let x' = [| Prj PairIdxLeft (SmartExp $x) |] + if not u + then extract us x' (wildP:ps) es + else extract us x' (varP _u:ps) ([| Exp (SmartExp (Match $(varE _u) (SmartExp (Prj PairIdxRight (SmartExp $x))))) |] : es) + + vs = reverse + $ [ False | _ <- concat fs0 ] ++ [ True | _ <- fs ] ++ [ False | _ <- concat fs1 ] + + -- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of the -- (unremarkable) boilerplate for us, but since the implementation is a little -- tricky it is debatable whether or not this is a good idea... diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 16b56d2bd..1f9405eda 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} @@ -88,7 +89,7 @@ module Data.Array.Accelerate.Prelude ( (?|), -- ** Expression-level - (?), caseof, + (?), match, -- * Scalar iteration iterate, @@ -2182,17 +2183,6 @@ 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. -- @@ -2209,6 +2199,80 @@ instance IfThenElse Acc where ifThenElse = acond +-- | The 'match' operation is the core operation which enables embedded +-- pattern matching. It is applied to an n-ary scalar function, and +-- generates the necessary case-statements in the embedded code for each +-- argument. For example, given the function: +-- +-- > example1 :: Exp (Maybe Bool) -> Exp Int +-- > example1 Nothing_ = 0 +-- > example1 (Just_ False_) = 1 +-- > example1 (Just_ True_) = 2 +-- +-- In order to use this function it must be applied to the 'match' +-- operator: +-- +-- > match example1 +-- +-- Using the infix-flip operator ('Data.Function.&'), we can also write +-- case statements inline. For example, instead of this: +-- +-- > example2 x = case f x of +-- > Nothing_ -> ... -- error: embedded pattern synonym... +-- > Just_ y -> ... -- ...used outside of 'match' context +-- +-- This can be written instead as: +-- +-- > example3 x = f x & match \case +-- > Nothing_ -> ... +-- > Just_ y -> ... +-- +-- And utilising the @LambdaCase@ and @BlockArguments@ syntactic extensions. +-- +match :: Matching f => f -> f +match f = mkFun (mkMatch f) id + +data Args f where + (:->) :: Exp a -> Args b -> Args (Exp a -> b) + Result :: Args (Exp a) + +class Matching a where + type ResultT a + mkMatch :: a -> Args a -> Exp (ResultT a) + mkFun :: (Args f -> Exp (ResultT a)) + -> (Args a -> Args f) + -> a + +instance Elt a => Matching (Exp a) where + type ResultT (Exp a) = a + + mkFun f k = f (k Result) + mkMatch (Exp e) Result = + case e of + SmartExp (Match _ x) -> Exp x + _ -> Exp e + +instance (Elt e, Matching r) => Matching (Exp e -> r) where + type ResultT (Exp e -> r) = ResultT r + + mkFun f k x = mkFun f (\xs -> k (x :-> xs)) + mkMatch f (x@(Exp p) :-> xs) = + case p of + -- This first case is used when we have nested calls to 'match' + SmartExp Match{} -> mkMatch (f x) xs + + -- If there is only a single alternative, we can elide the case + -- statement at this point. This can occur when pattern matching on + -- product types + _ -> case rhs of + [(_,r)] -> Exp r + _ -> Exp (SmartExp (Case p rhs)) + where + rhs = [ (tag, unExp (mkMatch (f x') xs)) + | tag <- tagsR @e + , let x' = Exp (SmartExp (Match tag p)) ] + + -- Scalar iteration -- ---------------- diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 2ddf6b846..605a1941b 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -540,6 +540,7 @@ fvOpenExp env aenv = fv fv (FromIndex _ sh ix) = concat [ fv sh, fv ix ] fv (ShapeSize _ sh) = fv sh fv Foreign{} = [] + fv (Case e rhs) = concat [ fv e, concat [ fv c | (_,c) <- rhs ] ] 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 diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index f27ed3635..ff38957ea 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -58,6 +58,7 @@ import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Representation.Elt import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Sugar.Foreign import Data.Array.Accelerate.Type @@ -89,6 +90,10 @@ let_, in_ :: Adoc let_ = annotate Statement "let" in_ = annotate Statement "in" +case_, of_ :: Adoc +case_ = annotate Statement "case" +of_ = annotate Statement "of" + if_, then_, else_ :: Adoc if_ = annotate Statement "if" then_ = annotate Statement "then" @@ -320,6 +325,7 @@ prettyArray aR@(ArrayR _ eR) = parens . fromString . showArray (showsElt eR) aR -- Scalar expressions -- ------------------ + prettyFun :: Val aenv -> Fun aenv f -> Adoc prettyFun = prettyOpenFun Empty @@ -374,6 +380,8 @@ prettyOpenExp ctx env aenv exp = Nil -> "()" VecPack _ e -> ppF1 "vecPack" (ppE e) VecUnpack _ e -> ppF1 "vecUnpack" (ppE e) + Case x xs -> hang shiftwidth + $ vsep [ case_ <+> ppE x ctx <+> of_, prettyCase env aenv xs ] Cond p t e -> flatAlt multi single where p' = ppE p context0 @@ -508,6 +516,32 @@ prettyTuple ctx env aenv exp = case collect exp of | Just tup <- collect e1 = Just $ tup ++ [prettyOpenExp app env aenv e2] collect _ = Nothing +prettyCase + :: Val env + -> Val aenv + -> [(TagR a, OpenExp env aenv b)] + -> Adoc +prettyCase env aenv alts + = vcat + $ map (\(n,t,e) -> t <+> indent (w-n) ("->" <+> e)) alts' + where + w = maximum (map (\(n,_,_) -> n) alts') + alts' = map (\(t,e) -> let (n,t') = ppT t + e' = prettyOpenExp context0 env aenv e + in (n, t', e')) alts + + ppT :: TagR s -> (Int, Adoc) + ppT tag = let s = go tag + n = length s + in (2*n, encloseSep "" "#" "." s) + where + go :: TagR s -> [Adoc] + go TagRunit = [] + go TagRsingle{} = [] + go TagRundef{} = [pretty '.'] + go (TagRtag t r) = pretty t : go r + go (TagRpair ta tb) = go ta ++ go tb + {- prettyAtuple diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 09a2c8b65..a2a8900ef 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -7,6 +7,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -81,6 +82,7 @@ module Data.Array.Accelerate.Smart ( import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.Error import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Representation.Elt import Data.Array.Accelerate.Representation.Shape @@ -480,6 +482,11 @@ data PreSmartExp acc exp t where -> Level -- environment size at defining occurrence -> PreSmartExp acc exp t + -- Needed for embedded pattern matching + Match :: TagR t + -> exp t + -> PreSmartExp acc exp t + -- All the same constructors as 'AST.Exp', plus projection Const :: ScalarType t -> t @@ -495,7 +502,6 @@ data PreSmartExp acc exp t where -> exp (t1, t2) -> PreSmartExp acc exp t - -- SIMD vectors VecPack :: KnownNat n => VecR n s tup -> exp tup @@ -516,6 +522,10 @@ data PreSmartExp acc exp t where -> exp Int -> PreSmartExp acc exp sh + Case :: exp a + -> [(TagR a, exp b)] + -> PreSmartExp acc exp b + Cond :: exp PrimBool -> exp t -> exp t @@ -823,6 +833,7 @@ instance HasTypeR SmartExp where instance HasTypeR exp => HasTypeR (PreSmartExp acc exp) where typeR = \case Tag tp _ -> tp + Match _ e -> typeR e Const tp _ -> TupRsingle tp Nil -> TupRunit Pair e1 e2 -> typeR e1 `TupRpair` typeR e2 @@ -835,6 +846,8 @@ instance HasTypeR exp => HasTypeR (PreSmartExp acc exp) where VecUnpack vecR _ -> vecRtuple vecR ToIndex _ _ _ -> TupRsingle scalarTypeInt FromIndex shr _ _ -> shapeType shr + Case _ ((_,c):_) -> typeR c + Case{} -> $internalError "typeR" "encountered empty case" Cond _ e _ -> typeR e While t _ _ _ -> t PrimConst c -> TupRsingle $ SingleScalarType $ primConstType c @@ -1222,7 +1235,7 @@ unAccFunction f = unAcc . f . Acc mkExp :: PreSmartExp SmartAcc SmartExp (EltR t) -> Exp t mkExp = Exp . SmartExp -unExp :: Elt e => Exp e -> SmartExp (EltR e) +unExp :: Exp e -> SmartExp (EltR e) unExp (Exp e) = e unExpFunction :: (Elt a, Elt b) => (Exp a -> Exp b) -> SmartExp (EltR a) -> SmartExp (EltR b) @@ -1317,6 +1330,7 @@ showsDirection RightToLeft = ('r':) showPreExpOp :: PreSmartExp acc exp t -> String showPreExpOp (Tag _ i) = "Tag" ++ show i +showPreExpOp Match{} = "Match" showPreExpOp (Const t c) = "Const " ++ showElt (TupRsingle t) c showPreExpOp (Undef _) = "Undef" showPreExpOp Nil{} = "Nil" @@ -1326,6 +1340,7 @@ showPreExpOp VecPack{} = "VecPack" showPreExpOp VecUnpack{} = "VecUnpack" showPreExpOp ToIndex{} = "ToIndex" showPreExpOp FromIndex{} = "FromIndex" +showPreExpOp Case{} = "Case" showPreExpOp Cond{} = "Cond" showPreExpOp While{} = "While" showPreExpOp PrimConst{} = "PrimConst" diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 457ed9bb5..201eb5a08 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -41,10 +41,6 @@ module Data.Array.Accelerate.Trafo.Fusion ( ) where --- standard library -import Prelude hiding ( exp, until ) - --- friends import Data.BitSet import Data.Array.Accelerate.AST import Data.Array.Accelerate.AST.LeftHandSide @@ -72,6 +68,9 @@ import qualified Data.Array.Accelerate.Debug.Stats as Stats import System.IO.Unsafe -- for debugging #endif +import Control.Lens ( over, mapped, _2 ) +import Prelude hiding ( exp, until ) + -- Delayed Array Fusion -- ==================== @@ -1401,6 +1400,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en IndexFull x ix sl -> IndexFull x (cvtE ix) (cvtE sl) ToIndex shR' sh ix -> ToIndex shR' (cvtE sh) (cvtE ix) FromIndex shR' sh i -> FromIndex shR' (cvtE sh) (cvtE i) + Case e rhs -> Case (cvtE e) (over (mapped . _2) cvtE rhs) Cond p t e -> Cond (cvtE p) (cvtE t) (cvtE e) PrimConst c -> PrimConst c PrimApp g x -> PrimApp g (cvtE x) diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 3fd0c04c3..c98585b75 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -10,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -70,6 +71,7 @@ import qualified Data.Array.Accelerate.Sugar.Array as Sugar import qualified Data.Array.Accelerate.Representation.Stencil as R import Control.Applicative hiding ( Const ) +import Control.Lens ( over, mapped, _2 ) import Control.Monad.Fix import Data.Hashable import Data.List ( elemIndex, findIndex, groupBy, intercalate, partition ) @@ -77,10 +79,10 @@ import Data.Maybe import System.IO.Unsafe ( unsafePerformIO ) import System.Mem.StableName 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 qualified Data.HashTable.IO as Hash +import qualified Data.IntMap as IntMap import Prelude @@ -731,6 +733,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp cvt (ScopedExp _ (ExpSharing _ pexp)) = case pexp of Tag tp i -> expVars $ prjIdx ("de Bruijn conversion tag " ++ show i) shows matchTypeR tp i lyt + Match _ e -> cvt e -- XXX: this should probably be an error Const tp v -> AST.Const tp v Undef tp -> AST.Undef tp Prj idx e -> cvtPrj idx (cvt e) @@ -740,6 +743,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp VecUnpack vec e -> AST.VecUnpack vec (cvt e) ToIndex shr sh ix -> AST.ToIndex shr (cvt sh) (cvt ix) FromIndex shr sh e -> AST.FromIndex shr (cvt sh) (cvt e) + Case e rhs -> AST.Case (cvt e) (over (mapped . _2) cvt rhs) Cond e1 e2 e3 -> AST.Cond (cvt e1) (cvt e2) (cvt e3) While tp p it i -> AST.While (cvtFun1 tp p) (cvtFun1 tp it) (cvt i) PrimConst c -> AST.PrimConst c @@ -1668,6 +1672,11 @@ makeOccMapSharingExp config accOccMap expOccMap = travE VecUnpack vec e -> travE1 (VecUnpack vec) e ToIndex shr sh ix -> travE2 (ToIndex shr) sh ix FromIndex shr sh e -> travE2 (FromIndex shr) sh e + Match t e -> travE1 (Match t) e + Case e rhs -> do + (e', h1) <- travE lvl e + (rhs', h2) <- unzip <$> sequence [ travE1 (t,) c | (t,c) <- rhs ] + return (Case e' rhs', h1 `max` maximum h2 + 1) Cond e1 e2 e3 -> travE3 Cond e1 e2 e3 While t p iter init -> do (p' , h1) <- traverseFun1 lvl t p @@ -1700,25 +1709,29 @@ makeOccMapSharingExp config accOccMap expOccMap = travE return (const (UnscopedExp [lvl] body), height + 1) - travE1 :: (UnscopedExp b -> PreSmartExp UnscopedAcc UnscopedExp a) -> SmartExp b - -> IO (PreSmartExp UnscopedAcc UnscopedExp a, Int) + travE1 :: (UnscopedExp b -> r) + -> SmartExp b + -> IO (r, Int) travE1 c e = do (e', h) <- travE lvl e return (c e', h + 1) - travE2 :: (UnscopedExp b -> UnscopedExp c -> PreSmartExp UnscopedAcc UnscopedExp a) - -> SmartExp b -> SmartExp c - -> IO (PreSmartExp UnscopedAcc UnscopedExp a, Int) + travE2 :: (UnscopedExp b -> UnscopedExp c -> r) + -> SmartExp b + -> SmartExp c + -> IO (r, 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 :: (UnscopedExp b -> UnscopedExp c -> UnscopedExp d -> PreSmartExp UnscopedAcc UnscopedExp a) - -> SmartExp b -> SmartExp c -> SmartExp d - -> IO (PreSmartExp UnscopedAcc UnscopedExp a, Int) + travE3 :: (UnscopedExp b -> UnscopedExp c -> UnscopedExp d -> r) + -> SmartExp b + -> SmartExp c + -> SmartExp d + -> IO (r, Int) travE3 c e1 e2 e3 = do (e1', h1) <- travE lvl e1 @@ -1726,16 +1739,18 @@ makeOccMapSharingExp config accOccMap expOccMap = travE (e3', h3) <- travE lvl e3 return (c e1' e2' e3', h1 `max` h2 `max` h3 + 1) - travA :: (UnscopedAcc b -> PreSmartExp UnscopedAcc UnscopedExp a) -> SmartAcc b - -> IO (PreSmartExp UnscopedAcc UnscopedExp a, Int) + travA :: (UnscopedAcc b -> r) + -> SmartAcc b + -> IO (r, Int) travA c acc = do (acc', h) <- traverseAcc lvl acc return (c acc', h + 1) - travAE :: (UnscopedAcc b -> UnscopedExp c -> PreSmartExp UnscopedAcc UnscopedExp a) - -> SmartAcc b -> SmartExp c - -> IO (PreSmartExp UnscopedAcc UnscopedExp a, Int) + travAE :: (UnscopedAcc b -> UnscopedExp c -> r) + -> SmartAcc b + -> SmartExp c + -> IO (r, Int) travAE c acc e = do (acc', h1) <- traverseAcc lvl acc @@ -2516,12 +2531,15 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp VecUnpack vec e -> travE1 (VecUnpack vec) e ToIndex shr sh ix -> travE2 (ToIndex shr) sh ix FromIndex shr sh e -> travE2 (FromIndex shr) sh e + Match t e -> travE1 (Match t) e + Case e rhs -> let (e', accCount1) = scopesExp e + (rhs', accCount2) = unzip [ ((t,c'), counts)| (t,c) <- rhs, let (c', counts) = scopesExp c ] + in reconstruct (Case e' rhs') (foldr (+++) accCount1 accCount2) Cond e1 e2 e3 -> travE3 Cond e1 e2 e3 - While tp p it i -> let - (p' , accCount1) = scopesFun1 p - (it', accCount2) = scopesFun1 it - (i' , accCount3) = scopesExp i - in reconstruct (While tp p' it' i') (accCount1 +++ accCount2 +++ accCount3) + While tp p it i -> let (p' , accCount1) = scopesFun1 p + (it', accCount2) = scopesFun1 it + (i' , accCount3) = scopesExp i + in reconstruct (While tp p' it' i') (accCount1 +++ accCount2 +++ accCount3) PrimConst c -> reconstruct (PrimConst c) noNodeCounts PrimApp p e -> travE1 (PrimApp p) e Index tp a e -> travAE (Index tp) a e diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 39b2bea57..f0588ada8 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -55,14 +56,10 @@ import Data.Array.Accelerate.Trafo.Substitution import qualified Data.Array.Accelerate.Debug.Stats as Stats import Control.Applicative hiding ( Const ) -import Prelude hiding ( exp, seq ) import Data.Maybe ( isJust ) - -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup -#else import Data.Monoid -#endif +import Data.Semigroup +import Prelude hiding ( exp, seq ) data VarsRange env = @@ -163,6 +160,9 @@ instance Semigroup Count where _ <> Infinity = Infinity Finite a <> Finite b = Finite $ a + b +instance Monoid Count where + mempty = Finite 0 + loopCount :: Count -> Count loopCount (Finite n) | n > 0 = Infinity loopCount c = c @@ -288,6 +288,7 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE IndexFull x ix sl -> IndexFull x <$> shrinkE ix <*> shrinkE sl ToIndex shr sh ix -> ToIndex shr <$> shrinkE sh <*> shrinkE ix FromIndex shr sh i -> FromIndex shr <$> shrinkE sh <*> shrinkE i + Case e rhs -> Case <$> shrinkE e <*> sequenceA [ (t,) <$> shrinkE c | (t,c) <- rhs ] 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) @@ -484,6 +485,7 @@ usesOfExp range = countE IndexFull _ ix sl -> countE ix <> countE sl FromIndex _ sh i -> countE sh <> countE i ToIndex _ sh e -> countE sh <> countE e + Case e rhs -> countE e <> mconcat [ countE c | (_,c) <- rhs ] Cond p t e -> countE p <> countE t <> countE e While p f x -> countE x <> loopCount (usesOfFun range p) <> loopCount (usesOfFun range f) PrimConst _ -> Finite 0 @@ -505,6 +507,8 @@ usesOfFun range (Body b) = usesOfExp range b -- type UsesOfAcc acc = forall aenv s t. Bool -> Idx aenv s -> acc aenv t -> Int +-- XXX: Should this be converted to use the above 'Count' semigroup? +-- usesOfPreAcc :: forall acc aenv s t. Bool @@ -567,6 +571,7 @@ usesOfPreAcc withShape countAcc idx = count IndexFull _ ix sl -> countE ix + countE sl ToIndex _ sh ix -> countE sh + countE ix FromIndex _ sh i -> countE sh + countE i + Case e rhs -> countE e + sum [ countE c | (_,c) <- rhs ] Cond p t e -> countE p + countE t + countE e While p f x -> countF p + countF f + countE x PrimConst _ -> 0 diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index af1e9596c..0e6161df2 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -224,6 +225,7 @@ simplifyOpenExp env = first getAny . cvtE IndexFull x ix sl -> IndexFull x <$> cvtE ix <*> cvtE sl ToIndex shr sh ix -> toIndex shr (cvtE sh) (cvtE ix) FromIndex shr sh ix -> fromIndex shr (cvtE sh) (cvtE ix) + Case e rhs -> Case <$> cvtE e <*> sequenceA [ (t,) <$> cvtE c | (t,c) <- rhs ] Cond p t e -> cond (cvtE p) (cvtE t) (cvtE e) PrimConst c -> pure $ PrimConst c PrimApp f x -> (u<>v, fx) @@ -417,6 +419,12 @@ 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 +instance Semigroup Stats where + (<>) = (+++) + +instance Monoid Stats where + mempty = Stats 0 0 0 0 0 + 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) @@ -501,6 +509,7 @@ summariseOpenExp = (terms +~ 1) . goE 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 + Case e rhs -> travE e +++ mconcat [ travE c | (_,c) <- rhs ] Cond p t e -> travE p +++ travE t +++ travE e While p f x -> travF p +++ travF f +++ travE x PrimConst c -> travC c diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 2aa751b44..f54a4dafc 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -145,7 +146,7 @@ inlineVars lhsBound expr bound -> Maybe (OpenExp env2 aenv t) substitute _ k2 vars (extractExpVars -> Just vars') | Just Refl <- matchVars vars vars' = Just $ weakenE k2 bound - substitute k1 k2 vars e = case e of + substitute k1 k2 vars topExp = case topExp of Let lhs e1 e2 | Exists lhs' <- rebuildLHS lhs -> Let lhs' <$> travE e1 <*> substitute (strengthenAfter lhs lhs' k1) (weakenWithLHS lhs' .> k2) (weakenWithLHS lhs `weakenVars` vars) e2 @@ -159,6 +160,7 @@ inlineVars lhsBound expr bound IndexFull si e1 e2 -> IndexFull si <$> travE e1 <*> travE e2 ToIndex shr e1 e2 -> ToIndex shr <$> travE e1 <*> travE e2 FromIndex shr e1 e2 -> FromIndex shr <$> travE e1 <*> travE e2 + Case e1 rhs -> Case <$> travE e1 <*> mapM (\(t,c) -> (t,) <$> travE c) rhs Cond e1 e2 e3 -> Cond <$> travE e1 <*> travE e2 <*> travE e3 While f1 f2 e1 -> While <$> travF f1 <*> travF f2 <*> travE e1 Const t c -> Just $ Const t c @@ -554,8 +556,9 @@ rebuildOpenExp v av@(ReindexAvar reindex) exp = IndexFull x ix sl -> IndexFull x <$> rebuildOpenExp v av ix <*> rebuildOpenExp v av sl ToIndex shr sh ix -> ToIndex shr <$> rebuildOpenExp v av sh <*> rebuildOpenExp v av ix FromIndex shr sh ix -> FromIndex shr <$> rebuildOpenExp v av sh <*> rebuildOpenExp v av ix + Case e rhs -> Case <$> rebuildOpenExp v av e <*> sequenceA [ (t,) <$> rebuildOpenExp v av c | (t,c) <- rhs ] Cond p t e -> Cond <$> rebuildOpenExp v av p <*> rebuildOpenExp v av t <*> rebuildOpenExp v av e - While p f x -> While <$> rebuildFun v av p <*> rebuildFun v av f <*> rebuildOpenExp v av x + While p f x -> While <$> rebuildFun v av p <*> rebuildFun v av f <*> rebuildOpenExp v av x PrimApp f x -> PrimApp f <$> rebuildOpenExp v av x Index a sh -> Index <$> reindex a <*> rebuildOpenExp v av sh LinearIndex a i -> LinearIndex <$> reindex a <*> rebuildOpenExp v av i From 88f60d3eccd9de277b50bd6ffdce821c18aeebab Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 26 Jun 2020 01:30:10 +0200 Subject: [PATCH 258/316] warning police --- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs index 6235c34ae..3fd518259 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs @@ -28,7 +28,7 @@ import Data.Array.Accelerate.Test.NoFib.Config import Test.Tasty import Test.Tasty.HUnit -import Data.List as P +import Data.List as P ( mapAccumL ) import Prelude as P From 86593f9d86a8e9a146091108edc38f3063cf2139 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 26 Jun 2020 01:30:53 +0200 Subject: [PATCH 259/316] use call stacks for partial functions --- src/Data/Array/Accelerate/AST.hs | 5 +- src/Data/Array/Accelerate/AST/Environment.hs | 7 +- src/Data/Array/Accelerate/Array/Data.hs | 7 +- src/Data/Array/Accelerate/Array/Remote/LRU.hs | 56 +- .../Array/Accelerate/Array/Remote/Nursery.hs | 11 +- .../Array/Accelerate/Array/Remote/Table.hs | 10 +- .../Array/Accelerate/Classes/RealFloat.hs | 7 +- src/Data/Array/Accelerate/Error.hs | 131 ++--- src/Data/Array/Accelerate/Interpreter.hs | 99 ++-- src/Data/Array/Accelerate/Pretty.hs | 8 +- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 58 +-- .../Array/Accelerate/Representation/Array.hs | 6 +- .../Array/Accelerate/Representation/Shape.hs | 15 +- src/Data/Array/Accelerate/Smart.hs | 9 +- src/Data/Array/Accelerate/Sugar/Foreign.hs | 6 +- .../Array/Accelerate/Trafo/Environment.hs | 7 +- src/Data/Array/Accelerate/Trafo/Fusion.hs | 189 ++++--- src/Data/Array/Accelerate/Trafo/Sharing.hs | 491 +++++++++++------- src/Data/Array/Accelerate/Trafo/Shrink.hs | 53 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 12 +- .../Array/Accelerate/Trafo/Substitution.hs | 31 +- 21 files changed, 702 insertions(+), 516 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index c9a2e366a..74183b063 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -152,6 +152,7 @@ import Language.Haskell.TH ( Q, TExp ) import Prelude import GHC.TypeLits +import GHC.Stack -- Array expressions @@ -784,7 +785,7 @@ instance HasArraysR acc => HasArraysR (PreOpenAcc acc) where arraysR (Stencil2 _ _ tR _ _ a _ _) = let ArrayR sh _ = arrayR a in arraysRarray sh tR -expType :: OpenExp aenv env t -> TypeR t +expType :: HasCallStack => OpenExp aenv env t -> TypeR t expType = \case Let _ _ body -> expType body Evar (Var tR _) -> TupRsingle tR @@ -798,7 +799,7 @@ expType = \case ToIndex{} -> TupRsingle scalarTypeInt FromIndex shr _ _ -> shapeType shr Case _ ((_,e):_) -> expType e - Case _ [] -> $internalError "expType" "empty case encountered" + Case _ [] -> internalError "empty case encountered" Cond _ e _ -> expType e While _ (Lam lhs _) _ -> lhsToTupR lhs While{} -> error "What's the matter, you're running in the shadows" diff --git a/src/Data/Array/Accelerate/AST/Environment.hs b/src/Data/Array/Accelerate/AST/Environment.hs index 3942c5a00..6e0c2d3be 100644 --- a/src/Data/Array/Accelerate/AST/Environment.hs +++ b/src/Data/Array/Accelerate/AST/Environment.hs @@ -3,7 +3,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -23,6 +22,8 @@ import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.AST.LeftHandSide import Data.Array.Accelerate.Error +import GHC.Stack + -- Valuation for an environment -- @@ -75,11 +76,11 @@ infixr 9 .> (.>) :: env2 :> env3 -> env1 :> env2 -> env1 :> env3 (.>) (Weaken f) (Weaken g) = Weaken (f . g) -sinkWithLHS :: LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> env1 :> env2 -> env1' :> env2' +sinkWithLHS :: HasCallStack => LeftHandSide s t env1 env1' -> LeftHandSide s t env2 env2' -> env1 :> env2 -> env1' :> env2' sinkWithLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k sinkWithLHS (LeftHandSideSingle _) (LeftHandSideSingle _) k = sink k sinkWithLHS (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k = sinkWithLHS b1 b2 $ sinkWithLHS a1 a2 k -sinkWithLHS _ _ _ = $internalError "sinkWithLHS" "left hand sides do not match" +sinkWithLHS _ _ _ = internalError "left hand sides do not match" weakenWithLHS :: forall s t env env'. LeftHandSide s t env env' -> env :> env' weakenWithLHS = go weakenId diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index aa1ed0c4f..6d19339d7 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -77,6 +77,7 @@ import Prelude hiding ( map import GHC.Base import GHC.ForeignPtr import GHC.Ptr +import GHC.Stack -- | Immutable array representation @@ -198,7 +199,7 @@ singleArrayDict = single -- Array operations -- ---------------- -newArrayData :: TupR ScalarType e -> Int -> IO (MutableArrayData e) +newArrayData :: HasCallStack => TupR ScalarType e -> Int -> IO (MutableArrayData e) newArrayData TupRunit !_ = return () newArrayData (TupRpair t1 t2) !size = (,) <$> newArrayData t1 size <*> newArrayData t2 size newArrayData (TupRsingle t) !size @@ -303,9 +304,9 @@ runArrayData st = unsafePerformIO $ do -- spaces (e.g. GPUs), we will not increase host memory pressure simply to track -- intermediate arrays that contain meaningful data only on the device. -- -allocateArray :: forall e. Storable e => Int -> IO (UniqueArray e) +allocateArray :: forall e. (HasCallStack, Storable e) => Int -> IO (UniqueArray e) allocateArray !size - = $internalCheck "newArrayData" "size must be >= 0" (size >= 0) + = internalCheck "size must be >= 0" (size >= 0) $ newUniqueArray <=< unsafeInterleaveIO $ do let bytes = size * sizeOf (undefined :: e) new <- readIORef __mallocForeignPtrBytes diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs index 858594079..e09c01db2 100644 --- a/src/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/src/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -8,7 +8,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -63,6 +62,8 @@ import System.Mem.Weak ( Weak, deRefWea import Prelude hiding ( lookup ) import qualified Data.HashTable.IO as HT +import GHC.Stack + -- We build cached memory tables on top of a basic memory table. -- @@ -137,7 +138,7 @@ new release = do -- more accesses of the remote pointer. -- withRemote - :: forall task m a c. (Task task, RemoteMemory m, MonadIO m, Functor m) + :: forall task m a c. (HasCallStack, Task task, RemoteMemory m, MonadIO m, Functor m) => MemoryTable (RemotePtr m) task -> SingleType a -> ArrayData a @@ -162,7 +163,7 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run | SingleArrayDict <- singleArra Nothing | isEvicted u -> copyBack utbl (incCount u) | otherwise -> do message ("lost array " ++ show key) - $internalError "withRemote" "non-evicted array has been lost" + internalError "non-evicted array has been lost" return (Just ptr) -- case mp of @@ -175,26 +176,29 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run | SingleArrayDict <- singleArra tasks' <- cleanUses tasks return (Used ts status (count - 1) (task : tasks') n tp' weak_arr) - copyBack :: UT task -> Used task -> m (RemotePtr m (ScalarArrayDataR a)) + copyBack :: HasCallStack => UT task -> Used task -> m (RemotePtr m (ScalarArrayDataR a)) copyBack utbl (Used ts _ count tasks n tp' weak_arr) | Just Refl <- matchSingleType tp tp' = do message "withRemote/reuploading-evicted-array" p <- mallocWithUsage mt utbl tp arr (Used ts Clean count tasks n tp weak_arr) pokeRemote tp n p arr return p - | otherwise = $internalError "withRemote" "Type mismatch" + | otherwise = internalError "Type mismatch" -- 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 :: ArrayData a ~ ScalarArrayData a => StableArray -> RemotePtr m (ScalarArrayDataR a) -> m c + go :: (HasCallStack, ArrayData a ~ ScalarArrayData a) + => StableArray + -> RemotePtr m (ScalarArrayDataR a) + -> 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" + Nothing -> internalError "invariant violated" Just u -> do u' <- updateTask u task return (Just u', ()) @@ -218,7 +222,7 @@ withRemote (MemoryTable !mt !ref _) !tp !arr run | SingleArrayDict <- singleArra -- On return, 'True' indicates that we allocated some remote memory, and 'False' -- indicates that we did not need to. -- -malloc :: forall e m task. (RemoteMemory m, MonadIO m, Task task) +malloc :: forall e m task. (HasCallStack, RemoteMemory m, MonadIO m, Task task) => MemoryTable (RemotePtr m) task -> SingleType e -> ArrayData e @@ -244,7 +248,7 @@ malloc (MemoryTable mt ref weak_utbl) !tp !ad !frozen !n | SingleArrayDict <- si return False mallocWithUsage - :: forall e m task. (RemoteMemory m, MonadIO m, Task task, ArrayData e ~ ScalarArrayData e) + :: forall e m task. (HasCallStack, RemoteMemory m, MonadIO m, Task task, ArrayData e ~ ScalarArrayData e) => Basic.MemoryTable (RemotePtr m) -> UT task -> SingleType e @@ -253,21 +257,21 @@ mallocWithUsage -> m (RemotePtr m (ScalarArrayDataR e)) mallocWithUsage !mt !utbl !tp !ad !usage@(Used _ _ _ _ n _ _) = malloc' where - malloc' :: m (RemotePtr m (ScalarArrayDataR e)) + malloc' :: HasCallStack => m (RemotePtr m (ScalarArrayDataR e)) malloc' = do mp <- Basic.malloc @e @m mt tp ad n :: m (Maybe (RemotePtr m (ScalarArrayDataR e))) case mp of Nothing -> do success <- evictLRU utbl mt if success then malloc' - else $internalError "malloc" "Remote memory exhausted" + else internalError "Remote memory exhausted" Just p -> liftIO $ do key <- Basic.makeStableArray tp ad HT.insert utbl key usage return p evictLRU - :: forall m task. (RemoteMemory m, MonadIO m, Task task) + :: forall m task. (HasCallStack, RemoteMemory m, MonadIO m, Task task) => UT task -> Basic.MemoryTable (RemotePtr m) -> m Bool @@ -300,15 +304,17 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do 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 tp weak_arr)) | count == 0 - , evictable status = do - tasks' <- cleanUses tasks - HT.insert utbl sa (Used ts status count tasks' n tp 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 (sa, used@(Used ts status count tasks n tp weak_arr)) + | count == 0 + , evictable status + = do + tasks' <- cleanUses tasks + HT.insert utbl sa (Used ts status count tasks' n tp 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 :: SingleType e -> Int -> Int64 @@ -323,7 +329,7 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do copyIfNecessary :: Status -> Int -> SingleType e -> ArrayData e -> m () copyIfNecessary Clean _ _ _ = return () copyIfNecessary Unmanaged _ _ _ = return () - copyIfNecessary Evicted _ _ _ = $internalError "evictLRU" "Attempting to evict already evicted array" + copyIfNecessary Evicted _ _ _ = internalError "Attempting to evict already evicted array" copyIfNecessary Dirty n tp ad = do mp <- liftIO $ Basic.lookup @m mt tp ad case mp of @@ -334,7 +340,7 @@ evictLRU !utbl !mt = trace "evictLRU/evicting-eldest-array" $ do -- Typically this should only be called in very specific circumstances. This -- operation is not thread-safe. -- -free :: forall m a task. (RemoteMemory m) +free :: forall m a task. (HasCallStack, RemoteMemory m) => MemoryTable (RemotePtr m) task -> SingleType a -> ArrayData a @@ -353,7 +359,7 @@ free (MemoryTable !mt !ref _) !tp !arr -- This typically only has use for backends that provide an FFI. -- insertUnmanaged - :: (MonadIO m, RemoteMemory m) + :: (HasCallStack, MonadIO m, RemoteMemory m) => MemoryTable (RemotePtr m) task -> SingleType e -> ArrayData e @@ -388,7 +394,7 @@ delete = HT.delete -- have matching host-side equivalents. -- reclaim - :: forall m task. (RemoteMemory m, MonadIO m) + :: forall m task. (HasCallStack, RemoteMemory m, MonadIO m) => MemoryTable (RemotePtr m) task -> m () reclaim (MemoryTable !mt _ _) = Basic.reclaim mt diff --git a/src/Data/Array/Accelerate/Array/Remote/Nursery.hs b/src/Data/Array/Accelerate/Array/Remote/Nursery.hs index 007c685fc..816a30b8f 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Nursery.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Nursery.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} -- | -- Module : Data.Array.Accelerate.Array.Remote.Nursery -- Copyright : [2008..2019] The Accelerate Team @@ -32,6 +31,8 @@ import qualified Data.HashTable.IO as HT import qualified Data.Sequence as Seq import qualified Data.Traversable as Seq +import GHC.Stack + -- 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 @@ -64,7 +65,7 @@ new delete = do -- | Look for an entry with the requested size. -- {-# INLINEABLE lookup #-} -lookup :: Int -> Nursery ptr -> IO (Maybe (ptr Word8)) +lookup :: HasCallStack => Int -> Nursery ptr -> IO (Maybe (ptr Word8)) lookup !key (Nursery !ref !_) = withMVar ref $ \nrs -> HT.mutateIO nrs key $ \case @@ -77,7 +78,7 @@ lookup !key (Nursery !ref !_) = 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" + Seq.EmptyL -> internalError "expected non-empty sequence" -- | Add an entry to the nursery diff --git a/src/Data/Array/Accelerate/Array/Remote/Table.hs b/src/Data/Array/Accelerate/Array/Remote/Table.hs index 2a170c2fb..e7f77f69c 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Table.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Table.hs @@ -8,7 +8,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} @@ -65,6 +64,8 @@ import Data.Array.Accelerate.Lifetime import qualified Data.Array.Accelerate.Array.Remote.Nursery as N import qualified Data.Array.Accelerate.Debug as D +import GHC.Stack + -- 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 @@ -119,8 +120,7 @@ new release = do -- | Look for the remote pointer corresponding to a given host-side array. -- -lookup :: forall m a. - RemoteMemory m +lookup :: forall m a. (HasCallStack, RemoteMemory m) => MemoryTable (RemotePtr m) -> SingleType a -> ArrayData a @@ -149,7 +149,7 @@ lookup (MemoryTable !ref _ _ _) !tp !arr -- above in the error message. -- Nothing -> - makeStableArray tp arr >>= \x -> $internalError "lookup" $ "dead weak pair: " ++ show x + makeStableArray tp arr >>= \x -> internalError $ "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. @@ -157,7 +157,7 @@ lookup (MemoryTable !ref _ _ _) !tp !arr -- arrays will be re-used. In the event that the remote memory is exhausted, -- 'Nothing' is returned. -- -malloc :: forall a m. (RemoteMemory m, MonadIO m) +malloc :: forall a m. (HasCallStack, RemoteMemory m, MonadIO m) => MemoryTable (RemotePtr m) -> SingleType a -> ArrayData a diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs b/src/Data/Array/Accelerate/Classes/RealFloat.hs index e898b385d..5d1200210 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -44,6 +43,8 @@ import Text.Printf import Prelude ( (.), ($), String, error, undefined, unlines, otherwise ) import qualified Prelude as P +import GHC.Stack + -- | Efficient, machine-independent access to the components of a floating-point -- number @@ -201,10 +202,10 @@ preludeError x ] -ieee754 :: forall a b. P.RealFloat a => String -> (Exp a -> b) -> Exp a -> b +ieee754 :: forall a b. HasCallStack => 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" + | otherwise = internalError (printf "%s: Not implemented for non-IEEE floating point" name) -- From: ghc/libraries/base/cbits/primFloat.c -- ------------------------------------------ diff --git a/src/Data/Array/Accelerate/Error.hs b/src/Data/Array/Accelerate/Error.hs index 7e12eef7a..0dac94bd5 100644 --- a/src/Data/Array/Accelerate/Error.hs +++ b/src/Data/Array/Accelerate/Error.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Error @@ -21,25 +18,25 @@ module Data.Array.Accelerate.Error ( ) where -import Data.List ( intercalate ) import Debug.Trace -import Language.Haskell.TH hiding ( Unsafe ) +import Text.Printf +import Prelude hiding ( error ) + +import GHC.Stack data Check = Bounds | Unsafe | Internal -- | Issue an internal error message -- --- $internalError :: String -> String -> a --- -internalError :: Q Exp -internalError = appE errorQ [| Internal |] +internalError :: HasCallStack => String -> a +internalError = withFrozenCallStack $ error Internal -boundsError :: Q Exp -boundsError = appE errorQ [| Bounds |] +boundsError :: HasCallStack => String -> a +boundsError = withFrozenCallStack $ error Bounds -unsafeError :: Q Exp -unsafeError = appE errorQ [| Unsafe |] +unsafeError :: HasCallStack => String -> a +unsafeError = withFrozenCallStack $ error Unsafe -- | Throw an error if the condition evaluates to False, otherwise evaluate the @@ -47,95 +44,61 @@ unsafeError = appE errorQ [| Unsafe |] -- -- $internalCheck :: String -> String -> Bool -> a -> a -- -internalCheck :: Q Exp -internalCheck = appE checkQ [| Internal |] +internalCheck :: HasCallStack => String -> Bool -> a -> a +internalCheck = withFrozenCallStack $ check Internal -boundsCheck :: Q Exp -boundsCheck = appE checkQ [| Bounds |] +boundsCheck :: HasCallStack => String -> Bool -> a -> a +boundsCheck = withFrozenCallStack $ check Bounds -unsafeCheck :: Q Exp -unsafeCheck = appE checkQ [| Unsafe |] +unsafeCheck :: HasCallStack => String -> Bool -> a -> a +unsafeCheck = withFrozenCallStack $ check 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 |] - +indexCheck :: HasCallStack => Int -> Int -> a -> a +indexCheck i n = + boundsCheck (printf "index out of bounds: i=%d, n=%d" i n) (i >= 0 && i < n) -- | 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 |] +internalWarning :: HasCallStack => String -> Bool -> a -> a +internalWarning = withFrozenCallStack $ warning Internal -unsafeWarning :: Q Exp -unsafeWarning = appE warningQ [| Unsafe |] +boundsWarning :: HasCallStack => String -> Bool -> a -> a +boundsWarning = withFrozenCallStack $ warning Bounds +unsafeWarning :: HasCallStack => String -> Bool -> a -> a +unsafeWarning = withFrozenCallStack $ warning Unsafe --- Template Haskell implementation --- ------------------------------- -call :: String -> String -> String -call f m = concat ["(", f, "): ", m] +error :: HasCallStack => Check -> String -> a +error kind msg = errorWithoutStackTrace (format kind msg) -errorQ :: Q Exp -errorQ = withLocation - [| \format kind fn msg -> errorWithoutStackTrace (format kind (call fn msg)) |] +check :: HasCallStack => Check -> String -> Bool -> a -> a +check kind msg cond k = + case not (doChecks kind) || cond of + True -> k + False -> errorWithoutStackTrace (format kind 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)) |] +warning :: HasCallStack => Check -> String -> Bool -> a -> a +warning kind msg cond k = + case not (doChecks kind) || cond of + True -> k + False -> trace (format kind msg) k -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 +format :: HasCallStack => Check -> String -> String +format kind msg = unlines [ header, msg, "", prettyCallStack callStack ] 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 + header + = unlines + $ case kind of + Internal -> ["" + ,"*** Internal error in package accelerate ***" + ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"] + _ -> [] -- CPP malarky diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 0f2c169fb..ff2ccff2c 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -7,7 +7,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -79,13 +78,15 @@ import Text.Printf ( printf ) import Unsafe.Coerce import Prelude hiding ( (!!), sum ) +import GHC.Stack + -- Program execution -- ----------------- -- | Run a complete embedded array program using the reference interpreter. -- -run :: Sugar.Arrays a => Smart.Acc a -> a +run :: (HasCallStack, Sugar.Arrays a) => Smart.Acc a -> a run a = unsafePerformIO execute where !acc = convertAcc a @@ -97,12 +98,12 @@ run a = unsafePerformIO execute -- | This is 'runN' specialised to an array program of one argument. -- -run1 :: (Sugar.Arrays a, Sugar.Arrays b) => (Smart.Acc a -> Smart.Acc b) -> a -> b +run1 :: (HasCallStack, Sugar.Arrays a, Sugar.Arrays b) => (Smart.Acc a -> Smart.Acc b) -> a -> b run1 = runN -- | Prepare and execute an embedded array program. -- -runN :: forall f. Afunction f => f -> AfunctionR f +runN :: forall f. (HasCallStack, Afunction f) => f -> AfunctionR f runN f = go where !acc = convertAfun f @@ -160,7 +161,7 @@ fromFunction' repr sh f = (TupRsingle repr, fromFunction repr sh f) -- Evaluate an open array function -- -evalOpenAfun :: DelayedOpenAfun aenv f -> Val aenv -> f +evalOpenAfun :: HasCallStack => DelayedOpenAfun aenv f -> Val aenv -> f evalOpenAfun (Alam lhs f) aenv = \a -> evalOpenAfun f $ aenv `push` (lhs, a) evalOpenAfun (Abody b) aenv = snd $ evalOpenAcc b aenv @@ -168,14 +169,14 @@ evalOpenAfun (Abody b) aenv = snd $ evalOpenAcc b aenv -- The core interpreter for optimised array programs -- evalOpenAcc - :: forall aenv a. - DelayedOpenAcc aenv a + :: forall aenv a. HasCallStack + => DelayedOpenAcc aenv a -> Val aenv -> WithReprs a -evalOpenAcc AST.Delayed{} _ = $internalError "evalOpenAcc" "expected manifest array" +evalOpenAcc AST.Delayed{} _ = internalError "expected manifest array" evalOpenAcc (AST.Manifest pacc) aenv = let - manifest :: forall a'. DelayedOpenAcc aenv a' -> WithReprs a' + manifest :: forall a'. HasCallStack => DelayedOpenAcc aenv a' -> WithReprs a' manifest acc = let (repr, a') = evalOpenAcc acc aenv in rnfArraysR repr a' `seq` (repr, a') @@ -281,12 +282,13 @@ transformOp repr sh' p f (Delayed _ _ xs _) reshapeOp - :: ShapeR sh + :: HasCallStack + => ShapeR sh -> sh -> WithReprs (Array sh' e) -> WithReprs (Array sh e) reshapeOp newShapeR newShape (TupRsingle (ArrayR shr tp), (Array sh adata)) - = $boundsCheck "reshape" "shape mismatch" (size newShapeR newShape == size shr sh) + = boundsCheck "shape mismatch" (size newShapeR newShape == size shr sh) ( TupRsingle (ArrayR newShapeR tp) , Array newShape adata ) @@ -328,10 +330,12 @@ sliceOp slice (TupRsingle repr@(ArrayR _ tp), arr) slix repr' = ArrayR (sliceShapeR slice) tp (sh', pf) = restrict slice slix (shape arr) - restrict :: SliceIndex slix sl co sh - -> slix - -> sh - -> (sl, sl -> sh) + restrict + :: HasCallStack + => SliceIndex slix sl co sh + -> slix + -> sh + -> (sl, sl -> sh) restrict SliceNil () () = ((), const ()) restrict (SliceAll sliceIdx) (slx, ()) (sl, sz) @@ -339,7 +343,7 @@ sliceOp slice (TupRsingle repr@(ArrayR _ tp), arr) slix 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)) + in indexCheck i sz $ (sl', \ix -> (f' ix, i)) mapOp :: TypeR b @@ -370,16 +374,18 @@ foldOp f z (Delayed (ArrayR (ShapeRsnoc shr) tp) (sh, n) arr _) fold1Op - :: (e -> e -> e) + :: HasCallStack + => (e -> e -> e) -> Delayed (Array (sh, Int) e) -> WithReprs (Array sh e) fold1Op f (Delayed (ArrayR (ShapeRsnoc shr) tp) (sh, n) arr _) - = $boundsCheck "fold1" "empty array" (n > 0) + = boundsCheck "empty array" (n > 0) $ fromFunction' (ArrayR shr tp) sh (\ix -> iter1 (ShapeRsnoc ShapeRz) ((), n) (\((), i) -> arr (ix, i)) f) foldSegOp - :: IntegralType i + :: HasCallStack + => IntegralType i -> (e -> e -> e) -> e -> Delayed (Array (sh, Int) e) @@ -387,39 +393,40 @@ foldSegOp -> WithReprs (Array (sh, Int) e) foldSegOp itp f z (Delayed repr (sh, _) arr _) (Delayed _ ((), n) _ seg) | IntegralDict <- integralDict itp - = $boundsCheck "foldSeg" "empty segment descriptor" (n > 0) + = boundsCheck "empty segment descriptor" (n > 0) $ fromFunction' repr (sh, n-1) $ \(sz, ix) -> let start = fromIntegral $ seg ix end = fromIntegral $ seg (ix+1) in - $boundsCheck "foldSeg" "empty segment" (end >= start) + boundsCheck "empty segment" (end >= start) $ iter (ShapeRsnoc ShapeRz) ((), end-start) (\((), i) -> arr (sz, start+i)) f z fold1SegOp - :: IntegralType i + :: HasCallStack + => IntegralType i -> (e -> e -> e) -> Delayed (Array (sh, Int) e) -> Delayed (Segments i) -> WithReprs (Array (sh, Int) e) fold1SegOp itp f (Delayed repr (sh, _) arr _) (Delayed _ ((), n) _ seg) | IntegralDict <- integralDict itp - = $boundsCheck "foldSeg" "empty segment descriptor" (n > 0) + = boundsCheck "empty segment descriptor" (n > 0) $ fromFunction' repr (sh, n-1) $ \(sz, ix) -> let start = fromIntegral $ seg ix end = fromIntegral $ seg (ix+1) in - $boundsCheck "fold1Seg" "empty segment" (end > start) + boundsCheck "empty segment" (end > start) $ iter1 (ShapeRsnoc ShapeRz) ((), end-start) (\((), i) -> arr (sz, start+i)) f scanl1Op - :: forall sh e. - (e -> e -> e) + :: forall sh e. HasCallStack + => (e -> e -> e) -> Delayed (Array (sh, Int) e) -> WithReprs (Array (sh, Int) e) scanl1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) - = $boundsCheck "scanl1" "empty array" (n > 0) + = boundsCheck "empty array" (n > 0) ( TupRsingle $ ArrayR shr tp , adata `seq` Array sh adata ) @@ -520,12 +527,12 @@ scanrOp f z (Delayed (ArrayR shr tp) (sz, n) ain _) scanr1Op - :: forall sh e. - (e -> e -> e) + :: forall sh e. HasCallStack + => (e -> e -> e) -> Delayed (Array (sh, Int) e) -> WithReprs (Array (sh, Int) e) scanr1Op f (Delayed (ArrayR shr tp) sh@(_, n) ain _) - = $boundsCheck "scanr1" "empty array" (n > 0) + = boundsCheck "empty array" (n > 0) ( TupRsingle $ ArrayR shr tp , adata `seq` Array sh adata ) @@ -626,7 +633,8 @@ backpermuteOp shr sh' p (Delayed (ArrayR _ tp) _ arr _) stencilOp - :: StencilR sh a stencil + :: HasCallStack + => StencilR sh a stencil -> TypeR b -> (stencil -> b) -> Boundary (Array sh a) @@ -640,7 +648,8 @@ stencilOp stencil tp f bnd arr@(Delayed _ sh _ _) stencil2Op - :: StencilR sh a stencil1 + :: HasCallStack + => StencilR sh a stencil1 -> StencilR sh b stencil2 -> TypeR c -> (stencil1 -> stencil2 -> c) @@ -784,7 +793,8 @@ stencilAccess stencil = goR (stencilShapeR stencil) stencil bounded - :: ShapeR sh + :: HasCallStack + => ShapeR sh -> Boundary (Array sh e) -> Delayed (Array sh e) -> sh @@ -809,7 +819,7 @@ bounded shr bnd (Delayed _ sh f _) ix = -- Return the index (second argument), updated to obey the given boundary -- conditions when outside the bounds of the given shape (first argument) -- - bound :: ShapeR sh -> sh -> sh -> sh + bound :: HasCallStack => ShapeR sh -> sh -> sh -> sh bound ShapeRz () () = () bound (ShapeRsnoc shr) (sh, sz) (ih, iz) = (bound shr sh ih, ih') where @@ -818,12 +828,12 @@ bounded shr bnd (Delayed _ sh f _) ix = Clamp -> 0 Mirror -> -iz Wrap -> sz + iz - _ -> $internalError "bound" "unexpected boundary condition" + _ -> internalError "unexpected boundary condition" | iz >= sz = case bnd of Clamp -> sz - 1 Mirror -> sz - (iz - sz + 2) Wrap -> iz - sz - _ -> $internalError "bound" "unexpected boundary condition" + _ -> internalError "unexpected boundary condition" | otherwise = iz -- toSeqOp :: forall slix sl dim co e proxy. (Elt slix, Shape sl, Shape dim, Elt e) @@ -849,7 +859,7 @@ data Boundary t where Function :: (sh -> e) -> Boundary (Array sh e) -evalBoundary :: AST.Boundary aenv t -> Val aenv -> Boundary t +evalBoundary :: HasCallStack => AST.Boundary aenv t -> Val aenv -> Boundary t evalBoundary bnd aenv = case bnd of AST.Clamp -> Clamp @@ -864,17 +874,17 @@ evalBoundary bnd aenv = -- Evaluate a closed scalar expression -- -evalExp :: Exp aenv t -> Val aenv -> t +evalExp :: HasCallStack => Exp aenv t -> Val aenv -> t evalExp e aenv = evalOpenExp e Empty aenv -- Evaluate a closed scalar function -- -evalFun :: Fun aenv t -> Val aenv -> t +evalFun :: HasCallStack => Fun aenv t -> Val aenv -> t evalFun f aenv = evalOpenFun f Empty aenv -- Evaluate an open scalar function -- -evalOpenFun :: OpenFun env aenv t -> Val env -> Val aenv -> t +evalOpenFun :: HasCallStack => OpenFun env aenv t -> Val env -> Val aenv -> t evalOpenFun (Body e) env aenv = evalOpenExp e env aenv evalOpenFun (Lam lhs f) env aenv = \x -> evalOpenFun f (env `push` (lhs, x)) aenv @@ -889,8 +899,8 @@ evalOpenFun (Lam lhs f) env aenv = -- leading to a large amount of wasteful recomputation. -- evalOpenExp - :: forall env aenv t. - OpenExp env aenv t + :: forall env aenv t. HasCallStack + => OpenExp env aenv t -> Val env -> Val aenv -> t @@ -953,7 +963,7 @@ evalOpenExp pexp env aenv = go ((t,cont):cs) | eqTag t v = cont | otherwise = go cs - go [] = $internalError "case" "unmatched case" + go [] = internalError "unmatched case" eqTag :: TagR a -> a -> Bool eqTag TagRunit () = True @@ -1569,9 +1579,6 @@ data Val' senv where 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. diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index a1f19b938..00c314400 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -61,6 +61,8 @@ import Data.Array.Accelerate.Debug.Flags import Data.Array.Accelerate.Debug.Stats #endif +import GHC.Stack + instance Arrays arrs => Show (Acc arrs) where show = withSimplStats . show . convertAcc @@ -149,7 +151,7 @@ extractOpenAcc :: OpenAcc aenv a -> PreOpenAcc OpenAcc aenv a extractOpenAcc (OpenAcc pacc) = pacc -prettyDelayedOpenAcc :: PrettyAcc DelayedOpenAcc +prettyDelayedOpenAcc :: HasCallStack => PrettyAcc DelayedOpenAcc prettyDelayedOpenAcc context aenv (Manifest pacc) = prettyPreOpenAcc context prettyDelayedOpenAcc extractDelayedOpenAcc aenv pacc prettyDelayedOpenAcc _ aenv (Delayed _ sh f _) @@ -160,9 +162,9 @@ prettyDelayedOpenAcc _ aenv (Delayed _ sh f _) , parens $ prettyOpenFun Empty aenv f ] -extractDelayedOpenAcc :: DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv a +extractDelayedOpenAcc :: HasCallStack => DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv a extractDelayedOpenAcc (Manifest pacc) = pacc -extractDelayedOpenAcc Delayed{} = $internalError "extractDelayedOpenAcc" "expected manifest array" +extractDelayedOpenAcc Delayed{} = internalError "expected manifest array" -- Debugging diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 605a1941b..88907aa8e 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -6,7 +6,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -58,6 +57,8 @@ import Prelude hiding ( exp ) import qualified Data.HashSet as Set import qualified Data.Sequence as Seq +import GHC.Stack + -- Configuration options -- --------------------- @@ -88,9 +89,6 @@ avalToVal (Apush aenv _ v) = Push (avalToVal aenv) (pretty 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 @@ -149,20 +147,20 @@ simple _ = False -- | Generate a dependency graph for the given computation -- {-# NOINLINE graphDelayedAcc #-} -graphDelayedAcc :: Detail -> DelayedAcc a -> Graph +graphDelayedAcc :: HasCallStack => 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 :: HasCallStack => 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" + _ -> internalError "unexpected error" -- Pretty-printing data-dependency graphs @@ -175,7 +173,8 @@ data PDoc = PDoc Adoc [Vertex] data PNode = PNode NodeId (Tree (Maybe Port, Adoc)) [(Vertex, Maybe Port)] graphDelayedOpenAcc - :: Detail + :: HasCallStack + => Detail -> Aval aenv -> DelayedOpenAcc aenv a -> Dot Graph @@ -189,13 +188,13 @@ graphDelayedOpenAcc detail aenv acc = do -- Generate a graph for the given term. -- prettyDelayedOpenAcc - :: forall aenv arrs. - Detail -- simplified output: only print operator name + :: forall aenv arrs. HasCallStack + => Detail -- simplified output: only print operator name -> Context -> Aval aenv -> DelayedOpenAcc aenv arrs -> Dot PNode -prettyDelayedOpenAcc _ _ _ Delayed{} = $internalError "prettyDelayedOpenAcc" "expected manifest array" +prettyDelayedOpenAcc _ _ _ Delayed{} = internalError "expected manifest array" prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = case pacc of Avar ix -> pnode (avar ix) @@ -217,7 +216,7 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = return $ PNode ident doc deps Apply _ afun acc -> apply <$> prettyDelayedAfun detail aenv afun - <*> prettyDelayedOpenAcc detail ctx aenv acc + <*> prettyDelayedOpenAcc detail ctx aenv acc Awhile p f x -> do ident <- mkNodeId atop @@ -296,7 +295,7 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = aenv' :: Val aenv aenv' = avalToVal aenv - ppA :: DelayedOpenAcc aenv a -> Dot PDoc + ppA :: HasCallStack => 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 @@ -314,8 +313,8 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = PDoc d v <- "Delayed" `fmt` [ ppE sh, ppF f ] return $ PDoc (parens d) v - ppB :: forall sh e. - TypeR e + ppB :: forall sh e. HasCallStack + => TypeR e -> Boundary aenv (Array sh e) -> Dot PDoc ppB _ Clamp = return (PDoc "clamp" []) @@ -324,18 +323,18 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = ppB tp (Constant e) = return (PDoc (prettyConst tp e) []) ppB _ (Function f) = ppF f - ppF :: Fun aenv t -> Dot PDoc + ppF :: HasCallStack => Fun aenv t -> Dot PDoc ppF = return . uncurry PDoc . (parens . prettyFun aenv' &&& fvF) - ppE :: Exp aenv t -> Dot PDoc + ppE :: HasCallStack => Exp aenv t -> Dot PDoc ppE = return . uncurry PDoc . (prettyExp aenv' &&& fvE) ppD :: String -> Direction -> String -> Operator ppD f LeftToRight k = fromString (f <> "l" <> k) ppD f RightToLeft k = fromString (f <> "r" <> k) - lift :: DelayedOpenAcc aenv a -> Dot Vertex - lift Delayed{} = $internalError "prettyDelayedOpenAcc" "expected manifest array" + lift :: HasCallStack => DelayedOpenAcc aenv a -> Dot Vertex + lift Delayed{} = internalError "expected manifest array" lift (Manifest (Avar (Var _ ix))) = return $ Vertex (fst (aprj ix aenv)) Nothing lift acc = do acc' <- prettyDelayedOpenAcc detail context0 aenv acc @@ -363,7 +362,8 @@ prettyDelayedOpenAcc detail ctx aenv atop@(Manifest pacc) = -- otherwise the referenced node will be drawn inside of the subgraph. -- prettyDelayedAfun - :: Detail + :: HasCallStack + => Detail -> Aval aenv -> DelayedOpenAfun aenv afun -> Dot Label @@ -394,11 +394,11 @@ prettyDelayedAfun detail aenv afun = do collect (Apush a i _) = Set.insert i (collect a) prettyLetALeftHandSide - :: forall repr aenv aenv'. - NodeId - -> Aval aenv - -> ALeftHandSide repr aenv aenv' - -> Dot (Aval aenv', Label) + :: forall repr aenv aenv'. HasCallStack + => NodeId + -> Aval aenv + -> ALeftHandSide repr aenv aenv' + -> Dot (Aval aenv', Label) prettyLetALeftHandSide _ aenv (LeftHandSideWildcard repr) = return (aenv, doc) where doc = case repr of @@ -413,8 +413,8 @@ prettyLetALeftHandSide ident aenv (LeftHandSidePair lhs1 lhs2) = do return (aenv2, "(" <> d1 <> ", " <> d2 <> ")") prettyLambdaALeftHandSide - :: forall repr aenv aenv'. - Aval aenv + :: forall repr aenv aenv'. HasCallStack + => Aval aenv -> ALeftHandSide repr aenv aenv' -> Dot (Aval aenv') prettyLambdaALeftHandSide aenv (LeftHandSideWildcard _) = return aenv @@ -430,8 +430,8 @@ prettyLambdaALeftHandSide aenv (LeftHandSidePair lhs1 lhs2) = do -- Display array tuples. This is a little tricky... -- prettyDelayedApair - :: forall aenv a1 a2. - Detail + :: forall aenv a1 a2. HasCallStack + => Detail -> Aval aenv -> DelayedOpenAcc aenv a1 -> DelayedOpenAcc aenv a2 diff --git a/src/Data/Array/Accelerate/Representation/Array.hs b/src/Data/Array/Accelerate/Representation/Array.hs index 10bea97e6..a29c31a0f 100644 --- a/src/Data/Array/Accelerate/Representation/Array.hs +++ b/src/Data/Array/Accelerate/Representation/Array.hs @@ -32,6 +32,8 @@ import Text.Show ( showListWi import Prelude hiding ( (!!) ) import qualified Data.Vector.Unboxed as U +import GHC.Stack + -- | Array data type, where the type arguments regard the representation -- types of the shape and elements. @@ -159,9 +161,9 @@ concatVectors tR vs = adata `seq` Array ((), len) adata shape :: Array sh e -> sh shape (Array sh _) = sh -reshape :: ShapeR sh -> sh -> ShapeR sh' -> Array sh' e -> Array sh e +reshape :: HasCallStack => ShapeR sh -> sh -> ShapeR sh' -> Array sh' e -> Array sh e reshape shR sh shR' (Array sh' adata) - = $boundsCheck "reshape" "shape mismatch" (size shR sh == size shR' sh') + = boundsCheck "shape mismatch" (size shR sh == size shR' sh') $ Array sh adata (!) :: (ArrayR (Array sh e), Array sh e) -> sh -> e diff --git a/src/Data/Array/Accelerate/Representation/Shape.hs b/src/Data/Array/Accelerate/Representation/Shape.hs index feb6b99b3..3b29abc50 100644 --- a/src/Data/Array/Accelerate/Representation/Shape.hs +++ b/src/Data/Array/Accelerate/Representation/Shape.hs @@ -23,6 +23,7 @@ import Language.Haskell.TH import Prelude hiding ( zip ) import GHC.Base ( quotInt, remInt ) +import GHC.Stack -- | Shape and index representations as nested pairs @@ -100,15 +101,15 @@ eq (ShapeRsnoc shr) (sh, i) (sh', i') = i == i' && eq shr sh sh' -- representation of the array (first argument is the /shape/, second -- argument is the /index/). -- -toIndex :: ShapeR sh -> sh -> sh -> Int +toIndex :: HasCallStack => ShapeR sh -> sh -> sh -> Int toIndex ShapeRz () () = 0 toIndex (ShapeRsnoc shr) (sh, sz) (ix, i) - = $indexCheck "toIndex" i sz + = indexCheck i sz $ toIndex shr sh ix * sz + i -- | Inverse of 'toIndex' -- -fromIndex :: ShapeR sh -> sh -> Int -> sh +fromIndex :: HasCallStack => ShapeR sh -> sh -> Int -> sh fromIndex ShapeRz () _ = () fromIndex (ShapeRsnoc shr) (sh, sz) i = (fromIndex shr sh (i `quotInt` sz), r) @@ -117,7 +118,7 @@ fromIndex (ShapeRsnoc shr) (sh, sz) i -- where r = case shr of -- Check if rank of shr is 0 - ShapeRz -> $indexCheck "fromIndex" i sz i + ShapeRz -> indexCheck i sz i _ -> i `remInt` sz -- | Iterate through the entire shape, applying the function in the second @@ -134,9 +135,9 @@ iter (ShapeRsnoc shr) (sh, sz) f c r = iter shr sh (\ix -> iter' (ix,0)) c r -- | Variant of 'iter' without an initial value -- -iter1 :: ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a +iter1 :: HasCallStack => ShapeR sh -> sh -> (sh -> a) -> (a -> a -> a) -> a iter1 ShapeRz () f _ = f () -iter1 (ShapeRsnoc _ ) (_, 0) _ _ = $boundsError "iter1" "empty iteration space" +iter1 (ShapeRsnoc _ ) (_, 0) _ _ = boundsError "empty iteration space" iter1 (ShapeRsnoc shr) (sh, sz) f c = iter1 shr sh (\ix -> iter1' (ix,0)) c where iter1' (ix,i) | i == sz-1 = f (ix,i) @@ -164,7 +165,7 @@ shapeToList (ShapeRsnoc shr) (sh,sz) = sz : shapeToList shr sh -- | Convert a list of dimensions into a shape -- -listToShape :: ShapeR sh -> [Int] -> sh +listToShape :: HasCallStack => ShapeR sh -> [Int] -> sh listToShape shr ds = case listToShape' shr ds of Just sh -> sh diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index a2a8900ef..88c3da89b 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -109,6 +109,7 @@ import Data.Kind import Prelude import GHC.TypeLits +import GHC.Stack -- Array computations @@ -825,7 +826,7 @@ instance HasArraysR acc => HasArraysR (PreSmartAcc acc exp) where class HasTypeR f where - typeR :: f t -> TypeR t + typeR :: HasCallStack => f t -> TypeR t instance HasTypeR SmartExp where typeR (SmartExp e) = typeR e @@ -847,7 +848,7 @@ instance HasTypeR exp => HasTypeR (PreSmartExp acc exp) where ToIndex _ _ _ -> TupRsingle scalarTypeInt FromIndex shr _ _ -> shapeType shr Case _ ((_,c):_) -> typeR c - Case{} -> $internalError "typeR" "encountered empty case" + Case{} -> internalError "encountered empty case" Cond _ e _ -> typeR e While t _ _ _ -> t PrimConst c -> TupRsingle $ SingleScalarType $ primConstType c @@ -876,10 +877,10 @@ instance HasTypeR exp => HasTypeR (PreSmartExp acc exp) where -- they can be passed as an input to the computation and thus the value can -- change without the need to generate fresh code. -- -constant :: forall e. Elt e => e -> Exp e +constant :: forall e. (HasCallStack, Elt e) => e -> Exp e constant = Exp . go (eltR @e) . fromElt where - go :: TypeR t -> t -> SmartExp t + go :: HasCallStack => TypeR t -> t -> SmartExp t go TupRunit () = SmartExp $ Nil go (TupRsingle tp) c = SmartExp $ Const tp c go (TupRpair t1 t2) (c1, c2) = SmartExp $ go t1 c1 `Pair` go t2 c2 diff --git a/src/Data/Array/Accelerate/Sugar/Foreign.hs b/src/Data/Array/Accelerate/Sugar/Foreign.hs index d42d2f547..b6dc7b4a8 100644 --- a/src/Data/Array/Accelerate/Sugar/Foreign.hs +++ b/src/Data/Array/Accelerate/Sugar/Foreign.hs @@ -18,6 +18,8 @@ import Data.Array.Accelerate.Error import Data.Typeable import Language.Haskell.TH +import GHC.Stack + -- 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 @@ -32,6 +34,6 @@ class Typeable asm => Foreign asm where -- 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" + liftForeign :: HasCallStack => asm args -> Q (TExp (asm args)) + liftForeign _ = internalError "not supported by this backend" diff --git a/src/Data/Array/Accelerate/Trafo/Environment.hs b/src/Data/Array/Accelerate/Trafo/Environment.hs index 82629223d..b93c9db92 100644 --- a/src/Data/Array/Accelerate/Trafo/Environment.hs +++ b/src/Data/Array/Accelerate/Trafo/Environment.hs @@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Trafo.Environment @@ -28,6 +27,8 @@ import Data.Array.Accelerate.Type import Data.Array.Accelerate.Debug.Stats as Stats +import GHC.Stack + -- An environment that holds let-bound scalar expressions. The second -- environment variable env' is used to project out the corresponding @@ -66,10 +67,10 @@ incExp (PushExp env w) = incExp env `PushExp` subs w subs :: forall env aenv s t. WeakOpenExp env aenv t -> WeakOpenExp (env,s) aenv t subs (Subst k (e :: OpenExp env_ aenv t) _) = Subst (weakenSucc' k) e (weakenE (weakenSucc' k) e) -prjExp :: Idx env' t -> Gamma env env' aenv -> OpenExp env aenv t +prjExp :: HasCallStack => Idx env' t -> Gamma env env' aenv -> OpenExp env aenv t prjExp ZeroIdx (PushExp _ (Subst _ _ e)) = e prjExp (SuccIdx ix) (PushExp env _) = prjExp ix env -prjExp _ _ = $internalError "prjExp" "inconsistent valuation" +prjExp _ _ = internalError "inconsistent valuation" pushExp :: Gamma env env' aenv -> OpenExp env aenv t -> Gamma env (env',t) aenv pushExp env e = env `PushExp` Subst weakenId e e diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 201eb5a08..55d81d094 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -9,7 +9,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -71,24 +70,26 @@ import System.IO.Unsafe -- for debugging import Control.Lens ( over, mapped, _2 ) import Prelude hiding ( exp, until ) +import GHC.Stack + -- Delayed Array Fusion -- ==================== -- | Apply the fusion transformation to a closed de Bruijn AST -- -convertAcc :: Acc arrs -> DelayedAcc arrs +convertAcc :: HasCallStack => Acc arrs -> DelayedAcc arrs convertAcc = convertAccWith defaultOptions -convertAccWith :: Config -> Acc arrs -> DelayedAcc arrs +convertAccWith :: HasCallStack => Config -> Acc arrs -> DelayedAcc arrs convertAccWith config = withSimplStats . convertOpenAcc config -- | Apply the fusion transformation to a function of array arguments -- -convertAfun :: Afun f -> DelayedAfun f +convertAfun :: HasCallStack => Afun f -> DelayedAfun f convertAfun = convertAfunWith defaultOptions -convertAfunWith :: Config -> Afun f -> DelayedAfun f +convertAfunWith :: HasCallStack => Config -> Afun f -> DelayedAfun f convertAfunWith config = withSimplStats . convertOpenAfun config -- -- | Apply the fusion transformation to the array computations embedded @@ -124,7 +125,11 @@ withSimplStats x = x -- manifest, and the two helper functions are even named as such! We should -- encode this property in the type somehow... -- -convertOpenAcc :: Config -> OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs +convertOpenAcc + :: HasCallStack + => Config + -> OpenAcc aenv arrs + -> DelayedOpenAcc aenv arrs convertOpenAcc config = manifest config . computeAcc . embedOpenAcc config @@ -133,7 +138,11 @@ convertOpenAcc config = manifest config . computeAcc . embedOpenAcc config -- representation. It is safe to match on BaseEnv because the first pass -- will put producers adjacent to the term consuming it. -- -delayed :: Config -> OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e) +delayed + :: HasCallStack + => Config + -> OpenAcc aenv (Array sh e) + -> DelayedOpenAcc aenv (Array sh e) delayed config (embedOpenAcc config -> Embed env cc) | BaseEnv <- env = case simplifyCC cc of @@ -150,9 +159,13 @@ delayed config (embedOpenAcc config -> Embed env cc) -- Convert array programs as manifest terms. -- -manifest :: Config -> OpenAcc aenv a -> DelayedOpenAcc aenv a +manifest + :: HasCallStack + => Config + -> OpenAcc aenv a + -> DelayedOpenAcc aenv a manifest config (OpenAcc pacc) = - let fusionError = $internalError "manifest" "unexpected fusible materials" + let fusionError = internalError "unexpected fusible materials" in Manifest $ case pacc of -- Non-fusible terms @@ -207,7 +220,8 @@ manifest config (OpenAcc pacc) = -- Flatten needless let-binds, which can be introduced by the -- conversion to the internal embeddable representation. -- - alet :: ALeftHandSide a aenv aenv' + alet :: HasCallStack + => ALeftHandSide a aenv aenv' -> DelayedOpenAcc aenv a -> DelayedOpenAcc aenv' b -> PreOpenAcc DelayedOpenAcc aenv b @@ -227,7 +241,8 @@ manifest config (OpenAcc pacc) = -- > compute :: Acc a -> Acc a -- > compute = id >-> id -- - apply :: ArraysR b + apply :: HasCallStack + => ArraysR b -> PreOpenAfun DelayedOpenAcc aenv (a -> b) -> DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv b @@ -241,14 +256,14 @@ manifest config (OpenAcc pacc) = | otherwise = Apply repr afun x - cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f + cvtAF :: HasCallStack => OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f cvtAF (Alam lhs f) = Alam lhs (cvtAF f) cvtAF (Abody b) = Abody (manifest config b) -- cvtS :: PreOpenSeq OpenAcc aenv senv s -> PreOpenSeq DelayedOpenAcc aenv senv s -- cvtS = convertOpenSeq config -convertOpenAfun :: Config -> OpenAfun aenv f -> DelayedOpenAfun aenv f +convertOpenAfun :: HasCallStack => Config -> OpenAfun aenv f -> DelayedOpenAfun aenv f convertOpenAfun c (Alam lhs f) = Alam lhs (convertOpenAfun c f) convertOpenAfun c (Abody b) = Abody (convertOpenAcc c b) @@ -300,7 +315,7 @@ type ElimAcc acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Bool -- adjacent producer/producer terms. Using the reduced internal form limits the -- number of combinations that need to be considered. -- -embedOpenAcc :: Config -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs +embedOpenAcc :: HasCallStack => Config -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs embedOpenAcc config (OpenAcc pacc) = embedPreOpenAcc config matchOpenAcc (embedOpenAcc config) elimOpenAcc pacc where @@ -327,7 +342,8 @@ embedOpenAcc config (OpenAcc pacc) = embedPreOpenAcc - :: Config + :: HasCallStack + => Config -> MatchAcc OpenAcc -> EmbedAcc OpenAcc -> ElimAcc OpenAcc @@ -415,7 +431,7 @@ embedPreOpenAcc config matchAcc embedAcc elimAcc pacc -- If fusion is not enabled, force terms to the manifest representation -- - unembed :: Embed OpenAcc aenv arrs -> Embed OpenAcc aenv arrs + unembed :: HasCallStack => Embed OpenAcc aenv arrs -> Embed OpenAcc aenv arrs unembed x | array_fusion `member` options config = x | Embed env cc <- x @@ -426,12 +442,12 @@ embedPreOpenAcc config matchAcc embedAcc elimAcc pacc | DeclareVars lhs _ value <- declareVars (arraysR pacc) -> Embed (PushEnv env lhs $ OpenAcc pacc) $ Done $ value weakenId - cvtA :: OpenAcc aenv' a -> OpenAcc aenv' a + cvtA :: HasCallStack => OpenAcc aenv' a -> OpenAcc aenv' a cvtA = computeAcc . embedAcc - cvtAF :: PreOpenAfun OpenAcc aenv' f -> PreOpenAfun OpenAcc aenv' f + cvtAF :: HasCallStack => PreOpenAfun OpenAcc aenv' f -> PreOpenAfun OpenAcc aenv' f cvtAF (Alam lhs f) = Alam lhs (cvtAF f) - cvtAF (Abody a) = Abody (cvtA a) + cvtAF (Abody a) = Abody (cvtA a) -- Helpers to shuffle the order of arguments to a constructor -- @@ -451,13 +467,13 @@ embedPreOpenAcc config matchAcc embedAcc elimAcc pacc -- Conversions for closed scalar functions and expressions. This just -- applies scalar simplifications. -- - cvtF :: Fun aenv' t -> Fun aenv' t + cvtF :: HasCallStack => Fun aenv' t -> Fun aenv' t cvtF = simplifyFun - cvtE :: Exp aenv' t -> Exp aenv' t + cvtE :: HasCallStack => Exp aenv' t -> Exp aenv' t cvtE = simplifyExp - cvtB :: Boundary aenv' t -> Boundary aenv' t + cvtB :: HasCallStack => Boundary aenv' t -> Boundary aenv' t cvtB Clamp = Clamp cvtB Mirror = Mirror cvtB Wrap = Wrap @@ -466,14 +482,14 @@ embedPreOpenAcc config matchAcc embedAcc elimAcc pacc -- Helpers to embed and fuse delayed terms -- - into :: Sink f + into :: (HasCallStack, Sink f) => (f env' a -> b) -> f env a -> Extend ArrayR OpenAcc env env' -> b into op a env = op (sinkA env a) - into2 :: (Sink f1, Sink f2) + into2 :: (HasCallStack, Sink f1, Sink f2) => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b @@ -481,11 +497,15 @@ embedPreOpenAcc config matchAcc embedAcc elimAcc pacc -> c into2 op a b env = op (sinkA env a) (sinkA env b) - into2M :: (Sink f1, Sink f2) - => (f1 env' a -> Maybe (f2 env' b) -> c) -> f1 env a -> Maybe (f2 env b) -> Extend ArrayR acc env env' -> c + into2M :: (HasCallStack, Sink f1, Sink f2) + => (f1 env' a -> Maybe (f2 env' b) -> c) + -> f1 env a + -> Maybe (f2 env b) + -> Extend ArrayR acc env env' + -> c into2M op a b env = op (sinkA env a) (sinkA env <$> b) - into3 :: (Sink f1, Sink f2, Sink f3) + into3 :: (HasCallStack, Sink f1, Sink f2, Sink f3) => (f1 env' a -> f2 env' b -> f3 env' c -> d) -> f1 env a -> f2 env b @@ -499,12 +519,14 @@ embedPreOpenAcc config matchAcc embedAcc elimAcc pacc -- directly on the delayed representation. See also: [Representing -- delayed arrays] -- - fuse :: (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) + fuse :: HasCallStack + => (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) -> OpenAcc aenv as -> Embed OpenAcc aenv bs fuse op (embedAcc -> Embed env cc) = Embed env (op env cc) - fuse2 :: (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs -> Cunctation aenv' cs) + fuse2 :: HasCallStack + => (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs -> Cunctation aenv' cs) -> OpenAcc aenv as -> OpenAcc aenv bs -> Embed OpenAcc aenv cs @@ -545,7 +567,8 @@ embedPreOpenAcc config matchAcc embedAcc elimAcc pacc -- useful for the 'permute' operation to know when it can in-place -- update the array of default values. -- - embed :: ArraysR bs + embed :: HasCallStack + => ArraysR bs -> (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> OpenAcc aenv' as -> PreOpenAcc OpenAcc aenv' bs) -> OpenAcc aenv as -> Embed OpenAcc aenv bs @@ -558,7 +581,8 @@ embedPreOpenAcc config matchAcc embedAcc elimAcc pacc , DeclareVars lhs _ value <- declareVars reprBs = Embed (PushEnv env lhs $ OpenAcc (op env (OpenAcc (compute cc)))) $ Done $ value weakenId - embed2 :: ArraysR cs + embed2 :: HasCallStack + => ArraysR cs -> (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> OpenAcc aenv' as -> OpenAcc aenv' bs -> PreOpenAcc OpenAcc aenv' cs) -> OpenAcc aenv as -> OpenAcc aenv bs @@ -788,7 +812,7 @@ instance Sink Cunctation where Step repr sh p f v -> Step repr (weaken k sh) (weaken k p) (weaken k f) (weaken k v) Yield repr sh f -> Yield repr (weaken k sh) (weaken k f) -simplifyCC :: Cunctation aenv a -> Cunctation aenv a +simplifyCC :: HasCallStack => Cunctation aenv a -> Cunctation aenv a simplifyCC = \case Done v -> Done v @@ -805,7 +829,7 @@ simplifyCC = \case -- Convert a real AST node into the internal representation -- -done :: PreOpenAcc OpenAcc aenv a -> Embed OpenAcc aenv a +done :: HasCallStack => PreOpenAcc OpenAcc aenv a -> Embed OpenAcc aenv a done pacc | Just vars <- avarsOut extractOpenAcc pacc = Embed BaseEnv (Done vars) @@ -817,7 +841,8 @@ doneZeroIdx repr = Done $ TupRsingle $ Var repr ZeroIdx -- Recast a cunctation into a mapping from indices to elements. -- -yield :: Cunctation aenv (Array sh e) +yield :: HasCallStack + => Cunctation aenv (Array sh e) -> Cunctation aenv (Array sh e) yield cc = case cc of @@ -829,7 +854,8 @@ yield cc = -- Recast a cunctation into transformation step form. Not possible if the source -- was in the Yield formulation. -- -step :: Cunctation aenv (Array sh e) +step :: HasCallStack + => Cunctation aenv (Array sh e) -> Maybe (Cunctation aenv (Array sh e)) step cc = case cc of @@ -841,10 +867,10 @@ step cc = -- Get the shape of a delayed array -- -shape :: Cunctation aenv (Array sh e) -> Exp aenv sh +shape :: HasCallStack => Cunctation aenv (Array sh e) -> Exp aenv sh shape cc - | Just (Step _ sh _ _ _) <- step cc = sh - | Yield _ sh _ <- yield cc = sh + | Just (Step _ sh _ _ _) <- step cc = sh + | Yield _ sh _ <- yield cc = sh -- prjExtend :: Kit acc => Extend acc env env' -> Idx env' t -> PreOpenAcc acc env' t @@ -906,7 +932,10 @@ instance Kit acc => Sink (SinkSeq acc senv) where -- We do a bit of extra work to (try to) maintain that terms should be left -- at their lowest common use site. SEE: [Fusion and the lowest common use site] -- -computeAcc :: Embed OpenAcc aenv arrs -> OpenAcc aenv arrs +computeAcc + :: HasCallStack + => Embed OpenAcc aenv arrs + -> OpenAcc aenv arrs computeAcc (Embed BaseEnv cc) = OpenAcc (compute cc) computeAcc (Embed env@(PushEnv bot lhs top) cc) = case simplifyCC cc of @@ -942,7 +971,8 @@ computeAcc (Embed env@(PushEnv bot lhs top) cc) = _ -> bindA env (OpenAcc (Transform repr sh p f (avarIn OpenAcc v))) where - bindA :: Extend ArrayR OpenAcc aenv aenv' + bindA :: HasCallStack + => Extend ArrayR OpenAcc aenv aenv' -> OpenAcc aenv' a -> OpenAcc aenv a bindA BaseEnv b = b @@ -962,7 +992,10 @@ computeAcc (Embed env@(PushEnv bot lhs top) cc) = -- Convert the internal representation of delayed arrays into a real AST -- node. Use the most specific version of a combinator whenever possible. -- -compute :: Cunctation aenv arrs -> PreOpenAcc OpenAcc aenv arrs +compute + :: HasCallStack + => Cunctation aenv arrs + -> PreOpenAcc OpenAcc aenv arrs compute cc = case simplifyCC cc of Done TupRunit -> Anil Done (TupRsingle v@(Var ArrayR{} _)) -> Avar v @@ -978,7 +1011,8 @@ compute cc = case simplifyCC cc of -- Representation of a generator as a delayed array -- generateD - :: ArrayR (Array sh e) + :: HasCallStack + => ArrayR (Array sh e) -> Exp aenv sh -> Fun aenv (sh -> e) -> Embed OpenAcc aenv (Array sh e) @@ -990,7 +1024,8 @@ generateD repr sh f -- Fuse a unary function into a delayed array. Also looks for unzips which can -- be executed in constant time; SEE [unzipD] -- -mapD :: TypeR b +mapD :: HasCallStack + => TypeR b -> Fun aenv (a -> b) -> Embed OpenAcc aenv (Array sh a) -> Embed OpenAcc aenv (Array sh b) @@ -1007,7 +1042,8 @@ mapD tR f (Embed env cc) -- a backend will be able to execute this in constant time. -- unzipD - :: TypeR b + :: HasCallStack + => TypeR b -> Fun aenv (a -> b) -> Embed OpenAcc aenv (Array sh a) -> Maybe (Embed OpenAcc aenv (Array sh b)) @@ -1025,7 +1061,8 @@ unzipD _ _ _ -- the destination array read there data from in the source array. -- backpermuteD - :: ShapeR sh' + :: HasCallStack + => ShapeR sh' -> Exp aenv sh' -> Fun aenv (sh' -> sh) -> Cunctation aenv (Array sh e) @@ -1039,7 +1076,8 @@ backpermuteD shR' sh' p = Stats.ruleFired "backpermuteD" . go -- Transform as a combined map and backwards permutation -- transformD - :: ArrayR (Array sh' b) + :: HasCallStack + => ArrayR (Array sh' b) -> Exp aenv sh' -> Fun aenv (sh' -> sh) -> Fun aenv (a -> b) @@ -1050,12 +1088,13 @@ transformD (ArrayR shR' tR) sh' p f . fuse (into2 (backpermuteD shR') sh' p) . mapD tR f where - fuse :: (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) + fuse :: HasCallStack + => (forall aenv'. Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' as -> Cunctation aenv' bs) -> Embed OpenAcc aenv as -> Embed OpenAcc aenv bs fuse op (Embed env cc) = Embed env (op env cc) - into2 :: (Sink f1, Sink f2) + into2 :: (HasCallStack, Sink f1, Sink f2) => (f1 env' a -> f2 env' b -> c) -> f1 env a -> f2 env b @@ -1071,7 +1110,8 @@ transformD (ArrayR shR' tR) sh' p f -- expensive and/or `sh` is large. -- replicateD - :: SliceIndex slix sl co sh + :: HasCallStack + => SliceIndex slix sl co sh -> Exp aenv slix -> Cunctation aenv (Array sl e) -> Cunctation aenv (Array sh e) @@ -1083,7 +1123,8 @@ replicateD sliceIndex slix cc -- Dimensional slice as a backwards permutation -- sliceD - :: SliceIndex slix sl co sh + :: HasCallStack + => SliceIndex slix sl co sh -> Exp aenv slix -> Cunctation aenv (Array sh e) -> Cunctation aenv (Array sl e) @@ -1103,7 +1144,8 @@ sliceD sliceIndex slix cc -- same number of elements: this has been lost for the delayed cases! -- reshapeD - :: ShapeR sl + :: HasCallStack + => ShapeR sl -> Embed OpenAcc aenv (Array sh e) -> Exp aenv sl -> Embed OpenAcc aenv (Array sl e) @@ -1124,7 +1166,8 @@ reshapeD slr (Embed env cc) (sinkA env -> sl) -- array. -- zipWithD - :: TypeR c + :: HasCallStack + => TypeR c -> Fun aenv (a -> b -> c) -> Cunctation aenv (Array sh a) -> Cunctation aenv (Array sh b) @@ -1149,8 +1192,8 @@ zipWithD tR f cc1 cc0 $ Yield (ArrayR shR tR) (intersect shR sh1 sh0) (combine f f1 f0) where - combine :: forall aenv a b c e. - Fun aenv (a -> b -> c) + combine :: forall aenv a b c e. HasCallStack + => Fun aenv (a -> b -> c) -> Fun aenv (e -> a) -> Fun aenv (e -> b) -> Fun aenv (e -> c) @@ -1172,7 +1215,8 @@ zipWithD tR f cc1 cc0 -> Lam lhs $ Body $ Let lhsA ixa'' $ Let lhsB (weakenE (weakenWithLHS lhsA .> k2) ixb') c' combineLhs - :: LeftHandSide s t env env1' + :: HasCallStack + => LeftHandSide s t env env1' -> LeftHandSide s t env env2' -> CombinedLHS s t env1' env2' env combineLhs = go weakenId weakenId @@ -1274,7 +1318,8 @@ data CombinedLHS s t env1' env2' env where -- in -- in -- -aletD :: EmbedAcc OpenAcc +aletD :: HasCallStack + => EmbedAcc OpenAcc -> ElimAcc OpenAcc -> ALeftHandSide arrs aenv aenv' -> OpenAcc aenv arrs @@ -1301,8 +1346,8 @@ aletD embedAcc elimAcc lhs (embedAcc -> Embed env1 cc1) acc0 = aletD' embedAcc elimAcc lhs (Embed env1 cc1) (embedAcc acc0) -aletD' :: forall aenv aenv' arrs brrs. - EmbedAcc OpenAcc +aletD' :: forall aenv aenv' arrs brrs. HasCallStack + => EmbedAcc OpenAcc -> ElimAcc OpenAcc -> ALeftHandSide arrs aenv aenv' -> Embed OpenAcc aenv arrs @@ -1349,8 +1394,8 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en -- body when not necessary (which can lead to a complexity blowup). -- eliminate - :: forall aenv aenv' sh e brrs. - Extend ArrayR OpenAcc aenv aenv' + :: forall aenv aenv' sh e brrs. HasCallStack + => Extend ArrayR OpenAcc aenv aenv' -> Cunctation aenv' (Array sh e) -> OpenAcc (aenv', Array sh e) brrs -> Embed OpenAcc aenv brrs @@ -1363,7 +1408,8 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en bnd :: PreOpenAcc OpenAcc aenv' (Array sh e) bnd = compute cc1 - elim :: ArrayR (Array sh e) + elim :: HasCallStack + => ArrayR (Array sh e) -> Exp aenv' sh -> Fun aenv' (sh -> e) -> Embed OpenAcc aenv brrs @@ -1382,8 +1428,10 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en -- 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. - OpenExp env aenv sh -> OpenFun env aenv (sh -> e) -> ArrayVar aenv (Array sh e) + replaceE :: forall env aenv sh e t. HasCallStack + => OpenExp env aenv sh + -> OpenFun env aenv (sh -> e) + -> ArrayVar aenv (Array sh e) -> OpenExp env aenv t -> OpenExp env aenv t replaceE sh' f' avar@(Var (ArrayR shR _) _) exp = @@ -1430,8 +1478,10 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en cvtE :: OpenExp env aenv s -> OpenExp env aenv s cvtE = replaceE sh' f' avar - replaceF :: forall env aenv sh e t. - OpenExp env aenv sh -> OpenFun env aenv (sh -> e) -> ArrayVar aenv (Array sh e) + replaceF :: forall env aenv sh e t. HasCallStack + => OpenExp env aenv sh + -> OpenFun env aenv (sh -> e) + -> ArrayVar aenv (Array sh e) -> OpenFun env aenv t -> OpenFun env aenv t replaceF sh' f' avar fun = @@ -1440,8 +1490,8 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en Lam lhs f -> let k = weakenWithLHS lhs in Lam lhs (replaceF (weakenE k sh') (weakenE k f') avar f) - replaceA :: forall aenv sh e a. - Exp aenv sh + replaceA :: forall aenv sh e a. HasCallStack + => Exp aenv sh -> Fun aenv (sh -> e) -> ArrayVar aenv (Array sh e) -> PreOpenAcc OpenAcc aenv a @@ -1503,7 +1553,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en cvtB (Constant c) = Constant c cvtB (Function f) = Function (cvtF f) - cvtAF :: PreOpenAfun OpenAcc aenv s -> PreOpenAfun OpenAcc aenv s + cvtAF :: HasCallStack => PreOpenAfun OpenAcc aenv s -> PreOpenAfun OpenAcc aenv s cvtAF = cvt sh' f' avar where cvt :: forall aenv a. @@ -1569,7 +1619,8 @@ aletD' _ _ lhs (Embed env1 cc1) (Embed env0 cc0) -- both branches. This would result in redundant work processing the bindings -- for the branch not taken. -- -acondD :: MatchAcc OpenAcc +acondD :: HasCallStack + => MatchAcc OpenAcc -> EmbedAcc OpenAcc -> Exp aenv PrimBool -> OpenAcc aenv arrs diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index c98585b75..9442d082d 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -9,7 +9,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -85,6 +84,8 @@ import qualified Data.HashTable.IO as Hash import qualified Data.IntMap as IntMap import Prelude +import GHC.Stack + -- Layouts -- ------- @@ -109,8 +110,8 @@ type ArrayLayout = Layout ArrayR -- The first argument provides context information for error messages in the -- case of failure. -- -prjIdx :: forall s t env env1. - String +prjIdx :: forall s t env env1. HasCallStack + => String -> (forall t'. TupR s t' -> ShowS) -> (forall u v. TupR s u -> TupR s v -> Maybe (u :~: v)) -> TupR s t @@ -119,7 +120,7 @@ prjIdx :: forall s t env env1. -> Vars s env t prjIdx context showTp matchTp tp = go where - go :: forall env'. Int -> Layout s env env' -> Vars s env t + go :: forall env'. HasCallStack => Int -> Layout s env env' -> Vars s env t go _ EmptyLayout = no "environment does not contain index" go 0 (PushLayout _ lhs vars) | Just Refl <- matchTp tp tp' = vars @@ -130,8 +131,8 @@ prjIdx context showTp matchTp tp = go tp' = lhsToTupR lhs go n (PushLayout l _ _) = go (n-1) l - no :: String -> a - no reason = $internalError "prjIdx" (printf "%s\nin the context: %s" reason context) + no :: HasCallStack => String -> a + no reason = internalError (printf "%s\nin the context: %s" reason context) -- Add an entry to a layout, incrementing all indices -- @@ -152,20 +153,20 @@ sizeLayout (PushLayout lyt _ _) = 1 + sizeLayout lyt -- | Convert a closed array expression to de Bruijn form while also incorporating sharing -- information. -- -convertAcc :: Acc arrs -> AST.Acc (Sugar.ArraysR arrs) +convertAcc :: HasCallStack => Acc arrs -> AST.Acc (Sugar.ArraysR arrs) convertAcc = convertAccWith defaultOptions -convertAccWith :: Config -> Acc arrs -> AST.Acc (Sugar.ArraysR arrs) +convertAccWith :: HasCallStack => Config -> Acc arrs -> AST.Acc (Sugar.ArraysR arrs) convertAccWith config (Acc acc) = convertOpenAcc config EmptyLayout acc -- | Convert a closed function over array computations, while incorporating -- sharing information. -- -convertAfun :: Afunction f => f -> AST.Afun (ArraysFunctionR f) +convertAfun :: HasCallStack => Afunction f => f -> AST.Afun (ArraysFunctionR f) convertAfun = convertAfunWith defaultOptions -convertAfunWith :: Afunction f => Config -> f -> AST.Afun (ArraysFunctionR f) +convertAfunWith :: HasCallStack => Afunction f => Config -> f -> AST.Afun (ArraysFunctionR f) convertAfunWith config = convertOpenAfun config EmptyLayout data AfunctionRepr f ar areprr where @@ -187,8 +188,8 @@ data AfunctionRepr f ar areprr where class Afunction f where type AfunctionR f type ArraysFunctionR f - afunctionRepr :: AfunctionRepr f (AfunctionR f) (ArraysFunctionR f) - convertOpenAfun :: Config -> ArrayLayout aenv aenv -> f -> AST.OpenAfun aenv (ArraysFunctionR f) + afunctionRepr :: HasCallStack => AfunctionRepr f (AfunctionR f) (ArraysFunctionR f) + convertOpenAfun :: HasCallStack => Config -> ArrayLayout aenv aenv -> f -> AST.OpenAfun aenv (ArraysFunctionR f) instance (Arrays a, Afunction r) => Afunction (Acc a -> r) where type AfunctionR (Acc a -> r) = a -> AfunctionR r @@ -210,7 +211,12 @@ instance Arrays b => Afunction (Acc b) where afunctionRepr = AfunctionReprBody convertOpenAfun config alyt (Acc body) = Abody $ convertOpenAcc config alyt body -convertSmartAfun1 :: Config -> ArraysR a -> (SmartAcc a -> SmartAcc b) -> AST.Afun (a -> b) +convertSmartAfun1 + :: HasCallStack + => Config + -> ArraysR a + -> (SmartAcc a -> SmartAcc b) + -> AST.Afun (a -> b) convertSmartAfun1 config repr f | DeclareVars lhs _ value <- declareVars repr = let @@ -223,7 +229,8 @@ convertSmartAfun1 config repr f -- information. -- convertOpenAcc - :: Config + :: HasCallStack + => Config -> ArrayLayout aenv aenv -> SmartAcc arrs -> AST.OpenAcc aenv arrs @@ -243,8 +250,8 @@ convertOpenAcc config alyt acc = -- in reverse chronological order (outermost variable is at the end of the list). -- convertSharingAcc - :: forall aenv arrs. - Config + :: forall aenv arrs. HasCallStack + => Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -> ScopedAcc arrs @@ -256,7 +263,7 @@ convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa repr)) | null aenv' = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++ show (hashStableNameHeight sa) ++ ")" | otherwise - = $internalError "convertSharingAcc" err + = internalError err where aenv' = lams ++ aenv ctxt = "shared 'Acc' tree with stable name " ++ show (hashStableNameHeight sa) @@ -431,7 +438,7 @@ convertSharingSeq config alyt slyt aenv senv (ScopedSeq (SletSharing sa@(StableS where slyt' = incLayout slyt `PushLayout` ZeroIdx - asIdx :: Arrays a + asIdx :: (HasCallStack, Arrays a) => ScopedSeq [a] -> Idx senv a asIdx (ScopedSeq (SvarSharing sn)) @@ -516,8 +523,8 @@ convertSharingSeq config alyt slyt aenv senv s --} convertSharingAfun1 - :: forall aenv a b. - Config + :: forall aenv a b. HasCallStack + => Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -> ArraysR a @@ -534,8 +541,8 @@ convertSharingAfun1 config alyt aenv reprA f -- | Convert a boundary condition -- convertSharingBoundary - :: forall aenv sh e. - Config + :: forall aenv sh e. HasCallStack + => Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -> ShapeR sh @@ -573,12 +580,12 @@ convertSharingBoundary config alyt aenv shr = cvt -- In higher-order abstract syntax, this represents an n-ary, polyvariadic -- function. -- -convertFun :: Function f => f -> AST.Fun () (EltFunctionR f) +convertFun :: (HasCallStack, Function f) => f -> AST.Fun () (EltFunctionR f) convertFun = convertFunWith $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing] } -convertFunWith :: Function f => Config -> f -> AST.Fun () (EltFunctionR f) +convertFunWith :: (HasCallStack, Function f) => Config -> f -> AST.Fun () (EltFunctionR f) convertFunWith config = convertOpenFun config EmptyLayout data FunctionRepr f r reprr where @@ -594,8 +601,8 @@ class Function f where type FunctionR f type EltFunctionR f - functionRepr :: FunctionRepr f (FunctionR f) (EltFunctionR f) - convertOpenFun :: Config -> ELayout env env -> f -> AST.OpenFun env () (EltFunctionR f) + functionRepr :: HasCallStack => FunctionRepr f (FunctionR f) (EltFunctionR f) + convertOpenFun :: HasCallStack => Config -> ELayout env env -> f -> AST.OpenFun env () (EltFunctionR f) instance (Elt a, Function r) => Function (Exp a -> r) where type FunctionR (Exp a -> r) = a -> FunctionR r @@ -618,7 +625,12 @@ instance Elt b => Function (Exp b) where functionRepr = FunctionReprBody convertOpenFun config lyt (Exp body) = Body $ convertOpenExp config lyt body -convertSmartFun :: Config -> TypeR a -> (SmartExp a -> SmartExp b) -> AST.Fun () (a -> b) +convertSmartFun + :: HasCallStack + => Config + -> TypeR a + -> (SmartExp a -> SmartExp b) + -> AST.Fun () (a -> b) convertSmartFun config tp f | DeclareVars lhs _ value <- declareVars tp = let @@ -633,16 +645,24 @@ convertSmartFun config tp f -- | Convert a closed scalar expression to de Bruijn form while incorporating -- sharing information. -- -convertExp :: Exp e -> AST.Exp () (EltR e) +convertExp + :: HasCallStack + => Exp e + -> AST.Exp () (EltR e) convertExp = convertExpWith $ defaultOptions { options = options defaultOptions \\ [seq_sharing, acc_sharing] } -convertExpWith :: Config -> Exp e -> AST.Exp () (EltR e) +convertExpWith + :: HasCallStack + => Config + -> Exp e + -> AST.Exp () (EltR e) convertExpWith config (Exp e) = convertOpenExp config EmptyLayout e convertOpenExp - :: Config + :: HasCallStack + => Config -> ELayout env env -> SmartExp e -> AST.OpenExp env () e @@ -662,8 +682,8 @@ convertOpenExp config lyt exp = -- keeping them in reverse chronological order (outermost variable is at the end of the list). -- convertSharingExp - :: forall t env aenv. - Config + :: forall t env aenv. HasCallStack + => Config -> ELayout env env -- scalar environment -> ArrayLayout aenv aenv -- array environment -> [StableSharingExp] -- currently bound sharing variables of expressions @@ -675,10 +695,10 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp -- scalar environment with any lambda bound variables this expression is rooted in env' = lams ++ env - cvt :: ScopedExp t' -> AST.OpenExp env aenv t' + cvt :: HasCallStack => ScopedExp t' -> AST.OpenExp env aenv t' cvt (ScopedExp _ (VarSharing se tp)) | Just i <- findIndex (matchStableExp se) env' = expVars (prjIdx (ctx i) shows matchTypeR tp i lyt) - | otherwise = $internalError "convertSharingExp" msg + | otherwise = internalError msg where ctx i = printf "shared 'Exp' tree with stable name %d; i=%d" (hashStableNameHeight se) i msg = unlines @@ -762,15 +782,15 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp | DeclareVars lhs _ value <- declareVars $ AST.expType a = AST.Let lhs a $ cvtPrj ix $ expVars $ value weakenId - cvtA :: ScopedAcc a -> AST.OpenAcc aenv a + cvtA :: HasCallStack => ScopedAcc a -> AST.OpenAcc aenv a cvtA = convertSharingAcc config alyt aenv - cvtAvar :: ScopedAcc a -> AST.ArrayVar aenv a + cvtAvar :: HasCallStack => ScopedAcc a -> AST.ArrayVar aenv a cvtAvar a = case cvtA a of AST.OpenAcc (AST.Avar var) -> var - _ -> $internalError "convertSharingExp" "Expected array computation in expression to be floated out" + _ -> internalError "Expected array computation in expression to be floated out" - cvtFun1 :: TypeR a -> (SmartExp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b) + cvtFun1 :: HasCallStack => TypeR a -> (SmartExp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b) cvtFun1 tp f | DeclareVars lhs k value <- declareVars tp = let @@ -782,7 +802,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp -- Push primitive function applications down through let bindings so that -- they are adjacent to their arguments. It looks a bit nicer this way. -- - cvtPrimFun :: AST.PrimFun (a -> r) -> AST.OpenExp env' aenv' a -> AST.OpenExp env' aenv' r + cvtPrimFun :: HasCallStack => AST.PrimFun (a -> r) -> AST.OpenExp env' aenv' a -> AST.OpenExp env' aenv' r cvtPrimFun f e = case e of AST.Let lhs bnd body -> AST.Let lhs bnd (cvtPrimFun f body) x -> AST.PrimApp f x @@ -790,7 +810,8 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp -- | Convert a unary functions -- convertSharingFun1 - :: Config + :: HasCallStack + => Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables -> TypeR a @@ -808,7 +829,8 @@ convertSharingFun1 config alyt aenv tp f -- | Convert a binary functions -- convertSharingFun2 - :: Config + :: HasCallStack + => Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables -> TypeR a @@ -830,7 +852,8 @@ convertSharingFun2 config alyt aenv ta tb f -- | Convert a unary stencil function -- convertSharingStencilFun1 - :: Config + :: HasCallStack + => Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables -> R.StencilR sh a stencil @@ -842,7 +865,8 @@ convertSharingStencilFun1 config alyt aenv sR1 stencil = -- | Convert a binary stencil function -- convertSharingStencilFun2 - :: Config + :: HasCallStack + => Config -> ArrayLayout aenv aenv -> [StableSharingAcc] -- currently bound array sharing-variables -> R.StencilR sh a stencil1 @@ -1257,7 +1281,8 @@ matchStableSeq sn1 (StableSharingSeq sn2 _) -- They are /not/ directly used to compute the de Brujin indices. -- makeOccMapAcc - :: Config + :: HasCallStack + => Config -> Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, OccMap SmartAcc) @@ -1271,31 +1296,49 @@ makeOccMapAcc config lvl acc = do makeOccMapSharingAcc - :: Config + :: HasCallStack + => Config -> OccMapHash SmartAcc -> Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) makeOccMapSharingAcc config accOccMap = traverseAcc where - traverseFun1 :: Level -> TypeR a -> (SmartExp a -> SmartExp b) -> IO (SmartExp a -> RootExp b, Int) + traverseFun1 + :: HasCallStack + => Level + -> TypeR a + -> (SmartExp a -> SmartExp b) + -> IO (SmartExp a -> RootExp b, Int) traverseFun1 = makeOccMapFun1 config accOccMap - traverseFun2 :: Level - -> TypeR a - -> TypeR b - -> (SmartExp a -> SmartExp b -> SmartExp c) - -> IO (SmartExp a -> SmartExp b -> RootExp c, Int) + traverseFun2 + :: HasCallStack + => Level + -> TypeR a + -> TypeR b + -> (SmartExp a -> SmartExp b -> SmartExp c) + -> IO (SmartExp a -> SmartExp b -> RootExp c, Int) traverseFun2 = makeOccMapFun2 config accOccMap - traverseAfun1 :: Level -> ArraysR a -> (SmartAcc a -> SmartAcc b) -> IO (SmartAcc a -> UnscopedAcc b, Int) + traverseAfun1 + :: HasCallStack + => Level + -> ArraysR a + -> (SmartAcc a -> SmartAcc b) + -> IO (SmartAcc a -> UnscopedAcc b, Int) traverseAfun1 = makeOccMapAfun1 config accOccMap - traverseExp :: Level -> SmartExp e -> IO (RootExp e, Int) + traverseExp + :: HasCallStack + => Level + -> SmartExp e + -> IO (RootExp e, Int) traverseExp = makeOccMapExp config accOccMap traverseBoundary - :: Level + :: HasCallStack + => Level -> ShapeR sh -> PreBoundary SmartAcc SmartExp (Array sh e) -> IO (PreBoundary UnscopedAcc RootExp (Array sh e), Int) @@ -1314,7 +1357,11 @@ makeOccMapSharingAcc config accOccMap = traverseAcc -- -> IO (RootSeq arrs, Int) -- traverseSeq = makeOccMapRootSeq config accOccMap - traverseAcc :: forall arrs. Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) + traverseAcc + :: forall arrs. HasCallStack + => Level + -> SmartAcc arrs + -> IO (UnscopedAcc arrs, Int) traverseAcc lvl acc@(SmartAcc pacc) = mfix $ \ ~(_, height) -> do -- Compute stable name and enter it into the occurrence map @@ -1433,25 +1480,35 @@ makeOccMapSharingAcc config accOccMap = traverseAcc where - travA :: (UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) - -> SmartAcc arrs' -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) + travA :: HasCallStack + => (UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> SmartAcc arrs' + -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travA c acc = do (acc', h) <- traverseAcc lvl acc return (c acc', h + 1) - travEA :: (RootExp b -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) - -> SmartExp b -> SmartAcc arrs' -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) + travEA :: HasCallStack + => (RootExp b -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> SmartExp b + -> SmartAcc arrs' + -> IO (PreSmartAcc 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) - travF2EA :: ((SmartExp b -> SmartExp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) - -> TypeR b -> TypeR c - -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartExp e -> SmartAcc arrs' - -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) + travF2EA + :: HasCallStack + => ((SmartExp b -> SmartExp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> TypeR b + -> TypeR c + -> (SmartExp b -> SmartExp c -> SmartExp d) + -> SmartExp e + -> SmartAcc arrs' + -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travF2EA c t1 t2 fun exp acc = do (fun', h1) <- traverseFun2 lvl t1 t2 fun @@ -1459,10 +1516,15 @@ makeOccMapSharingAcc config accOccMap = traverseAcc (acc', h3) <- traverseAcc lvl acc return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1) - travF2MEA :: ((SmartExp b -> SmartExp c -> RootExp d) -> Maybe (RootExp e) -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) - -> TypeR b -> TypeR c - -> (SmartExp b -> SmartExp c -> SmartExp d) -> Maybe (SmartExp e) -> SmartAcc arrs' - -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) + travF2MEA + :: HasCallStack + => ((SmartExp b -> SmartExp c -> RootExp d) -> Maybe (RootExp e) -> UnscopedAcc arrs' -> PreSmartAcc UnscopedAcc RootExp arrs) + -> TypeR b + -> TypeR c + -> (SmartExp b -> SmartExp c -> SmartExp d) + -> Maybe (SmartExp e) + -> SmartAcc arrs' + -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travF2MEA c t1 t2 fun exp acc = do (fun', h1) <- traverseFun2 lvl t1 t2 fun @@ -1470,16 +1532,21 @@ makeOccMapSharingAcc config accOccMap = traverseAcc (acc', h3) <- traverseAcc lvl acc return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1) - travME :: Maybe (SmartExp t) -> IO (Maybe (RootExp t), Int) + travME :: HasCallStack => Maybe (SmartExp t) -> IO (Maybe (RootExp t), Int) travME Nothing = return (Nothing, 0) travME (Just e) = do (e', c) <- traverseExp lvl e return (Just e', c) - travF2A2 :: ((SmartExp b -> SmartExp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreSmartAcc UnscopedAcc RootExp arrs) - -> TypeR b -> TypeR c - -> (SmartExp b -> SmartExp c -> SmartExp d) -> SmartAcc arrs1 -> SmartAcc arrs2 - -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) + travF2A2 + :: HasCallStack + => ((SmartExp b -> SmartExp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreSmartAcc UnscopedAcc RootExp arrs) + -> TypeR b + -> TypeR c + -> (SmartExp b -> SmartExp c -> SmartExp d) + -> SmartAcc arrs1 + -> SmartAcc arrs2 + -> IO (PreSmartAcc UnscopedAcc RootExp arrs, Int) travF2A2 c t1 t2 fun acc1 acc2 = do (fun' , h1) <- traverseFun2 lvl t1 t2 fun @@ -1487,12 +1554,14 @@ makeOccMapSharingAcc config accOccMap = traverseAcc (acc2', h3) <- traverseAcc lvl acc2 return (c fun' acc1' acc2', h1 `max` h2 `max` h3 + 1) -makeOccMapAfun1 :: Config - -> OccMapHash SmartAcc - -> Level - -> ArraysR a - -> (SmartAcc a -> SmartAcc b) - -> IO (SmartAcc a -> UnscopedAcc b, Int) +makeOccMapAfun1 + :: HasCallStack + => Config + -> OccMapHash SmartAcc + -> Level + -> ArraysR a + -> (SmartAcc a -> SmartAcc b) + -> IO (SmartAcc a -> UnscopedAcc b, Int) makeOccMapAfun1 config accOccMap lvl repr f = do let x = SmartAcc (Atag repr lvl) -- @@ -1534,7 +1603,8 @@ makeOccMapAfun3 config accOccMap lvl f = do -- See Note [Traversing functions and side effects] -- makeOccMapExp - :: Config + :: HasCallStack + => Config -> OccMapHash SmartAcc -> Level -> SmartExp e @@ -1542,7 +1612,8 @@ makeOccMapExp makeOccMapExp config accOccMap lvl = makeOccMapRootExp config accOccMap lvl [] makeOccMapFun1 - :: Config + :: HasCallStack + => Config -> OccMapHash SmartAcc -> Level -> TypeR a @@ -1555,7 +1626,8 @@ makeOccMapFun1 config accOccMap lvl tp f = do return (const body, height) makeOccMapFun2 - :: Config + :: HasCallStack + => Config -> OccMapHash SmartAcc -> Level -> TypeR a @@ -1570,8 +1642,8 @@ makeOccMapFun2 config accOccMap lvl t1 t2 f = do return (\_ _ -> body, height) makeOccMapStencil1 - :: forall sh a b stencil. - Config + :: forall sh a b stencil. HasCallStack + => Config -> OccMapHash SmartAcc -> R.StencilR sh a stencil -> Level @@ -1584,8 +1656,8 @@ makeOccMapStencil1 config accOccMap s lvl stencil = do return (const body, height) makeOccMapStencil2 - :: forall sh a b c stencil1 stencil2. - Config + :: forall sh a b c stencil1 stencil2. HasCallStack + => Config -> OccMapHash SmartAcc -> R.StencilR sh a stencil1 -> R.StencilR sh b stencil2 @@ -1607,7 +1679,8 @@ makeOccMapStencil2 config accOccMap sR1 sR2 lvl stencil = do -- 2) a local occurrence map for that expression. -- makeOccMapRootExp - :: Config + :: HasCallStack + => Config -> OccMapHash SmartAcc -> Level -- The level of currently bound scalar variables -> [Int] -- The tags of newly introduced free scalar variables in this expression @@ -1625,7 +1698,8 @@ makeOccMapRootExp config accOccMap lvl fvs exp = do -- Generate sharing information for an open scalar expression. -- makeOccMapSharingExp - :: Config + :: HasCallStack + => Config -> OccMapHash SmartAcc -> OccMapHash SmartExp -> Level -- The level of currently bound variables @@ -1633,7 +1707,7 @@ makeOccMapSharingExp -> IO (UnscopedExp e, Int) makeOccMapSharingExp config accOccMap expOccMap = travE where - travE :: forall a. Level -> SmartExp a -> IO (UnscopedExp a, Int) + travE :: forall a. HasCallStack => Level -> SmartExp a -> IO (UnscopedExp a, Int) travE lvl exp@(SmartExp pexp) = mfix $ \ ~(_, height) -> do -- Compute stable name and enter it into the occurrence map @@ -1695,13 +1769,15 @@ makeOccMapSharingExp config accOccMap expOccMap = travE Coerce t1 t2 e -> travE1 (Coerce t1 t2) e where - traverseAcc :: Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) + traverseAcc :: HasCallStack => Level -> SmartAcc arrs -> IO (UnscopedAcc arrs, Int) traverseAcc = makeOccMapSharingAcc config accOccMap - traverseFun1 :: Level - -> TypeR a - -> (SmartExp a -> SmartExp b) - -> IO (SmartExp a -> UnscopedExp b, Int) + traverseFun1 + :: HasCallStack + => Level + -> TypeR a + -> (SmartExp a -> SmartExp b) + -> IO (SmartExp a -> UnscopedExp b, Int) traverseFun1 lvl tp f = do let x = SmartExp (Tag tp lvl) @@ -1709,15 +1785,14 @@ makeOccMapSharingExp config accOccMap expOccMap = travE return (const (UnscopedExp [lvl] body), height + 1) - travE1 :: (UnscopedExp b -> r) - -> SmartExp b - -> IO (r, Int) + travE1 :: HasCallStack => (UnscopedExp b -> r) -> SmartExp b -> IO (r, Int) travE1 c e = do (e', h) <- travE lvl e return (c e', h + 1) - travE2 :: (UnscopedExp b -> UnscopedExp c -> r) + travE2 :: HasCallStack + => (UnscopedExp b -> UnscopedExp c -> r) -> SmartExp b -> SmartExp c -> IO (r, Int) @@ -1727,7 +1802,8 @@ makeOccMapSharingExp config accOccMap expOccMap = travE (e2', h2) <- travE lvl e2 return (c e1' e2', h1 `max` h2 + 1) - travE3 :: (UnscopedExp b -> UnscopedExp c -> UnscopedExp d -> r) + travE3 :: HasCallStack + => (UnscopedExp b -> UnscopedExp c -> UnscopedExp d -> r) -> SmartExp b -> SmartExp c -> SmartExp d @@ -1739,15 +1815,14 @@ makeOccMapSharingExp config accOccMap expOccMap = travE (e3', h3) <- travE lvl e3 return (c e1' e2' e3', h1 `max` h2 `max` h3 + 1) - travA :: (UnscopedAcc b -> r) - -> SmartAcc b - -> IO (r, Int) + travA :: HasCallStack => (UnscopedAcc b -> r) -> SmartAcc b -> IO (r, Int) travA c acc = do (acc', h) <- traverseAcc lvl acc return (c acc', h + 1) - travAE :: (UnscopedAcc b -> UnscopedExp c -> r) + travAE :: HasCallStack + => (UnscopedAcc b -> UnscopedExp c -> r) -> SmartAcc b -> SmartExp c -> IO (r, Int) @@ -2047,20 +2122,22 @@ nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeNam -- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments -- at 'determineScopesAcc'. -- -buildInitialEnvAcc :: [Level] -> [StableSharingAcc] -> [StableSharingAcc] +buildInitialEnvAcc + :: HasCallStack + => [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) + sas2 -> internalError ("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 + = internalError ("Encountered a node that is not a plain 'Atag'\n " ++ showSA sa) noStableSharing :: StableSharingAcc noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ()) @@ -2078,20 +2155,22 @@ buildInitialEnvAcc tags sas = map (lookupSA sas) tags -- variable was not preserved and we cannot build an appropriate initial environment (c.f., comments -- at 'determineScopesAcc'. -- -buildInitialEnvExp :: [Level] -> [StableSharingExp] -> [StableSharingExp] +buildInitialEnvExp + :: HasCallStack + => [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)) + ses2 -> internalError ("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) + = internalError ("Encountered a node that is not a plain 'Tag'\n " ++ showSE se) noStableSharing :: StableSharingExp noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp acc exp ()) @@ -2124,7 +2203,8 @@ isFreeVar _ = Fals -- Precondition: there are only 'AvarSharing' and 'AccSharing' nodes in the argument. -- determineScopesAcc - :: Config + :: HasCallStack + => Config -> [Level] -> OccMap SmartAcc -> UnscopedAcc a @@ -2135,19 +2215,20 @@ determineScopesAcc config fvs accOccMap rootAcc in if all isFreeVar counts then (sharingAcc, buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- counts]) - else $internalError "determineScopesAcc" ("unbound shared subtrees" ++ show unboundTrees) + else internalError ("unbound shared subtrees" ++ show unboundTrees) determineScopesSharingAcc - :: Config + :: HasCallStack + => Config -> OccMap SmartAcc -> UnscopedAcc a -> (ScopedAcc a, NodeCounts) determineScopesSharingAcc config accOccMap = scopesAcc where - scopesAcc :: forall arrs. UnscopedAcc arrs -> (ScopedAcc arrs, NodeCounts) + scopesAcc :: forall arrs. HasCallStack => UnscopedAcc arrs -> (ScopedAcc arrs, NodeCounts) scopesAcc (UnscopedAcc _ (AletSharing _ _)) - = $internalError "determineScopesSharingAcc: scopesAcc" "unexpected 'AletSharing'" + = internalError "unexpected 'AletSharing'" scopesAcc (UnscopedAcc _ (AvarSharing sn tp)) = (ScopedAcc [] (AvarSharing sn tp), StableSharingAcc sn (AvarSharing sn tp) `insertAccNode` noNodeCounts) @@ -2263,7 +2344,8 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- reconstruct (Collect seq') accCount1 where - travEA :: (ScopedExp e -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) + travEA :: HasCallStack + => (ScopedExp e -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) -> RootExp e -> UnscopedAcc arrs' -> (ScopedAcc arrs, NodeCounts) @@ -2272,41 +2354,44 @@ determineScopesSharingAcc config accOccMap = scopesAcc (e' , accCount1) = scopesExp e (acc', accCount2) = scopesAcc acc - travF2EA :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedExp e - -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) - -> (SmartExp a -> SmartExp b -> RootExp c) - -> RootExp e - -> UnscopedAcc arrs' - -> (ScopedAcc arrs, NodeCounts) + travF2EA + :: HasCallStack + => ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedExp e -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) + -> (SmartExp a -> SmartExp 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 - travF2MEA :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> Maybe (ScopedExp e) - -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) - -> (SmartExp a -> SmartExp b -> RootExp c) - -> Maybe (RootExp e) - -> UnscopedAcc arrs' - -> (ScopedAcc arrs, NodeCounts) + travF2MEA + :: HasCallStack + => ((SmartExp a -> SmartExp b -> ScopedExp c) -> Maybe (ScopedExp e) -> ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) + -> (SmartExp a -> SmartExp b -> RootExp c) + -> Maybe (RootExp e) + -> UnscopedAcc arrs' + -> (ScopedAcc arrs, NodeCounts) travF2MEA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3) where (f' , accCount1) = scopesFun2 f (e' , accCount2) = travME e (acc', accCount3) = scopesAcc acc - travME :: Maybe (RootExp e) -> (Maybe (ScopedExp e), NodeCounts) + travME :: HasCallStack => Maybe (RootExp e) -> (Maybe (ScopedExp e), NodeCounts) travME Nothing = (Nothing, noNodeCounts) travME (Just e) = (Just e', c) where (e', c) = scopesExp e - travF2A2 :: ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedAcc arrs1 - -> ScopedAcc arrs2 -> PreSmartAcc ScopedAcc ScopedExp arrs) - -> (SmartExp a -> SmartExp b -> RootExp c) - -> UnscopedAcc arrs1 - -> UnscopedAcc arrs2 - -> (ScopedAcc arrs, NodeCounts) + travF2A2 + :: HasCallStack + => ((SmartExp a -> SmartExp b -> ScopedExp c) -> ScopedAcc arrs1 -> ScopedAcc arrs2 -> PreSmartAcc ScopedAcc ScopedExp arrs) + -> (SmartExp a -> SmartExp b -> RootExp c) + -> UnscopedAcc arrs1 + -> UnscopedAcc arrs2 + -> (ScopedAcc arrs, NodeCounts) travF2A2 c f acc1 acc2 = reconstruct (c f' acc1' acc2') (accCount1 +++ accCount2 +++ accCount3) where @@ -2314,7 +2399,8 @@ determineScopesSharingAcc config accOccMap = scopesAcc (acc1', accCount2) = scopesAcc acc1 (acc2', accCount3) = scopesAcc acc2 - travA :: (ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) + travA :: HasCallStack + => (ScopedAcc arrs' -> PreSmartAcc ScopedAcc ScopedExp arrs) -> UnscopedAcc arrs' -> (ScopedAcc arrs, NodeCounts) travA c acc = reconstruct (c acc') accCount @@ -2338,9 +2424,11 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- In either case, any completed 'NodeCounts' are injected as bindings using 'AletSharing' -- node. -- - reconstruct :: PreSmartAcc ScopedAcc ScopedExp arrs - -> NodeCounts - -> (ScopedAcc arrs, NodeCounts) + reconstruct + :: HasCallStack + => PreSmartAcc ScopedAcc ScopedExp arrs + -> NodeCounts + -> (ScopedAcc arrs, NodeCounts) reconstruct newAcc@(Atag tp _) _subCount -- free variable => replace by a sharing variable regardless of the number of -- occurrences @@ -2404,13 +2492,19 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- scopesSeq :: forall arrs. RootSeq arrs -> (ScopedSeq arrs, NodeCounts) -- scopesSeq = determineScopesSeq config accOccMap - scopesExp :: RootExp t -> (ScopedExp t, NodeCounts) + scopesExp + :: HasCallStack + => 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 :: (SmartAcc a1 -> UnscopedAcc a2) -> (SmartAcc a1 -> ScopedAcc a2, NodeCounts) + scopesAfun1 + :: HasCallStack + => (SmartAcc a1 -> UnscopedAcc a2) + -> (SmartAcc a1 -> ScopedAcc a2, NodeCounts) scopesAfun1 f = (const (ScopedAcc ssa body'), (counts', graph)) where body@(UnscopedAcc fvs _) = f undefined @@ -2424,7 +2518,10 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- The lambda bound variable is at this point already irrelevant; for details, see -- Note [Traversing functions and side effects] -- - scopesFun1 :: (SmartExp e1 -> RootExp e2) -> (SmartExp e1 -> ScopedExp e2, NodeCounts) + scopesFun1 + :: HasCallStack + => (SmartExp e1 -> RootExp e2) + -> (SmartExp e1 -> ScopedExp e2, NodeCounts) scopesFun1 f = (const body, counts) where (body, counts) = scopesExp (f undefined) @@ -2432,8 +2529,10 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- The lambda bound variable is at this point already irrelevant; for details, see -- Note [Traversing functions and side effects] -- - scopesFun2 :: (SmartExp e1 -> SmartExp e2 -> RootExp e3) - -> (SmartExp e1 -> SmartExp e2 -> ScopedExp e3, NodeCounts) + scopesFun2 + :: HasCallStack + => (SmartExp e1 -> SmartExp e2 -> RootExp e3) + -> (SmartExp e1 -> SmartExp e2 -> ScopedExp e3, NodeCounts) scopesFun2 f = (\_ _ -> body, counts) where (body, counts) = scopesExp (f undefined undefined) @@ -2441,10 +2540,11 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- 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. - UnscopedAcc (Array sh e1){-dummy-} - -> (stencil -> RootExp e2) - -> (stencil -> ScopedExp e2, NodeCounts) + scopesStencil1 + :: forall sh e1 e2 stencil. HasCallStack + => UnscopedAcc (Array sh e1){-dummy-} + -> (stencil -> RootExp e2) + -> (stencil -> ScopedExp e2, NodeCounts) scopesStencil1 _ stencilFun = (const body, counts) where (body, counts) = scopesExp (stencilFun undefined) @@ -2452,17 +2552,20 @@ determineScopesSharingAcc config accOccMap = scopesAcc -- 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. - UnscopedAcc (Array sh e1){-dummy-} - -> UnscopedAcc (Array sh e2){-dummy-} - -> (stencil1 -> stencil2 -> RootExp e3) - -> (stencil1 -> stencil2 -> ScopedExp e3, NodeCounts) + scopesStencil2 + :: forall sh e1 e2 e3 stencil1 stencil2. HasCallStack + => 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 + :: HasCallStack + => PreBoundary UnscopedAcc RootExp t + -> (PreBoundary ScopedAcc ScopedExp t, NodeCounts) scopesBoundary bndy = case bndy of Clamp -> (Clamp, noNodeCounts) @@ -2474,7 +2577,8 @@ determineScopesSharingAcc config accOccMap = scopesAcc determineScopesExp - :: Config + :: HasCallStack + => Config -> OccMap SmartAcc -> RootExp t -> (ScopedExp t, NodeCounts) -- Root (closed) expression plus Acc node counts @@ -2490,17 +2594,24 @@ determineScopesExp config accOccMap (RootExp expOccMap exp@(UnscopedExp fvs _)) determineScopesSharingExp - :: Config + :: HasCallStack + => Config -> OccMap SmartAcc -> OccMap SmartExp -> UnscopedExp t -> (ScopedExp t, NodeCounts) determineScopesSharingExp config accOccMap expOccMap = scopesExp where - scopesAcc :: UnscopedAcc a -> (ScopedAcc a, NodeCounts) + scopesAcc + :: HasCallStack + => UnscopedAcc a + -> (ScopedAcc a, NodeCounts) scopesAcc = determineScopesSharingAcc config accOccMap - scopesFun1 :: (SmartExp a -> UnscopedExp b) -> (SmartExp a -> ScopedExp b, NodeCounts) + scopesFun1 + :: HasCallStack + => (SmartExp a -> UnscopedExp b) + -> (SmartExp a -> ScopedExp b, NodeCounts) scopesFun1 f = tracePure ("LAMBDA " ++ show ssa) (show counts) (const (ScopedExp ssa body'), (counts',graph)) where body@(UnscopedExp fvs _) = f undefined @@ -2511,10 +2622,12 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp isBoundHere (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag _ i))) _) = i `elem` fvs isBoundHere _ = False - - scopesExp :: forall t. UnscopedExp t -> (ScopedExp t, NodeCounts) + scopesExp + :: forall t. HasCallStack + => UnscopedExp t + -> (ScopedExp t, NodeCounts) scopesExp (UnscopedExp _ (LetSharing _ _)) - = $internalError "determineScopesSharingExp: scopesExp" "unexpected 'LetSharing'" + = internalError "unexpected 'LetSharing'" scopesExp (UnscopedExp _ (VarSharing sn tp)) = (ScopedExp [] (VarSharing sn tp), StableSharingExp sn (VarSharing sn tp) `insertExpNode` noNodeCounts) @@ -2549,13 +2662,16 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp Foreign tp ff f e -> travE1 (Foreign tp ff f) e Coerce t1 t2 e -> travE1 (Coerce t1 t2) e where - travE1 :: (ScopedExp a -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedExp a + travE1 :: HasCallStack + => (ScopedExp a -> PreSmartExp 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 -> PreSmartExp ScopedAcc ScopedExp t) + travE2 :: HasCallStack + => (ScopedExp a -> ScopedExp b -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedExp a -> UnscopedExp b -> (ScopedExp t, NodeCounts) @@ -2564,7 +2680,8 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp (e1', accCount1) = scopesExp e1 (e2', accCount2) = scopesExp e2 - travE3 :: (ScopedExp a -> ScopedExp b -> ScopedExp c -> PreSmartExp ScopedAcc ScopedExp t) + travE3 :: HasCallStack + => (ScopedExp a -> ScopedExp b -> ScopedExp c -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedExp a -> UnscopedExp b -> UnscopedExp c @@ -2575,13 +2692,15 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp (e2', accCount2) = scopesExp e2 (e3', accCount3) = scopesExp e3 - travA :: (ScopedAcc a -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedAcc a + travA :: HasCallStack + => (ScopedAcc a -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedAcc a -> (ScopedExp t, NodeCounts) travA c acc = floatOutAcc c acc' accCount where (acc', accCount) = scopesAcc acc - travAE :: (ScopedAcc a -> ScopedExp b -> PreSmartExp ScopedAcc ScopedExp t) + travAE :: HasCallStack + => (ScopedAcc a -> ScopedExp b -> PreSmartExp ScopedAcc ScopedExp t) -> UnscopedAcc a -> UnscopedExp b -> (ScopedExp t, NodeCounts) @@ -2590,10 +2709,12 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp (acc', accCountA) = scopesAcc acc (e' , accCountE) = scopesExp e - floatOutAcc :: (ScopedAcc a -> PreSmartExp ScopedAcc ScopedExp t) - -> ScopedAcc a - -> NodeCounts - -> (ScopedExp t, NodeCounts) + floatOutAcc + :: HasCallStack + => (ScopedAcc a -> PreSmartExp ScopedAcc ScopedExp t) + -> ScopedAcc a + -> NodeCounts + -> (ScopedExp t, NodeCounts) floatOutAcc c acc@(ScopedAcc _ (AvarSharing _ _)) accCount -- nothing to float out = reconstruct (c acc) accCount floatOutAcc c acc accCount @@ -2601,9 +2722,12 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp 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 + :: HasCallStack + => ScopedAcc a + -> (ScopedAcc a -> SharingAcc ScopedAcc ScopedExp a) + -> (ScopedAcc a, StableSharingAcc) + abstract (ScopedAcc _ (AvarSharing _ _)) _ = internalError "AvarSharing" abstract (ScopedAcc ssa (AletSharing sa acc)) lets = abstract acc (lets . ScopedAcc ssa . AletSharing sa) abstract acc@(ScopedAcc ssa (AccSharing sn a)) lets = (ScopedAcc ssa (AvarSharing sn $ Smart.arraysR a), StableSharingAcc sn (lets acc)) @@ -2623,8 +2747,11 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp -- In either case, any completed 'NodeCounts' are injected as bindings using 'LetSharing' -- node. -- - reconstruct :: PreSmartExp ScopedAcc ScopedExp t -> NodeCounts - -> (ScopedExp t, NodeCounts) + reconstruct + :: HasCallStack + => PreSmartExp ScopedAcc ScopedExp t + -> NodeCounts + -> (ScopedExp t, NodeCounts) reconstruct newExp@(Tag tp _) _subCount -- free variable => replace by a sharing variable regardless of the number of -- occurrences @@ -2664,7 +2791,7 @@ determineScopesSharingExp config accOccMap expOccMap = scopesExp -- complete). Otherwise, we would let-bind subterms before their parents, which leads -- scope errors. -- - filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingExp]) + filterCompleted :: HasCallStack => NodeCounts -> (NodeCounts, [StableSharingExp]) filterCompleted (ns,graph) = let bindable = map (isBindable bindable (map nodeName ns)) ns (bind, unbind) = partition fst $ zip bindable ns @@ -2851,7 +2978,8 @@ determineScopesSharingSeq config accOccMap _seqOccMap = scopesSeq -- {-# NOINLINE recoverSharingAcc #-} recoverSharingAcc - :: Config + :: HasCallStack + => Config -> Level -- The level of currently bound array variables -> [Level] -- The tags of newly introduced free array variables -> SmartAcc a @@ -2866,7 +2994,8 @@ recoverSharingAcc config alvl avars acc {-# NOINLINE recoverSharingExp #-} recoverSharingExp - :: Config + :: HasCallStack + => Config -> Level -- The level of currently bound scalar variables -> [Level] -- The tags of newly introduced free scalar variables -> SmartExp e diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index f0588ada8..fddb34db4 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -61,6 +61,8 @@ import Data.Monoid import Data.Semigroup import Prelude hiding ( exp, seq ) +import GHC.Stack + data VarsRange env = VarsRange !(Exists (Idx env)) -- rightmost variable @@ -167,15 +169,19 @@ loopCount :: Count -> Count loopCount (Finite n) | n > 0 = Infinity loopCount c = c -shrinkLhs :: Count -> LeftHandSide s t env1 env2 -> Maybe (Exists (LeftHandSide s t env1)) +shrinkLhs + :: HasCallStack + => Count + -> LeftHandSide s t env1 env2 + -> Maybe (Exists (LeftHandSide s t env1)) shrinkLhs _ (LeftHandSideWildcard _) = Nothing -- We cannot shrink this shrinkLhs (Finite 0) lhs = Just $ Exists $ LeftHandSideWildcard $ lhsToTupR lhs -- LHS isn't used at all, replace with a wildcard shrinkLhs (Impossible usages) lhs = case go usages lhs of (True , [], lhs') -> Just lhs' (False, [], _ ) -> Nothing -- No variables were dropped. Thus lhs == lhs'. - _ -> $internalError "shrinkLhs" "Mismatch in length of usages array and LHS" + _ -> internalError "Mismatch in length of usages array and LHS" where - go :: Usages -> LeftHandSide s t env1 env2 -> (Bool, Usages, Exists (LeftHandSide s t env1)) + go :: HasCallStack => Usages -> LeftHandSide s t env1 env2 -> (Bool, Usages, Exists (LeftHandSide s t env1)) go us (LeftHandSideWildcard tp) = (False, us, Exists $ LeftHandSideWildcard tp) go (True : us) (LeftHandSideSingle tp) = (False, us, Exists $ LeftHandSideSingle tp) go (False : us) (LeftHandSideSingle tp) = (True , us, Exists $ LeftHandSideWildcard $ TupRsingle tp) @@ -190,14 +196,19 @@ shrinkLhs (Impossible usages) lhs = case go usages lhs of | otherwise = LeftHandSidePair l1' l2'' in (c1 || c2, us'', Exists lhs') - go _ _ = $internalError "shrinkLhs" "Empty array, mismatch in length of usages array and LHS" + go _ _ = internalError "Empty array, mismatch in length of usages array and LHS" shrinkLhs _ _ = Nothing -- The first LHS should be 'larger' than the second, eg the second may have -- a wildcard if the first LHS does bind variables there, but not the other -- way around. -- -strengthenShrunkLHS :: LeftHandSide s t env1 env2 -> LeftHandSide s t env1' env2' -> env1 :?> env1' -> env2 :?> env2' +strengthenShrunkLHS + :: HasCallStack + => LeftHandSide s t env1 env2 + -> LeftHandSide s t env1' env2' + -> env1 :?> env1' + -> env2 :?> env2' strengthenShrunkLHS (LeftHandSideWildcard _) (LeftHandSideWildcard _) k = k strengthenShrunkLHS (LeftHandSideSingle _) (LeftHandSideSingle _) k = \ix -> case ix of ZeroIdx -> Just ZeroIdx @@ -209,8 +220,8 @@ strengthenShrunkLHS (LeftHandSideSingle _) (LeftHandSideWildcard _) k = \ix -> strengthenShrunkLHS (LeftHandSidePair l h) (LeftHandSideWildcard t) k = strengthenShrunkLHS h (LeftHandSideWildcard t2) $ strengthenShrunkLHS l (LeftHandSideWildcard t1) k where TupRpair t1 t2 = t -strengthenShrunkLHS (LeftHandSideWildcard _) _ _ = $internalError "strengthenShrunkLHS" "Second LHS defines more variables" -strengthenShrunkLHS _ _ _ = $internalError "strengthenShrunkLHS" "Mismatch LHS single with LHS pair" +strengthenShrunkLHS (LeftHandSideWildcard _) _ _ = internalError "Second LHS defines more variables" +strengthenShrunkLHS _ _ _ = internalError "Mismatch LHS single with LHS pair" -- Shrinking @@ -220,7 +231,7 @@ strengthenShrunkLHS _ _ _ = $inter -- instance of beta-reduction to cases where the bound variable is used zero -- (dead-code elimination) or one (linear inlining) times. -- -shrinkExp :: OpenExp env aenv t -> (Bool, OpenExp env aenv t) +shrinkExp :: HasCallStack => OpenExp env aenv t -> (Bool, OpenExp env aenv t) shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE where -- If the bound variable is used at most this many times, it will be inlined @@ -231,25 +242,25 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE lIMIT = 1 cheap :: OpenExp env aenv t -> Bool - cheap (Evar _) = True - cheap (Pair e1 e2) = cheap e1 && cheap e2 - cheap Nil = True - cheap Const{} = True - cheap PrimConst{} = True - cheap Undef{} = True + cheap (Evar _) = True + cheap (Pair e1 e2) = cheap e1 && cheap e2 + cheap Nil = True + cheap Const{} = True + cheap PrimConst{} = True + cheap Undef{} = True cheap (Coerce _ _ e) = cheap e - cheap _ = False + cheap _ = False - shrinkE :: OpenExp env aenv t -> (Any, OpenExp env aenv t) + shrinkE :: HasCallStack => OpenExp env aenv t -> (Any, OpenExp env aenv t) shrinkE exp = case exp of Let (LeftHandSideSingle _) bnd@Evar{} body -> Stats.inline "Var" . yes $ shrinkE (inline body bnd) Let lhs bnd body | shouldInline -> case inlineVars lhs (snd body') (snd bnd') of Just inlined -> Stats.betaReduce msg . yes $ shrinkE inlined - _ -> $internalError "shrinkExp" "Unexpected failure while trying to inline some expression." + _ -> internalError "Unexpected failure while trying to inline some expression." | Just (Exists lhs') <- shrinkLhs count lhs -> case strengthenE (strengthenShrunkLHS lhs lhs' Just) (snd body') of Just body'' -> (Any True, Let lhs' (snd bnd') body'') - Nothing -> $internalError "shrinkExp" "Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." + Nothing -> internalError "Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." | otherwise -> Let lhs <$> bnd' <*> body' where shouldInline = case count of @@ -300,7 +311,7 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE Foreign repr ff f e -> Foreign repr ff <$> shrinkF f <*> shrinkE e Coerce t1 t2 e -> Coerce t1 t2 <$> shrinkE e - shrinkF :: OpenFun env aenv t -> (Any, OpenFun env aenv t) + shrinkF :: HasCallStack => OpenFun env aenv t -> (Any, OpenFun env aenv t) shrinkF = first Any . shrinkFun first :: (a -> a') -> (a,b) -> (a',b) @@ -309,7 +320,7 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE yes :: (Any, x) -> (Any, x) yes (_, x) = (Any True, x) -shrinkFun :: OpenFun env aenv f -> (Bool, OpenFun env aenv f) +shrinkFun :: HasCallStack => OpenFun env aenv f -> (Bool, OpenFun env aenv f) shrinkFun (Lam lhs f) = case lhsVarsRange lhs of Left Refl -> let b' = case lhs of @@ -322,7 +333,7 @@ shrinkFun (Lam lhs f) = case lhsVarsRange lhs of in case shrinkLhs count lhs of Just (Exists lhs') -> case strengthenE (strengthenShrunkLHS lhs lhs' Just) f' of Just f'' -> (True, Lam lhs' f'') - Nothing -> $internalError "shrinkFun" "Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." + Nothing -> internalError "Unexpected failure in strenthenE. Variable was analysed to be unused in usesOfExp, but appeared to be used in strenthenE." Nothing -> (b, Lam lhs f') where (b, f') = shrinkFun f diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index 0e6161df2..368d83fb5 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -7,7 +7,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -56,6 +55,8 @@ import Data.Monoid import Text.Printf import Prelude hiding ( exp, iterate ) +import GHC.Stack + -- Scalar optimisations -- ==================== @@ -334,10 +335,10 @@ lhsExpr (LeftHandSidePair l1 l2) env = lhsExpr l2 $ lhsExpr l1 env -- Simplify closed expressions and functions. The process is applied -- repeatedly until no more changes are made. -- -simplifyExp :: Exp aenv t -> Exp aenv t +simplifyExp :: HasCallStack => Exp aenv t -> Exp aenv t simplifyExp = iterate summariseOpenExp matchOpenExp shrinkExp (simplifyOpenExp EmptyExp) -simplifyFun :: Fun aenv f -> Fun aenv f +simplifyFun :: HasCallStack => Fun aenv f -> Fun aenv f simplifyFun = iterate summariseOpenFun matchOpenFun shrinkFun (simplifyOpenFun EmptyExp) @@ -360,7 +361,8 @@ simplifyFun = iterate summariseOpenFun matchOpenFun shrinkFun (simplifyOpenFun E -- iterate - :: forall f a. (f a -> Stats) + :: forall f a. HasCallStack + => (f a -> Stats) -> (forall s t. f s -> f t -> Maybe (s :~: t)) -- match -> (f a -> (Bool, f a)) -- shrink -> (f a -> (Bool, f a)) -- simplify @@ -381,7 +383,7 @@ iterate summarise match shrink simplify = fix 1 . setup fix :: Int -> f a -> f a fix i x0 - | i > lIMIT = $internalWarning "simplify" "iteration limit reached" (not (x0 ==^ simplify x0)) x0 + | i > lIMIT = internalWarning "iteration limit reached" (not (x0 ==^ simplify x0)) x0 | not shrunk = x1 | not simplified = x2 | otherwise = fix (i+1) x2 diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index f54a4dafc..a19eb0577 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -62,6 +62,8 @@ import Control.Applicative hiding ( Const ) import Control.Monad import Prelude hiding ( exp, seq ) +import GHC.Stack + -- NOTE: [Renaming and Substitution] -- @@ -217,7 +219,8 @@ substitute :: LeftHandSide b env envb -- | Composition of unary functions. -- -compose :: OpenFun env aenv (b -> c) +compose :: HasCallStack + => OpenFun env aenv (b -> c) -> OpenFun env aenv (a -> b) -> OpenFun env aenv (a -> c) compose f@(Lam lhsB (Body c)) g@(Lam lhsA (Body b)) @@ -524,7 +527,7 @@ shiftE' _ _ _ = error "Substitution: left hand sides do not match" {-# INLINEABLE rebuildMaybeExp #-} rebuildMaybeExp - :: (Applicative f, SyntacticExp fe) + :: (HasCallStack, Applicative f, SyntacticExp fe) => RebuildEvar f fe env env' aenv' -> ReindexAvar f aenv aenv' -> Maybe (OpenExp env aenv t) @@ -534,7 +537,7 @@ rebuildMaybeExp v av (Just x) = Just <$> rebuildOpenExp v av x {-# INLINEABLE rebuildOpenExp #-} rebuildOpenExp - :: (Applicative f, SyntacticExp fe) + :: (HasCallStack, Applicative f, SyntacticExp fe) => RebuildEvar f fe env env' aenv' -> ReindexAvar f aenv aenv' -> OpenExp env aenv t @@ -569,7 +572,7 @@ rebuildOpenExp v av@(ReindexAvar reindex) exp = {-# INLINEABLE rebuildFun #-} rebuildFun - :: (Applicative f, SyntacticExp fe) + :: (HasCallStack, Applicative f, SyntacticExp fe) => RebuildEvar f fe env env' aenv' -> ReindexAvar f aenv aenv' -> OpenFun env aenv t @@ -585,7 +588,7 @@ rebuildFun v av fun = -- ----------------- type RebuildAcc acc = - forall aenv aenv' f fa a. (Applicative f, SyntacticAcc fa) + forall aenv aenv' f fa a. (HasCallStack, Applicative f, SyntacticAcc fa) => RebuildAvar f fa acc aenv aenv' -> acc aenv a -> f (acc aenv' a) @@ -618,7 +621,7 @@ newtype ReindexAvar f aenv aenv' = reindexAvar :: forall f fa acc aenv aenv'. - (Applicative f, SyntacticAcc fa) + (HasCallStack, Applicative f, SyntacticAcc fa) => RebuildAvar f fa acc aenv aenv' -> ReindexAvar f aenv aenv' reindexAvar v = ReindexAvar f where @@ -628,12 +631,12 @@ reindexAvar v = ReindexAvar f where g :: fa acc aenv' (Array sh e) -> ArrayVar aenv' (Array sh e) g fa = case accOut fa of Avar var' -> var' - _ -> $internalError "reindexAvar" "An Avar which was used in an Exp was mapped to an array term other than Avar. This mapping is invalid as an Exp can only contain array variables." + _ -> internalError "An Avar which was used in an Exp was mapped to an array term other than Avar. This mapping is invalid as an Exp can only contain array variables." {-# INLINEABLE shiftA #-} shiftA - :: (Applicative f, SyntacticAcc fa) + :: (HasCallStack, Applicative f, SyntacticAcc fa) => RebuildAcc acc -> RebuildAvar f fa acc aenv aenv' -> ArrayVar (aenv, s) (Array sh e) @@ -642,7 +645,7 @@ shiftA _ _ (Var s ZeroIdx) = pure $ avarIn $ Var s ZeroIdx shiftA k v (Var s (SuccIdx ix)) = weakenAcc k <$> v (Var s ix) shiftA' - :: (Applicative f, SyntacticAcc fa) + :: (HasCallStack, Applicative f, SyntacticAcc fa) => ALeftHandSide t aenv1 aenv1' -> ALeftHandSide t aenv2 aenv2' -> RebuildAcc acc @@ -651,11 +654,11 @@ shiftA' shiftA' (LeftHandSideWildcard _) (LeftHandSideWildcard _) _ v = v shiftA' (LeftHandSideSingle _) (LeftHandSideSingle _) k v = shiftA k v shiftA' (LeftHandSidePair a1 b1) (LeftHandSidePair a2 b2) k v = shiftA' b1 b2 k $ shiftA' a1 a2 k v -shiftA' _ _ _ _ = $internalError "Substitution/shiftA'" "left hand sides do not match" +shiftA' _ _ _ _ = internalError "left hand sides do not match" {-# INLINEABLE rebuildOpenAcc #-} rebuildOpenAcc - :: (Applicative f, SyntacticAcc fa) + :: (HasCallStack, Applicative f, SyntacticAcc fa) => (forall sh e. ArrayVar aenv (Array sh e) -> f (fa OpenAcc aenv' (Array sh e))) -> OpenAcc aenv t -> f (OpenAcc aenv' t) @@ -663,7 +666,7 @@ rebuildOpenAcc av (OpenAcc acc) = OpenAcc <$> rebuildPreOpenAcc rebuildOpenAcc a {-# INLINEABLE rebuildPreOpenAcc #-} rebuildPreOpenAcc - :: (Applicative f, SyntacticAcc fa) + :: (HasCallStack, Applicative f, SyntacticAcc fa) => RebuildAcc acc -> RebuildAvar f fa acc aenv aenv' -> PreOpenAcc acc aenv t @@ -702,7 +705,7 @@ rebuildPreOpenAcc k av acc = {-# INLINEABLE rebuildAfun #-} rebuildAfun - :: (Applicative f, SyntacticAcc fa) + :: (HasCallStack, Applicative f, SyntacticAcc fa) => RebuildAcc acc -> RebuildAvar f fa acc aenv aenv' -> PreOpenAfun acc aenv t @@ -713,7 +716,7 @@ rebuildAfun k av (Alam lhs1 f) = Alam lhs2 <$> rebuildAfun k (shiftA' lhs1 lhs2 k av) f rebuildAlet - :: forall f fa acc aenv1 aenv1' aenv2 bndArrs arrs. (Applicative f, SyntacticAcc fa) + :: forall f fa acc aenv1 aenv1' aenv2 bndArrs arrs. (HasCallStack, Applicative f, SyntacticAcc fa) => RebuildAcc acc -> RebuildAvar f fa acc aenv1 aenv2 -> ALeftHandSide bndArrs aenv1 aenv1' From 0c2d7dd6fe20c2ac6f5fc92ea8563627e3550b05 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 26 Jun 2020 02:07:07 +0200 Subject: [PATCH 260/316] typo --- src/Data/Array/Accelerate/Test/NoFib/Sharing.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs b/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs index d69b209fa..7ee5e0aa7 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs @@ -60,7 +60,7 @@ test_sharing = , testCase "unused" $ sharingExp test_unused_iteration ] , testGroup "nested data-parallelism" - [ expectFail $ testCase "mvm" $ sharingAcc test_nested_data_praallelism + [ expectFail $ testCase "mvm" $ sharingAcc test_nested_data_parallelism ] ] where @@ -312,8 +312,8 @@ test_unused_iteration = -- This program contains nested data-parallelism and thus sharing recovery -- will fail. -- -test_nested_data_praallelism :: Acc (Vector Float) -test_nested_data_praallelism = +test_nested_data_parallelism :: Acc (Vector Float) +test_nested_data_parallelism = 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) From d38e46deca6baa384cf6f2131480473f7c317df4 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 26 Jun 2020 02:07:34 +0200 Subject: [PATCH 261/316] ci: revert windows build to ghc-8.6 --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 737f3677d..18e791d94 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -32,7 +32,7 @@ jobs: # 32-bit linker problem, failing with the error: # Access violation in generated code when writing 0x0 - os: windows-latest - ghc: "8.10" + ghc: "8.6" allow_failure: false env: STACK_FLAGS: "--system-ghc --no-install-ghc --fast --flag accelerate:nofib" From ae3c08aee4cf73385a02a2bfa38b926e2a8265e0 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 26 Jun 2020 02:27:10 +0200 Subject: [PATCH 262/316] display a more compact call stack --- src/Data/Array/Accelerate/Error.hs | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/Accelerate/Error.hs b/src/Data/Array/Accelerate/Error.hs index 0dac94bd5..1ef9f9d1d 100644 --- a/src/Data/Array/Accelerate/Error.hs +++ b/src/Data/Array/Accelerate/Error.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Error @@ -19,8 +20,9 @@ module Data.Array.Accelerate.Error ( ) where import Debug.Trace +import Data.List ( intercalate ) import Text.Printf -import Prelude hiding ( error ) +import Prelude hiding ( error ) import GHC.Stack @@ -90,16 +92,33 @@ warning kind msg cond k = False -> trace (format kind msg) k format :: HasCallStack => Check -> String -> String -format kind msg = unlines [ header, msg, "", prettyCallStack callStack ] +format kind msg = intercalate "\n" [ header, msg, ppCallStack callStack ] where header - = unlines + = intercalate "\n" $ case kind of Internal -> ["" ,"*** Internal error in package accelerate ***" ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"] _ -> [] +ppCallStack :: CallStack -> String +ppCallStack = intercalate "\n" . ppLines + where + ppLines cs = + case getCallStack cs of + [] -> [] + st -> "CallStack (from HasCallStack):" + : map ((" " ++) . ppCallSite) st + + ppCallSite (f, loc) = f ++ ": " ++ ppSrcLoc loc + + ppSrcLoc SrcLoc{..} = + foldr (++) "" + [ srcLocModule, ":" + , show srcLocStartLine, ":" + , show srcLocStartCol + ] -- CPP malarky -- ----------- From 5faf6fd132a1cb042ae9dd17278629c53b053c07 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 26 Jun 2020 02:29:42 +0200 Subject: [PATCH 263/316] ci: just allow windows to fail \: --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 18e791d94..43906f317 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -32,8 +32,8 @@ jobs: # 32-bit linker problem, failing with the error: # Access violation in generated code when writing 0x0 - os: windows-latest - ghc: "8.6" - allow_failure: false + ghc: "8.10" + allow_failure: true env: STACK_FLAGS: "--system-ghc --no-install-ghc --fast --flag accelerate:nofib" From 17ec82eb4d3fcea3612bf559bf370b824ec1f146 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 26 Jun 2020 13:29:47 +0200 Subject: [PATCH 264/316] wibble --- src/Data/Array/Accelerate/Error.hs | 3 ++- src/Data/Array/Accelerate/Trafo/Sharing.hs | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/Accelerate/Error.hs b/src/Data/Array/Accelerate/Error.hs index 1ef9f9d1d..466caa248 100644 --- a/src/Data/Array/Accelerate/Error.hs +++ b/src/Data/Array/Accelerate/Error.hs @@ -99,7 +99,8 @@ format kind msg = intercalate "\n" [ header, msg, ppCallStack callStack ] $ case kind of Internal -> ["" ,"*** Internal error in package accelerate ***" - ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues"] + ,"*** Please submit a bug report at https://github.com/AccelerateHS/accelerate/issues" + ,""] _ -> [] ppCallStack :: CallStack -> String diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 9442d082d..35a1c0b9e 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -717,9 +717,9 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp , "" , "> 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))))" + , "> let I2 rows cols = shape mat" + , "> in generate (I1 cols)" + , "> (\\(I1 col) -> the $ sum (slice mat (lift (Z :. All :. 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" From a7f82ff60e5720861346e968271deced099c05a5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 29 Jun 2020 18:51:21 +0200 Subject: [PATCH 265/316] drop old tools --- {utils => tools}/hackage-docs.sh | 0 utils/README | 5 ----- utils/ghc-core | 11 ----------- utils/ghci | 11 ----------- 4 files changed, 27 deletions(-) rename {utils => tools}/hackage-docs.sh (100%) delete mode 100644 utils/README delete mode 100755 utils/ghc-core delete mode 100755 utils/ghci diff --git a/utils/hackage-docs.sh b/tools/hackage-docs.sh similarity index 100% rename from utils/hackage-docs.sh rename to tools/hackage-docs.sh diff --git a/utils/README b/utils/README deleted file mode 100644 index 49a45f15f..000000000 --- a/utils/README +++ /dev/null @@ -1,5 +0,0 @@ -This directory contains some utilities to use Accelerate from within GHCi. - -Symling (or copy) the wrapper script 'ghci' to the root directory of the -accelerate source tree. - diff --git a/utils/ghc-core b/utils/ghc-core deleted file mode 100755 index 0ae519268..000000000 --- a/utils/ghc-core +++ /dev/null @@ -1,11 +0,0 @@ -#!/bin/bash - -GHC_CORE=`which -a ghc-core | grep -v "\./ghc-core"` - -$GHC_CORE --no-cast --no-asm -- \ - -odir dist/build -hidir dist/build \ - -optP -include -optP dist/build/autogen/cabal_macros.h \ - -iutils -Iinclude \ - -O2 \ - $@ - diff --git a/utils/ghci b/utils/ghci deleted file mode 100755 index 1fc06247f..000000000 --- a/utils/ghci +++ /dev/null @@ -1,11 +0,0 @@ -#!/bin/sh - -# Load up GHCi with an appropriate environment -# -DISTDIR=$(stack path --dist-dir) -stack exec ghci -- \ - -j +RTS -N -A64M -n2m -RTS \ - ${DISTDIR}/build/cbits/atomic.o \ - ${DISTDIR}/build/cbits/flags.o \ - $@ - From 27d0f803a036221765acd6c28e92b9574263f604 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 30 Jun 2020 14:16:42 +0200 Subject: [PATCH 266/316] propogate sub-pattern matches in Pattern instances also update TH generator to define patterns for simple product types in terms of Pattern --- src/Data/Array/Accelerate.hs | 5 +- src/Data/Array/Accelerate/Classes/Eq.hs | 2 +- src/Data/Array/Accelerate/Classes/Ord.hs | 2 +- src/Data/Array/Accelerate/Data/Either.hs | 2 +- src/Data/Array/Accelerate/Data/Maybe.hs | 2 +- src/Data/Array/Accelerate/Pattern.hs | 393 +++++++++++++++-------- 6 files changed, 265 insertions(+), 141 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 145fe2166..0e130820f 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -351,7 +351,7 @@ module Data.Array.Accelerate ( pattern Vec8, pattern V8, pattern Vec16, pattern V16, - pattern True_, pattern False_, + mkPattern, mkPatterns, -- ** Scalar operations -- *** Introduction @@ -412,7 +412,8 @@ module Data.Array.Accelerate ( Int, Int8, Int16, Int32, Int64, Word, Word8, Word16, Word32, Word64, Half(..), Float, Double, - Bool(..), Char, + Bool(..), pattern True_, pattern False_, + Char, CFloat, CDouble, CShort, CUShort, CInt, CUInt, CLong, CULong, CLLong, CULLong, diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 6e83a846b..3c0658f79 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -43,7 +43,7 @@ import Language.Haskell.TH.Extra import qualified Prelude as P -mkPatterns ''Bool +mkPattern ''Bool infix 4 == infix 4 /= diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 59ed43157..586bd9f1c 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -48,7 +48,7 @@ import Text.Printf import qualified Prelude as P -mkPatterns ''Ordering +mkPattern ''Ordering infix 4 < infix 4 > diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index d3d4e3172..e884aa7d6 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -57,7 +57,7 @@ import Data.Maybe import Prelude ( (.), ($), const, otherwise ) -mkPatterns ''Either +mkPattern ''Either -- | Lift a value into the 'Left' constructor diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index 49c07ccc0..410ff1925 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -56,7 +56,7 @@ import Data.Maybe ( Maybe(..) import Prelude ( ($), const, otherwise ) -mkPatterns ''Maybe +mkPattern ''Maybe -- | Returns 'True' if the argument is 'Nothing' diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 22e10149b..24660390a 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -36,6 +37,7 @@ module Data.Array.Accelerate.Pattern ( pattern V2, pattern V3, pattern V4, pattern V8, pattern V16, + mkPattern, mkPatterns, ) where @@ -103,8 +105,11 @@ instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where newtype VecPattern a = VecPattern a -mkPatterns :: Name -> DecsQ -mkPatterns nm = do +mkPatterns :: [Name] -> DecsQ +mkPatterns nms = concat <$> mapM mkPattern nms + +mkPattern :: Name -> DecsQ +mkPattern nm = do info <- reify nm case info of TyConI dec -> mkDec dec @@ -115,188 +120,309 @@ mkDec dec = case dec of DataD _ nm tv _ cs _ -> mkDataD nm tv cs NewtypeD _ nm tv _ c _ -> mkNewtypeD nm tv c - _ -> fail "mkPatterns: expected the name of a newtype or datatype" + _ -> fail "mkPatterns: expected the name of a newtype or datatype" mkNewtypeD :: Name -> [TyVarBndr] -> Con -> DecsQ mkNewtypeD tn tvs c = mkDataD tn tvs [c] mkDataD :: Name -> [TyVarBndr] -> [Con] -> DecsQ mkDataD tn tvs cs = do - (pats, decs) <- unzip <$> go [] fts cs cts + (pats, decs) <- unzip <$> go cs comp <- pragCompleteD pats Nothing return $ comp : concat decs where + go [] = fail "mkPatterns: empty data declarations not supported" + go [c] = return <$> mkConP tn tvs c + go _ = go' [] (map fieldTys cs) ctags cs + + go' prev (this:next) (tag:tags) (con:cons) = do + r <- mkConS tn tvs prev next tag con + rs <- go' (this:prev) next tags cons + return (r : rs) + go' _ [] [] [] = return [] + go' _ _ _ _ = fail "mkPatterns: unexpected error" + fieldTys (NormalC _ fs) = map snd fs fieldTys (RecC _ fs) = map (\(_,_,t) -> t) fs fieldTys (InfixC a _ b) = [snd a, snd b] fieldTys _ = error "mkPatterns: only constructors for \"vanilla\" syntax are supported" - st = length cs > 1 - fts = map fieldTys cs - -- TODO: The GTags class demonstrates a way to generate the tags for -- a given constructor, rather than backwards-engineering the structure -- as we've done here. We should use that instead! -- - cts = + ctags = let n = length cs m = n `quot` 2 l = take m (iterate (True:) [False]) r = take (n-m) (iterate (True:) [True]) + -- + bitsToTag = foldl' f 0 + where + f i False = i `shiftL` 1 + f i True = setBit (i `shiftL` 1) 0 in map bitsToTag (l ++ r) - bitsToTag = foldl' f 0 - where - f n False = n `shiftL` 1 - f n True = setBit (n `shiftL` 1) 0 - - go prev (this:next) (con:cons) (tag:tags) = do - r <- mkCon st tn tvs prev next tag con - rs <- go (this:prev) next cons tags - return (r : rs) - go _ [] [] [] = return [] - go _ _ _ _ = fail "mkPatterns: unexpected error" -mkCon :: Bool -> Name -> [TyVarBndr] -> [[Type]] -> [[Type]] -> Word8 -> Con -> Q (Name, [Dec]) -mkCon st tn tvs prev next tag = \case - NormalC nm fs -> mkNormalC st tn (map tyVarBndrName tvs) tag nm prev (map snd fs) next +mkConP :: Name -> [TyVarBndr] -> Con -> Q (Name, [Dec]) +mkConP tn' tvs' = \case + NormalC cn fs -> mkNormalC tn' cn (map tyVarBndrName tvs') (map snd fs) + RecC cn fs -> mkRecC tn' cn (map tyVarBndrName tvs') (map (rename . fst3) fs) (map thd3 fs) + InfixC a cn b -> mkInfixC tn' cn (map tyVarBndrName tvs') [snd a, snd b] + _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" + where + mkNormalC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec]) + mkNormalC tn cn tvs fs = do + xs <- replicateM (length fs) (newName "_x") + r <- sequence [ patSynSigD pat sig + , patSynD pat + (prefixPatSyn xs) + implBidir + [p| Pattern $(tupP (map varP xs)) |] + ] + return (pat, r) + where + pat = rename cn + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkRecC :: Name -> Name -> [Name] -> [Name] -> [Type] -> Q (Name, [Dec]) + mkRecC tn cn tvs xs fs = do + r <- sequence [ patSynSigD pat sig + , patSynD pat + (recordPatSyn xs) + implBidir + [p| Pattern $(tupP (map varP xs)) |] + ] + return (pat, r) + where + pat = rename cn + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkInfixC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec]) + mkInfixC tn cn tvs fs = do + _a <- newName "_a" + _b <- newName "_b" + r <- sequence [ patSynSigD pat sig + , patSynD pat + (infixPatSyn _a _b) + implBidir + [p| Pattern $(tupP [varP _a, varP _b]) |] + ] + return (pat, r) + where + pat = mkName (':' : nameBase cn) + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + +mkConS :: Name -> [TyVarBndr] -> [[Type]] -> [[Type]] -> Word8 -> Con -> Q (Name, [Dec]) +mkConS tn' tvs' prev' next' tag' = \case + NormalC nm fs -> mkNormalC tn' (map tyVarBndrName tvs') tag' nm prev' (map snd fs) next' -- RecC nm fs -> undefined -- InfixC a nm b -> undefined _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" - -mkNormalC :: Bool -> Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) -mkNormalC st tn tvs tag cn ps fs ns = do - (fun_mk, dec_mk) <- mkNormalC_mk st tn tvs tag cn ps fs ns - (fun_match, dec_match) <- mkNormalC_match st tn tvs tag cn ps fs ns - (pat, dec_pat) <- mkNormalC_pattern tn tvs cn fs fun_mk fun_match - return $ (pat, concat [dec_pat, dec_mk, dec_match]) - -mkNormalC_pattern :: Name -> [Name] -> Name -> [Type] -> Name -> Name -> Q (Name, [Dec]) -mkNormalC_pattern tn tvs cn fs mk match = do - xs <- replicateM (length fs) (newName "_x") - r <- sequence [ patSynSigD pat sig - , patSynD pat - (prefixPatSyn xs) - (explBidir [clause [] (normalB (varE mk)) []]) - (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) - ] - return (pat, r) where - pat = mkName (nameBase cn ++ "_") - sig = forallT - (map plainTV tvs) - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) - -mkNormalC_mk :: Bool -> Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) -mkNormalC_mk sum_type tn tvs tag cn fs0 fs fs1 = do - fun <- newName ("_mk" ++ nameBase cn) - xs <- replicateM (length fs) (newName "_x") - let - vs = foldl' (\es e -> [| SmartExp ($es `Pair` $e) |]) [| SmartExp Nil |] - $ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat (reverse fs0)) - ++ map varE xs - ++ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat fs1) - - body = clause (map (\x -> [p| (Exp $(varP x)) |]) xs) (normalB tagged) [] + mkNormalC :: Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkNormalC tn tvs tag cn ps fs ns = do + (fun_mk, dec_mk) <- mkNormalC_mk tn tvs tag cn ps fs ns + (fun_match, dec_match) <- mkNormalC_match tn tvs tag cn ps fs ns + (pat, dec_pat) <- mkNormalC_pattern tn tvs cn fs fun_mk fun_match + return $ (pat, concat [dec_pat, dec_mk, dec_match]) + + mkNormalC_pattern :: Name -> [Name] -> Name -> [Type] -> Name -> Name -> Q (Name, [Dec]) + mkNormalC_pattern tn tvs cn fs mk match = do + xs <- replicateM (length fs) (newName "_x") + r <- sequence [ patSynSigD pat sig + , patSynD pat + (prefixPatSyn xs) + (explBidir [clause [] (normalB (varE mk)) []]) + (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) + ] + return (pat, r) where - tagged - | sum_type = [| Exp $ SmartExp $ Pair (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) $(litE (IntegerL (toInteger tag))))) $vs |] - | otherwise = [| Exp $vs |] - - r <- sequence [ sigD fun sig - , funD fun [body] - ] - return (fun, r) - where - sig = forallT - (map plainTV tvs) - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) - - -mkNormalC_match :: Bool -> Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) -mkNormalC_match sum_type tn tvs tag cn fs0 fs fs1 = do - fun <- newName ("_match" ++ nameBase cn) - e <- newName "_e" - x <- newName "_x" - (ps,es) <- extract vs (if sum_type then [| Prj PairIdxRight $(varE x) |] else varE x) [] [] - let - lhs = [p| (Exp $(varP e)) |] - body = normalB $ caseE (varE e) - [ TH.match (conP 'SmartExp [(conP 'Match [matchP ps, varP x])]) (normalB [| Just $(tupE es) |]) [] - , TH.match (conP 'SmartExp [(recP 'Match [])]) (normalB [| Nothing |]) [] - , TH.match wildP (normalB [| error "Pattern synonym used outside 'match' context" |]) [] - ] - - r <- sequence [ sigD fun sig - , funD fun [clause [lhs] body []] - ] - return (fun, r) - where - sig = - forallT [] - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) - -> Maybe $(tupT (map (\t -> [t| Exp $(return t) |]) fs)) |] - - matchP us - | sum_type = [p| TagRtag $(litP (IntegerL (toInteger tag))) $pat |] - | otherwise = pat + pat = rename cn + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkNormalC_mk :: Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkNormalC_mk tn tvs tag cn fs0 fs fs1 = do + fun <- newName ("_mk" ++ nameBase cn) + xs <- replicateM (length fs) (newName "_x") + let + vs = foldl' (\es e -> [| SmartExp ($es `Pair` $e) |]) [| SmartExp Nil |] + $ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat (reverse fs0)) + ++ map varE xs + ++ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat fs1) + + tagged = [| Exp $ SmartExp $ Pair (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) $(litE (IntegerL (toInteger tag))))) $vs |] + body = clause (map (\x -> [p| (Exp $(varP x)) |]) xs) (normalB tagged) [] + + r <- sequence [ sigD fun sig + , funD fun [body] + ] + return (fun, r) + where + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + + mkNormalC_match :: Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkNormalC_match tn tvs tag cn fs0 fs fs1 = do + fun <- newName ("_match" ++ nameBase cn) + e <- newName "_e" + x <- newName "_x" + (ps,es) <- extract vs [| Prj PairIdxRight $(varE x) |] [] [] + let + lhs = [p| (Exp $(varP e)) |] + body = normalB $ caseE (varE e) + [ TH.match (conP 'SmartExp [(conP 'Match [matchP ps, varP x])]) (normalB [| Just $(tupE es) |]) [] + , TH.match (conP 'SmartExp [(recP 'Match [])]) (normalB [| Nothing |]) [] + , TH.match wildP (normalB [| error "Pattern synonym used outside 'match' context" |]) [] + ] + + r <- sequence [ sigD fun sig + , funD fun [clause [lhs] body []] + ] + return (fun, r) where - pat = [p| $(foldl (\ps p -> [p| TagRpair $ps $p |]) [p| TagRunit |] us) |] + sig = + forallT [] + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) + -> Maybe $(tupT (map (\t -> [t| Exp $(return t) |]) fs)) |] - extract [] _ ps es = return (ps, es) - extract (u:us) x ps es = do - _u <- newName "_u" - let x' = [| Prj PairIdxLeft (SmartExp $x) |] - if not u - then extract us x' (wildP:ps) es - else extract us x' (varP _u:ps) ([| Exp (SmartExp (Match $(varE _u) (SmartExp (Prj PairIdxRight (SmartExp $x))))) |] : es) + matchP us = [p| TagRtag $(litP (IntegerL (toInteger tag))) $pat |] + where + pat = [p| $(foldl (\ps p -> [p| TagRpair $ps $p |]) [p| TagRunit |] us) |] - vs = reverse - $ [ False | _ <- concat fs0 ] ++ [ True | _ <- fs ] ++ [ False | _ <- concat fs1 ] + extract [] _ ps es = return (ps, es) + extract (u:us) x ps es = do + _u <- newName "_u" + let x' = [| Prj PairIdxLeft (SmartExp $x) |] + if not u + then extract us x' (wildP:ps) es + else extract us x' (varP _u:ps) ([| Exp (SmartExp (Match $(varE _u) (SmartExp (Prj PairIdxRight (SmartExp $x))))) |] : es) + vs = reverse + $ [ False | _ <- concat fs0 ] ++ [ True | _ <- fs ] ++ [ False | _ <- concat fs1 ] --- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of the --- (unremarkable) boilerplate for us, but since the implementation is a little --- tricky it is debatable whether or not this is a good idea... +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c + +rename :: Name -> Name +rename nm = + let + split acc [] = (reverse acc, '\0') -- shouldn't happen + split acc [l] = (reverse acc, l) + split acc (l:ls) = split (l:acc) ls + -- + nm' = nameBase nm + (base, suffix) = split [] nm' + in + case suffix of + '_' -> mkName base + _ -> mkName (nm' ++ "_") + + +-- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of +-- the (unremarkable) boilerplate for us. -- runQ $ do let + -- Generate instance declarations for IsPattern of the form: + -- instance (Arrays x, ArraysR x ~ (((), ArraysR a), ArraysR b), Arrays a, Arrays b,) => IsPattern Acc x (Acc a, Acc b) + mkAccPattern :: Int -> Q [Dec] + mkAccPattern n = do + a <- newName "a" + let + -- Type variables for the elements + xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + -- Last argument to `IsPattern`, eg (Acc a, Acc b) in the example + b = tupT (map (\t -> [t| Acc $(varT t)|]) xs) + -- Representation as snoc-list of pairs, eg (((), ArraysR a), ArraysR b) + snoc = foldl (\sn t -> [t| ($sn, ArraysR $(varT t)) |]) [t| () |] xs + -- Constraints for the type class, consisting of Arrays constraints on all type variables, + -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`. + context = tupT + $ [t| Arrays $(varT a) |] + : [t| ArraysR $(varT a) ~ $snoc |] + : map (\t -> [t| Arrays $(varT t)|]) xs + -- + get x 0 = [| Acc (SmartAcc (Aprj PairIdxRight $x)) |] + get x i = get [| SmartAcc (Aprj PairIdxLeft $x) |] (i-1) + -- + _x <- newName "_x" + [d| instance $context => IsPattern Acc $(varT a) $b where + construct $(tupP (map (\x -> [p| Acc $(varP x)|]) xs)) = + Acc $(foldl (\vs v -> [| SmartAcc ($vs `Apair` $(varE v)) |]) [| SmartAcc Anil |] xs) + destruct (Acc $(varP _x)) = + $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0])) + |] + -- Generate instance declarations for IsPattern of the form: -- instance (Elt x, EltR x ~ (((), EltR a), EltR b), Elt a, Elt b,) => IsPattern Exp x (Exp a, Exp b) - mkIsPattern :: Name -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> Int -> Q [Dec] - mkIsPattern con cst repr smart prj nil pair n = do + mkExpPattern :: Int -> Q [Dec] + mkExpPattern n = do a <- newName "a" let -- Type variables for the elements xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] + -- Variables for sub-pattern matches + ms = [ mkName ('m' : show i) | i <- [0 .. n-1] ] + tags = foldl (\ts t -> [p| $ts `TagRpair` $(varP t) |]) [p| TagRunit |] ms -- Last argument to `IsPattern`, eg (Exp, a, Exp b) in the example - b = tupT (map (\t -> [t| $(conT con) $(varT t)|]) xs) + b = tupT (map (\t -> [t| Exp $(varT t)|]) xs) -- Representation as snoc-list of pairs, eg (((), EltR a), EltR b) - snoc = foldl (\sn t -> [t| ($sn, $(appT repr $ varT t)) |]) [t| () |] xs + snoc = foldl (\sn t -> [t| ($sn, EltR $(varT t)) |]) [t| () |] xs -- Constraints for the type class, consisting of Elt constraints on all type variables, -- and an equality constraint on the representation type of `a` and the snoc representation `snoc`. context = tupT - $ appT cst [t| $(varT a) |] - : [t| $repr $(varT a) ~ $snoc |] - : map (\t -> [t| $cst $(varT t)|]) xs + $ [t| Elt $(varT a) |] + : [t| EltR $(varT a) ~ $snoc |] + : map (\t -> [t| Elt $(varT t)|]) xs -- - get x 0 = [| $(conE con) ($smart ($prj PairIdxRight $x)) |] - get x i = get [| $smart ($prj PairIdxLeft $x) |] (i-1) + get x 0 = [| SmartExp (Prj PairIdxRight $x) |] + get x i = get [| SmartExp (Prj PairIdxLeft $x) |] (i-1) -- _x <- newName "_x" - [d| instance $context => IsPattern $(conT con) $(varT a) $b where - construct $(tupP (map (conP con . return . varP) xs)) = - $(conE con) $(foldl (\vs v -> appE smart (appE (appE pair vs) (varE v))) (appE smart nil) xs) - destruct $(conP con [varP _x]) = - $(tupE (map (get (varE _x)) [(n-1), (n-2) .. 0])) + _y <- newName "_y" + [d| instance $context => IsPattern Exp $(varT a) $b where + construct $(tupP (map (\x -> [p| Exp $(varP x)|]) xs)) = + let _unmatch :: SmartExp a -> SmartExp a + _unmatch (SmartExp (Match _ $(varP _y))) = $(varE _y) + _unmatch x = x + in + Exp $(foldl (\vs v -> [| SmartExp ($vs `Pair` _unmatch $(varE v)) |]) [| SmartExp Nil |] xs) + destruct (Exp $(varP _x)) = + case $(varE _x) of + SmartExp (Match $tags $(varP _y)) + -> $(tupE [[| Exp (SmartExp (Match $(varE m) $(get (varE _x) i))) |] | m <- ms | i <- [(n-1), (n-2) .. 0]]) + _ -> $(tupE [[| Exp $(get (varE _x) i) |] | i <- [(n-1), (n-2) .. 0]]) |] mkVecPattern :: Int -> Q [Dec] @@ -313,9 +439,6 @@ runQ $ do Exp x' -> Exp (SmartExp (VecPack $v x')) destruct (Exp x) = VecPattern (destruct (Exp (SmartExp (VecUnpack $v x)) :: Exp $t)) |] - - mkExpPattern = mkIsPattern (mkName "Exp") [t| Elt |] [t| EltR |] [| SmartExp |] [| Prj |] [| Nil |] [| Pair |] - mkAccPattern = mkIsPattern (mkName "Acc") [t| Arrays |] [t| ArraysR |] [| SmartAcc |] [| Aprj |] [| Anil |] [| Apair |] -- es <- mapM mkExpPattern [0..16] as <- mapM mkAccPattern [0..16] From 917291289b203912f6c911df785f515c453a325b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 1 Jul 2020 12:16:20 +0200 Subject: [PATCH 267/316] update TH generator for record and infix data types --- src/Data/Array/Accelerate/Classes/Eq.hs | 19 +- src/Data/Array/Accelerate/Classes/Ord.hs | 1 + src/Data/Array/Accelerate/Data/Either.hs | 1 + src/Data/Array/Accelerate/Data/Maybe.hs | 1 + src/Data/Array/Accelerate/Pattern.hs | 231 +++++++++++++++++++---- src/Data/Array/Accelerate/Prelude.hs | 9 + 6 files changed, 214 insertions(+), 48 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 3c0658f79..f4b58aeea 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -1,11 +1,14 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Eq diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 586bd9f1c..55b10bf42 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index e884aa7d6..4240f3390 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index 410ff1925..af8245688 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 24660390a..03789442c 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -55,11 +55,16 @@ import Data.Primitive.Vec import Control.Monad import Data.Bits -import Data.List ( foldl' ) +import Data.Char +import Data.List ( (\\), foldl' ) import Language.Haskell.TH hiding ( Exp, Match, match, tupP, tupE ) import Language.Haskell.TH.Extra +import Numeric +import Text.Printf import qualified Language.Haskell.TH as TH +import GHC.Stack + -- | A pattern synonym for working with (product) data types. You can declare -- your own pattern synonyms based off of this. @@ -105,9 +110,30 @@ instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where newtype VecPattern a = VecPattern a +-- | As 'mkPattern, but for a list of types +-- mkPatterns :: [Name] -> DecsQ mkPatterns nms = concat <$> mapM mkPattern nms +-- | Generate pattern synonyms for the given simple (Haskell'98) sum or +-- product data type. +-- +-- Constructor and record selectors are renamed to add a trailing +-- underscore if it does not exist, or to remove it if it does. For infix +-- constructors, the name is prepended with a colon ':'. For example: +-- +-- > data Point = Point { xcoord_ :: Float, ycoord_ :: Float } +-- > deriving (Generic, Elt) +-- +-- Will create the pattern synonym: +-- +-- > Point_ :: Exp Float -> Exp Float -> Exp Point +-- +-- together with the selector functions +-- +-- > xcoord :: Exp Point -> Exp Float +-- > ycoord :: Exp Point -> Exp Float +-- mkPattern :: Name -> DecsQ mkPattern nm = do info <- reify nm @@ -131,10 +157,15 @@ mkDataD tn tvs cs = do comp <- pragCompleteD pats Nothing return $ comp : concat decs where + -- For single-constructor types we create the pattern synonym for the + -- type directly in terms of Pattern go [] = fail "mkPatterns: empty data declarations not supported" go [c] = return <$> mkConP tn tvs c go _ = go' [] (map fieldTys cs) ctags cs + -- For sum-types, when creating the pattern for an individual + -- constructor we need to know about the types of the fields all other + -- constructors as well go' prev (this:next) (tag:tags) (con:cons) = do r <- mkConS tn tvs prev next tag con rs <- go' (this:prev) next tags cons @@ -145,7 +176,7 @@ mkDataD tn tvs cs = do fieldTys (NormalC _ fs) = map snd fs fieldTys (RecC _ fs) = map (\(_,_,t) -> t) fs fieldTys (InfixC a _ b) = [snd a, snd b] - fieldTys _ = error "mkPatterns: only constructors for \"vanilla\" syntax are supported" + fieldTys _ = fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" -- TODO: The GTags class demonstrates a way to generate the tags for -- a given constructor, rather than backwards-engineering the structure @@ -166,11 +197,13 @@ mkDataD tn tvs cs = do mkConP :: Name -> [TyVarBndr] -> Con -> Q (Name, [Dec]) -mkConP tn' tvs' = \case - NormalC cn fs -> mkNormalC tn' cn (map tyVarBndrName tvs') (map snd fs) - RecC cn fs -> mkRecC tn' cn (map tyVarBndrName tvs') (map (rename . fst3) fs) (map thd3 fs) - InfixC a cn b -> mkInfixC tn' cn (map tyVarBndrName tvs') [snd a, snd b] - _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" +mkConP tn' tvs' con' = do + checkExts [ PatternSynonyms ] + case con' of + NormalC cn fs -> mkNormalC tn' cn (map tyVarBndrName tvs') (map snd fs) + RecC cn fs -> mkRecC tn' cn (map tyVarBndrName tvs') (map (rename . fst3) fs) (map thd3 fs) + InfixC a cn b -> mkInfixC tn' cn (map tyVarBndrName tvs') [snd a, snd b] + _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" where mkNormalC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec]) mkNormalC tn cn tvs fs = do @@ -230,26 +263,42 @@ mkConP tn' tvs' = \case (map (\t -> [t| Exp $(return t) |]) fs)) mkConS :: Name -> [TyVarBndr] -> [[Type]] -> [[Type]] -> Word8 -> Con -> Q (Name, [Dec]) -mkConS tn' tvs' prev' next' tag' = \case - NormalC nm fs -> mkNormalC tn' (map tyVarBndrName tvs') tag' nm prev' (map snd fs) next' - -- RecC nm fs -> undefined - -- InfixC a nm b -> undefined - _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" +mkConS tn' tvs' prev' next' tag' con' = do + checkExts [GADTs, PatternSynonyms, ScopedTypeVariables, TypeApplications, ViewPatterns] + case con' of + NormalC cn fs -> mkNormalC tn' cn tag' (map tyVarBndrName tvs') prev' (map snd fs) next' + RecC cn fs -> mkRecC tn' cn tag' (map tyVarBndrName tvs') (map (rename . fst3) fs) prev' (map thd3 fs) next' + InfixC a cn b -> mkInfixC tn' cn tag' (map tyVarBndrName tvs') prev' [snd a, snd b] next' + _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" where - mkNormalC :: Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) - mkNormalC tn tvs tag cn ps fs ns = do - (fun_mk, dec_mk) <- mkNormalC_mk tn tvs tag cn ps fs ns - (fun_match, dec_match) <- mkNormalC_match tn tvs tag cn ps fs ns - (pat, dec_pat) <- mkNormalC_pattern tn tvs cn fs fun_mk fun_match - return $ (pat, concat [dec_pat, dec_mk, dec_match]) - - mkNormalC_pattern :: Name -> [Name] -> Name -> [Type] -> Name -> Name -> Q (Name, [Dec]) - mkNormalC_pattern tn tvs cn fs mk match = do + mkNormalC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkNormalC tn cn tag tvs ps fs ns = do + (fun_build, dec_build) <- mkBuild tn (nameBase cn) tvs tag ps fs ns + (fun_match, dec_match) <- mkMatch tn (nameBase cn) tvs tag ps fs ns + (pat, dec_pat) <- mkNormalC_pattern tn cn tvs fs fun_build fun_match + return $ (pat, concat [dec_pat, dec_build, dec_match]) + + mkRecC :: Name -> Name -> Word8 -> [Name] -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkRecC tn cn tag tvs xs ps fs ns = do + (fun_build, dec_build) <- mkBuild tn (nameBase cn) tvs tag ps fs ns + (fun_match, dec_match) <- mkMatch tn (nameBase cn) tvs tag ps fs ns + (pat, dec_pat) <- mkRecC_pattern tn cn tvs xs fs fun_build fun_match + return $ (pat, concat [dec_pat, dec_build, dec_match]) + + mkInfixC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkInfixC tn cn tag tvs ps fs ns = do + (fun_build, dec_build) <- mkBuild tn (zencode (nameBase cn)) tvs tag ps fs ns + (fun_match, dec_match) <- mkMatch tn (zencode (nameBase cn)) tvs tag ps fs ns + (pat, dec_pat) <- mkInfixC_pattern tn cn tvs fs fun_build fun_match + return $ (pat, concat [dec_pat, dec_build, dec_match]) + + mkNormalC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) + mkNormalC_pattern tn cn tvs fs build match = do xs <- replicateM (length fs) (newName "_x") r <- sequence [ patSynSigD pat sig , patSynD pat (prefixPatSyn xs) - (explBidir [clause [] (normalB (varE mk)) []]) + (explBidir [clause [] (normalB (varE build)) []]) (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) ] return (pat, r) @@ -257,14 +306,52 @@ mkConS tn' tvs' prev' next' tag' = \case pat = rename cn sig = forallT (map plainTV tvs) - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) (foldr (\t ts -> [t| $t -> $ts |]) [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] (map (\t -> [t| Exp $(return t) |]) fs)) - mkNormalC_mk :: Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) - mkNormalC_mk tn tvs tag cn fs0 fs fs1 = do - fun <- newName ("_mk" ++ nameBase cn) + mkRecC_pattern :: Name -> Name -> [Name] -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) + mkRecC_pattern tn cn tvs xs fs build match = do + r <- sequence [ patSynSigD pat sig + , patSynD pat + (recordPatSyn xs) + (explBidir [clause [] (normalB (varE build)) []]) + (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) + ] + return (pat, r) + where + pat = rename cn + sig = forallT + (map plainTV tvs) + (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkInfixC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) + mkInfixC_pattern tn cn tvs fs build match = do + _a <- newName "_a" + _b <- newName "_b" + r <- sequence [ patSynSigD pat sig + , patSynD pat + (infixPatSyn _a _b) + (explBidir [clause [] (normalB (varE build)) []]) + (parensP $ viewP (varE match) [p| Just $(tupP [varP _a, varP _b]) |]) + ] + return (pat, r) + where + pat = mkName (':' : nameBase cn) + sig = forallT + (map plainTV tvs) + (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkBuild :: Name -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkBuild tn cn tvs tag fs0 fs fs1 = do + fun <- newName ("_build" ++ cn) xs <- replicateM (length fs) (newName "_x") let vs = foldl' (\es e -> [| SmartExp ($es `Pair` $e) |]) [| SmartExp Nil |] @@ -280,17 +367,17 @@ mkConS tn' tvs' prev' next' tag' = \case ] return (fun, r) where - sig = forallT - (map plainTV tvs) - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) - mkNormalC_match :: Name -> [Name] -> Word8 -> Name -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) - mkNormalC_match tn tvs tag cn fs0 fs fs1 = do - fun <- newName ("_match" ++ nameBase cn) + mkMatch :: Name -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkMatch tn cn tvs tag fs0 fs fs1 = do + fun <- newName ("_match" ++ cn) e <- newName "_e" x <- newName "_x" (ps,es) <- extract vs [| Prj PairIdxRight $(varE x) |] [] [] @@ -307,11 +394,10 @@ mkConS tn' tvs' prev' next' tag' = \case ] return (fun, r) where - sig = - forallT [] - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) - -> Maybe $(tupT (map (\t -> [t| Exp $(return t) |]) fs)) |] + sig = forallT + (map plainTV tvs) + (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) -> Maybe $(tupT (map (\t -> [t| Exp $(return t) |]) fs)) |] matchP us = [p| TagRtag $(litP (IntegerL (toInteger tag))) $pat |] where @@ -348,6 +434,71 @@ rename nm = '_' -> mkName base _ -> mkName (nm' ++ "_") +checkExts :: [Extension] -> Q () +checkExts req = do + enabled <- extsEnabled + let missing = req \\ enabled + unless (null missing) . fail . unlines + $ printf "You must enable the following language extensions to generate pattern synonyms:" + : map (printf " {-# LANGUAGE %s #-}" . show) missing + +-- A simplified version of that stolen from GHC/Utils/Encoding.hs +-- +type EncodedString = String + +zencode :: String -> EncodedString +zencode [] = [] +zencode (h:rest) = encode_digit h ++ go rest + where + go [] = [] + go (c:cs) = encode_ch c ++ go cs + +unencoded_char :: Char -> Bool +unencoded_char 'z' = False +unencoded_char 'Z' = False +unencoded_char c = isAlphaNum c + +encode_digit :: Char -> EncodedString +encode_digit c | isDigit c = encode_as_unicode_char c + | otherwise = encode_ch c + +encode_ch :: Char -> EncodedString +encode_ch c | unencoded_char c = [c] -- Common case first +encode_ch '(' = "ZL" +encode_ch ')' = "ZR" +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = encode_as_unicode_char c + +encode_as_unicode_char :: Char -> EncodedString +encode_as_unicode_char c + = 'z' + : if isDigit (head hex_str) then hex_str + else '0':hex_str + where + hex_str = showHex (ord c) "U" + -- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of -- the (unremarkable) boilerplate for us. diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 1f9405eda..0d3d2c5cc 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -2229,6 +2229,15 @@ instance IfThenElse Acc where -- -- And utilising the @LambdaCase@ and @BlockArguments@ syntactic extensions. -- +-- The Template Haskell splice 'Data.Array.Accelerate.mkPattern' (or +-- 'Data.Array.Accelerate.mkPatterns') can be used to generate the pattern +-- synonyms for a given Haskell'98 sum or product data type. For example: +-- +-- > data Option a = None | Some a +-- > deriving (Generic, Elt) +-- > +-- > mkPattern ''Option +-- match :: Matching f => f -> f match f = mkFun (mkMatch f) id From 7c211cff086a4a350fe1728f69ad8c8ff4d1329f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 1 Jul 2020 17:07:44 +0200 Subject: [PATCH 268/316] =?UTF-8?q?use=20=E2=80=98Maybe=E2=80=99=20in=20th?= =?UTF-8?q?e=20permutation=20function=20rather=20than=20the=20magic=20valu?= =?UTF-8?q?e=20=E2=80=98ignore=E2=80=99?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes AccelerateHS/accelerate#87 --- accelerate.cabal | 5 + src/Data/Array/Accelerate.hs | 6 +- src/Data/Array/Accelerate/AST.hs | 6 +- src/Data/Array/Accelerate/Classes/Eq.hs | 3 +- src/Data/Array/Accelerate/Classes/Ord.hs | 7 +- src/Data/Array/Accelerate/Data/Either.hs | 72 +-- src/Data/Array/Accelerate/Data/Maybe.hs | 57 +-- src/Data/Array/Accelerate/Interpreter.hs | 26 +- src/Data/Array/Accelerate/Language.hs | 19 +- src/Data/Array/Accelerate/Pattern.hs | 405 +---------------- src/Data/Array/Accelerate/Pattern/Bool.hs | 26 ++ src/Data/Array/Accelerate/Pattern/Either.hs | 26 ++ src/Data/Array/Accelerate/Pattern/Maybe.hs | 26 ++ src/Data/Array/Accelerate/Pattern/Ordering.hs | 26 ++ src/Data/Array/Accelerate/Pattern/TH.hs | 428 ++++++++++++++++++ src/Data/Array/Accelerate/Prelude.hs | 60 ++- .../Array/Accelerate/Representation/Shape.hs | 6 - src/Data/Array/Accelerate/Smart.hs | 5 +- src/Data/Array/Accelerate/Sugar/Elt.hs | 3 + src/Data/Array/Accelerate/Sugar/Shape.hs | 5 - .../Accelerate/Test/NoFib/Issues/Issue137.hs | 3 +- .../Accelerate/Test/NoFib/Issues/Issue185.hs | 3 +- .../Accelerate/Test/NoFib/Issues/Issue93.hs | 3 +- .../Accelerate/Test/NoFib/Prelude/Permute.hs | 24 +- .../Test/NoFib/Spectral/RadixSort.hs | 3 +- 25 files changed, 642 insertions(+), 611 deletions(-) create mode 100644 src/Data/Array/Accelerate/Pattern/Bool.hs create mode 100644 src/Data/Array/Accelerate/Pattern/Either.hs create mode 100644 src/Data/Array/Accelerate/Pattern/Maybe.hs create mode 100644 src/Data/Array/Accelerate/Pattern/Ordering.hs create mode 100644 src/Data/Array/Accelerate/Pattern/TH.hs diff --git a/accelerate.cabal b/accelerate.cabal index 54965b4e5..11bd557c6 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -388,6 +388,11 @@ Library Data.Array.Accelerate.Lift Data.Array.Accelerate.Orphans Data.Array.Accelerate.Pattern + Data.Array.Accelerate.Pattern.Bool + Data.Array.Accelerate.Pattern.Either + Data.Array.Accelerate.Pattern.Maybe + Data.Array.Accelerate.Pattern.Ordering + Data.Array.Accelerate.Pattern.TH Data.Array.Accelerate.Prelude Data.Array.Accelerate.Pretty.Graphviz Data.Array.Accelerate.Pretty.Graphviz.Monad diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 0e130820f..e3d9d22d0 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -240,7 +240,6 @@ module Data.Array.Accelerate ( -- *** Permutations -- **** Forward permutation (scatter) permute, - ignore, scatter, -- **** Backward permutation (gather) @@ -252,7 +251,7 @@ module Data.Array.Accelerate ( reverseOn, transposeOn, -- *** Filtering - filter, + filter, compact, -- ** Folding fold, fold1, foldAll, fold1All, @@ -424,12 +423,13 @@ module Data.Array.Accelerate ( import Data.Array.Accelerate.Classes import Data.Array.Accelerate.Language import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Pattern.TH import Data.Array.Accelerate.Prelude import Data.Array.Accelerate.Pretty () -- show instances import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Array ( Array, Arrays, Scalar, Vector, Matrix, Segments, fromFunction, fromFunctionM, toList, fromList ) import Data.Array.Accelerate.Sugar.Elt -import Data.Array.Accelerate.Sugar.Shape hiding ( size, ignore, toIndex, fromIndex, intersect ) +import Data.Array.Accelerate.Sugar.Shape hiding ( size, toIndex, fromIndex, intersect ) import Data.Array.Accelerate.Sugar.Vec import Data.Array.Accelerate.Type import Data.Primitive.Vec diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 74183b063..b535db648 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -88,6 +88,7 @@ module Data.Array.Accelerate.AST ( PrimConst(..), PrimFun(..), PrimBool, + PrimMaybe, -- ** Extracting type information HasArraysR(..), arrayR, @@ -191,7 +192,8 @@ type ArrayVar = Var ArrayR type ArrayVars aenv = Vars ArrayR aenv -- Bool is not a primitive type -type PrimBool = TAG +type PrimBool = TAG +type PrimMaybe a = (TAG, ((), a)) -- | Collective array computations parametrised over array variables @@ -406,7 +408,7 @@ data PreOpenAcc (acc :: Type -> Type -> Type) aenv a where -- Permute :: Fun aenv (e -> e -> e) -- combination function -> acc aenv (Array sh' e) -- default values - -> Fun aenv (sh -> sh') -- permutation function + -> Fun aenv (sh -> PrimMaybe sh') -- permutation function -> acc aenv (Array sh e) -- source array -> PreOpenAcc acc aenv (Array sh' e) diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index f4b58aeea..18be66fc3 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -32,6 +32,7 @@ module Data.Array.Accelerate.Classes.Eq ( import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Pattern.Bool import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Sugar.Shape @@ -46,8 +47,6 @@ import Language.Haskell.TH.Extra import qualified Prelude as P -mkPattern ''Bool - infix 4 == infix 4 /= diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index 55b10bf42..f3e46f7c1 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -30,6 +30,7 @@ module Data.Array.Accelerate.Classes.Ord ( import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Pattern.Ordering import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Elt @@ -44,13 +45,11 @@ import qualified Data.Array.Accelerate.Classes.Eq as A import Data.Char import Language.Haskell.TH hiding ( Exp ) import Language.Haskell.TH.Extra -import Prelude ( ($), (>>=), Ordering(..), Num(..), Maybe(..), String, show, error, unlines, return, concat, map, mapM, (==) ) +import Prelude ( ($), (>>=), Ordering(..), Num(..), Maybe(..), String, show, error, unlines, return, concat, map, mapM ) import Text.Printf import qualified Prelude as P -mkPattern ''Ordering - infix 4 < infix 4 > infix 4 <= @@ -115,8 +114,6 @@ instance Ord sh => Ord (sh :. Int) where Just Refl -> constant True Nothing -> indexTail x > indexTail y -instance Elt Ordering - instance Eq Ordering where x == y = mkCoerce x A.== (mkCoerce y :: Exp TAG) x /= y = mkCoerce x A./= (mkCoerce y :: Exp TAG) diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index 4240f3390..61a812107 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -32,19 +32,17 @@ module Data.Array.Accelerate.Data.Either ( ) where import Data.Array.Accelerate.AST.Idx -import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Interpreter import Data.Array.Accelerate.Language hiding ( chr ) -import Data.Array.Accelerate.Pattern -import Data.Array.Accelerate.Prelude hiding ( filter ) +import Data.Array.Accelerate.Lift +import Data.Array.Accelerate.Pattern.Either +import Data.Array.Accelerate.Prelude import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Array ( Array, Vector ) import Data.Array.Accelerate.Sugar.Elt -import Data.Array.Accelerate.Sugar.Shape ( Shape, Slice, Z(..), (:.), empty ) +import Data.Array.Accelerate.Sugar.Shape ( Shape, Slice, (:.) ) 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 @@ -54,11 +52,7 @@ import Data.Array.Accelerate.Data.Semigroup #endif import Data.Either ( Either(..) ) -import Data.Maybe -import Prelude ( (.), ($), const, otherwise ) - - -mkPattern ''Either +import Prelude ( (.), ($) ) -- | Lift a value into the 'Left' constructor @@ -89,14 +83,14 @@ isRight x = tag x == 1 -- instead. -- fromLeft :: (Elt a, Elt b) => Exp (Either a b) -> Exp a -fromLeft x = let T3 _ a _ = asTuple x in a +fromLeft (Exp e) = Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxLeft $ SmartExp $ Prj PairIdxRight e -- | 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 = let T3 _ _ b = asTuple x in b +fromRight (Exp e) = Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxRight e -- | 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@, @@ -114,7 +108,7 @@ either f g x = 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) +lefts es = compact (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 @@ -123,7 +117,7 @@ lefts es = filter' (map isLeft es) (map fromLeft es) 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) +rights es = compact (map isRight es) (map fromRight es) instance Elt a => Functor (Either a) where @@ -145,56 +139,10 @@ instance (Elt a, Elt b) => Semigroup (Exp (Either a b)) where #endif tag :: (Elt a, Elt b) => Exp (Either a b) -> Exp Word8 -tag x = let T3 t _ _ = asTuple x in t - -instance (Elt a, Elt b) => Elt (Either a b) +tag (Exp e) = Exp $ SmartExp $ Prj PairIdxLeft e 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) = Left_ (lift a) lift (Right b) = Right_ (lift b) - --- Utilities --- --------- - -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 @sh @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 - -asTuple :: (Elt a, Elt b) => Exp (Either a b) -> Exp (Word8, a, b) -asTuple (Exp e) = - T3 (Exp $ SmartExp $ Prj PairIdxLeft e) - (Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxLeft $ SmartExp $ Prj PairIdxRight e) - (Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxRight e) - diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index af8245688..e7144a728 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -32,19 +32,17 @@ module Data.Array.Accelerate.Data.Maybe ( ) where import Data.Array.Accelerate.AST.Idx -import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Interpreter import Data.Array.Accelerate.Language hiding ( chr ) -import Data.Array.Accelerate.Pattern -import Data.Array.Accelerate.Prelude hiding ( filter ) +import Data.Array.Accelerate.Lift +import Data.Array.Accelerate.Pattern.Maybe +import Data.Array.Accelerate.Prelude import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Array ( Array, Vector ) import Data.Array.Accelerate.Sugar.Elt -import Data.Array.Accelerate.Sugar.Shape ( Shape, Slice, Z(..), (:.), empty ) +import Data.Array.Accelerate.Sugar.Shape ( Shape, Slice, (:.) ) 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 @@ -54,10 +52,7 @@ import Data.Array.Accelerate.Data.Semigroup #endif import Data.Maybe ( Maybe(..) ) -import Prelude ( ($), const, otherwise ) - - -mkPattern ''Maybe +import Prelude ( ($) ) -- | Returns 'True' if the argument is 'Nothing' @@ -99,7 +94,7 @@ maybe d f x = cond (isNothing x) d (f (fromJust x)) 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) +justs xs = compact (map isJust xs) (map fromJust xs) instance Functor Maybe where @@ -134,48 +129,8 @@ instance (Semigroup (Exp a), Elt a) => Semigroup (Exp (Maybe a)) where tag :: Elt a => Exp (Maybe a) -> Exp Word8 tag (Exp x) = Exp $ SmartExp $ Prj PairIdxLeft x -instance Elt a => Elt (Maybe a) - instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Maybe a) where type Plain (Maybe a) = Maybe (Plain a) lift Nothing = Nothing_ lift (Just a) = Just_ (lift a) - --- Utilities --- --------- - -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 @sh @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 - diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index ff2ccff2c..56b9480ca 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -581,10 +581,10 @@ scanr'Op f z (Delayed (ArrayR shr@(ShapeRsnoc shr') tp) (sh, n) ain _) permuteOp - :: forall sh sh' e. - (e -> e -> e) + :: forall sh sh' e. HasCallStack + => (e -> e -> e) -> WithReprs (Array sh' e) - -> (sh -> sh') + -> (sh -> PrimMaybe sh') -> Delayed (Array sh e) -> WithReprs (Array sh' e) permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR shr tp) sh _ ain) @@ -592,8 +592,6 @@ permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR where sh' = shape def n' = size shr' sh' - - ignore' = ignore shr' -- (adata, _) = runArrayData @e $ do aout <- newArrayData tp n' @@ -608,14 +606,16 @@ permuteOp f (TupRsingle (ArrayR shr' _), def@(Array _ adef)) p (Delayed (ArrayR -- project each element onto the destination array and update update src - = let dst = p src - i = toIndex shr sh src - j = toIndex shr' sh' dst - in - unless (eq shr' dst ignore') $ do - let x = ain i - y <- readArrayData tp aout j - writeArrayData tp aout j (f x y) + = case p src of + (0,_) -> return () + (1,((),dst)) -> do + let i = toIndex shr sh src + j = toIndex shr' sh' dst + x = ain i + -- + y <- readArrayData tp aout j + writeArrayData tp aout j (f x y) + _ -> internalError "unexpected tag" init 0 iter shr sh update (>>) (return ()) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 990bcc099..6ccd4cf97 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -98,9 +98,6 @@ module Data.Array.Accelerate.Language ( -- * Conversions ord, chr, boolToInt, bitcast, - -- * Constants - ignore - ) where import Data.Array.Accelerate.AST ( PrimFun(..) ) @@ -115,7 +112,6 @@ import Data.Array.Accelerate.Sugar.Foreign import Data.Array.Accelerate.Sugar.Shape ( Shape(..), Slice(..), (:.) ) import Data.Array.Accelerate.Type import qualified Data.Array.Accelerate.Representation.Array as R -import qualified Data.Array.Accelerate.Sugar.Shape as S import Data.Array.Accelerate.Classes.Eq import Data.Array.Accelerate.Classes.Fractional @@ -704,8 +700,8 @@ scanr1 f (Acc a) = Acc $ SmartAcc $ Scan RightToLeft (eltR @a) (unExpBinaryFunct -- 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 +-- The combination function must be /associative/ and /commutative/. +-- Elements for which the permutation function returns 'Nothing' are -- dropped. -- -- The combination function is given the new value being permuted as its first @@ -793,7 +789,7 @@ permute :: forall sh sh' a. (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 + -> (Exp sh -> Exp (Maybe sh')) -- ^ index permutation function -> Acc (Array sh a) -- ^ array of source values to be permuted -> Acc (Array sh' a) permute = Acc $$$$ applyAcc (Permute $ arrayR @sh @a) @@ -1515,12 +1511,3 @@ bitcast -> Exp b bitcast = mkBitcast - --- Constants --- --------- - --- | Magic index identifying elements that are ignored in a forward permutation. --- -ignore :: Shape sh => Exp sh -ignore = constant S.ignore - diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 03789442c..daa45377a 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -37,9 +36,6 @@ module Data.Array.Accelerate.Pattern ( pattern V2, pattern V3, pattern V4, pattern V8, pattern V16, - mkPattern, - mkPatterns, - ) where import Data.Array.Accelerate.AST.Idx @@ -53,17 +49,8 @@ import Data.Array.Accelerate.Sugar.Vec import Data.Array.Accelerate.Type import Data.Primitive.Vec -import Control.Monad -import Data.Bits -import Data.Char -import Data.List ( (\\), foldl' ) -import Language.Haskell.TH hiding ( Exp, Match, match, tupP, tupE ) +import Language.Haskell.TH hiding ( Exp, Match, tupP, tupE ) import Language.Haskell.TH.Extra -import Numeric -import Text.Printf -import qualified Language.Haskell.TH as TH - -import GHC.Stack -- | A pattern synonym for working with (product) data types. You can declare @@ -110,396 +97,6 @@ instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where newtype VecPattern a = VecPattern a --- | As 'mkPattern, but for a list of types --- -mkPatterns :: [Name] -> DecsQ -mkPatterns nms = concat <$> mapM mkPattern nms - --- | Generate pattern synonyms for the given simple (Haskell'98) sum or --- product data type. --- --- Constructor and record selectors are renamed to add a trailing --- underscore if it does not exist, or to remove it if it does. For infix --- constructors, the name is prepended with a colon ':'. For example: --- --- > data Point = Point { xcoord_ :: Float, ycoord_ :: Float } --- > deriving (Generic, Elt) --- --- Will create the pattern synonym: --- --- > Point_ :: Exp Float -> Exp Float -> Exp Point --- --- together with the selector functions --- --- > xcoord :: Exp Point -> Exp Float --- > ycoord :: Exp Point -> Exp Float --- -mkPattern :: Name -> DecsQ -mkPattern nm = do - info <- reify nm - case info of - TyConI dec -> mkDec dec - _ -> fail "mkPatterns: expected the name of a newtype or datatype" - -mkDec :: Dec -> DecsQ -mkDec dec = - case dec of - DataD _ nm tv _ cs _ -> mkDataD nm tv cs - NewtypeD _ nm tv _ c _ -> mkNewtypeD nm tv c - _ -> fail "mkPatterns: expected the name of a newtype or datatype" - -mkNewtypeD :: Name -> [TyVarBndr] -> Con -> DecsQ -mkNewtypeD tn tvs c = mkDataD tn tvs [c] - -mkDataD :: Name -> [TyVarBndr] -> [Con] -> DecsQ -mkDataD tn tvs cs = do - (pats, decs) <- unzip <$> go cs - comp <- pragCompleteD pats Nothing - return $ comp : concat decs - where - -- For single-constructor types we create the pattern synonym for the - -- type directly in terms of Pattern - go [] = fail "mkPatterns: empty data declarations not supported" - go [c] = return <$> mkConP tn tvs c - go _ = go' [] (map fieldTys cs) ctags cs - - -- For sum-types, when creating the pattern for an individual - -- constructor we need to know about the types of the fields all other - -- constructors as well - go' prev (this:next) (tag:tags) (con:cons) = do - r <- mkConS tn tvs prev next tag con - rs <- go' (this:prev) next tags cons - return (r : rs) - go' _ [] [] [] = return [] - go' _ _ _ _ = fail "mkPatterns: unexpected error" - - fieldTys (NormalC _ fs) = map snd fs - fieldTys (RecC _ fs) = map (\(_,_,t) -> t) fs - fieldTys (InfixC a _ b) = [snd a, snd b] - fieldTys _ = fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" - - -- TODO: The GTags class demonstrates a way to generate the tags for - -- a given constructor, rather than backwards-engineering the structure - -- as we've done here. We should use that instead! - -- - ctags = - let n = length cs - m = n `quot` 2 - l = take m (iterate (True:) [False]) - r = take (n-m) (iterate (True:) [True]) - -- - bitsToTag = foldl' f 0 - where - f i False = i `shiftL` 1 - f i True = setBit (i `shiftL` 1) 0 - in - map bitsToTag (l ++ r) - - -mkConP :: Name -> [TyVarBndr] -> Con -> Q (Name, [Dec]) -mkConP tn' tvs' con' = do - checkExts [ PatternSynonyms ] - case con' of - NormalC cn fs -> mkNormalC tn' cn (map tyVarBndrName tvs') (map snd fs) - RecC cn fs -> mkRecC tn' cn (map tyVarBndrName tvs') (map (rename . fst3) fs) (map thd3 fs) - InfixC a cn b -> mkInfixC tn' cn (map tyVarBndrName tvs') [snd a, snd b] - _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" - where - mkNormalC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec]) - mkNormalC tn cn tvs fs = do - xs <- replicateM (length fs) (newName "_x") - r <- sequence [ patSynSigD pat sig - , patSynD pat - (prefixPatSyn xs) - implBidir - [p| Pattern $(tupP (map varP xs)) |] - ] - return (pat, r) - where - pat = rename cn - sig = forallT - (map plainTV tvs) - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) - - mkRecC :: Name -> Name -> [Name] -> [Name] -> [Type] -> Q (Name, [Dec]) - mkRecC tn cn tvs xs fs = do - r <- sequence [ patSynSigD pat sig - , patSynD pat - (recordPatSyn xs) - implBidir - [p| Pattern $(tupP (map varP xs)) |] - ] - return (pat, r) - where - pat = rename cn - sig = forallT - (map plainTV tvs) - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) - - mkInfixC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec]) - mkInfixC tn cn tvs fs = do - _a <- newName "_a" - _b <- newName "_b" - r <- sequence [ patSynSigD pat sig - , patSynD pat - (infixPatSyn _a _b) - implBidir - [p| Pattern $(tupP [varP _a, varP _b]) |] - ] - return (pat, r) - where - pat = mkName (':' : nameBase cn) - sig = forallT - (map plainTV tvs) - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) - -mkConS :: Name -> [TyVarBndr] -> [[Type]] -> [[Type]] -> Word8 -> Con -> Q (Name, [Dec]) -mkConS tn' tvs' prev' next' tag' con' = do - checkExts [GADTs, PatternSynonyms, ScopedTypeVariables, TypeApplications, ViewPatterns] - case con' of - NormalC cn fs -> mkNormalC tn' cn tag' (map tyVarBndrName tvs') prev' (map snd fs) next' - RecC cn fs -> mkRecC tn' cn tag' (map tyVarBndrName tvs') (map (rename . fst3) fs) prev' (map thd3 fs) next' - InfixC a cn b -> mkInfixC tn' cn tag' (map tyVarBndrName tvs') prev' [snd a, snd b] next' - _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" - where - mkNormalC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) - mkNormalC tn cn tag tvs ps fs ns = do - (fun_build, dec_build) <- mkBuild tn (nameBase cn) tvs tag ps fs ns - (fun_match, dec_match) <- mkMatch tn (nameBase cn) tvs tag ps fs ns - (pat, dec_pat) <- mkNormalC_pattern tn cn tvs fs fun_build fun_match - return $ (pat, concat [dec_pat, dec_build, dec_match]) - - mkRecC :: Name -> Name -> Word8 -> [Name] -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) - mkRecC tn cn tag tvs xs ps fs ns = do - (fun_build, dec_build) <- mkBuild tn (nameBase cn) tvs tag ps fs ns - (fun_match, dec_match) <- mkMatch tn (nameBase cn) tvs tag ps fs ns - (pat, dec_pat) <- mkRecC_pattern tn cn tvs xs fs fun_build fun_match - return $ (pat, concat [dec_pat, dec_build, dec_match]) - - mkInfixC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) - mkInfixC tn cn tag tvs ps fs ns = do - (fun_build, dec_build) <- mkBuild tn (zencode (nameBase cn)) tvs tag ps fs ns - (fun_match, dec_match) <- mkMatch tn (zencode (nameBase cn)) tvs tag ps fs ns - (pat, dec_pat) <- mkInfixC_pattern tn cn tvs fs fun_build fun_match - return $ (pat, concat [dec_pat, dec_build, dec_match]) - - mkNormalC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) - mkNormalC_pattern tn cn tvs fs build match = do - xs <- replicateM (length fs) (newName "_x") - r <- sequence [ patSynSigD pat sig - , patSynD pat - (prefixPatSyn xs) - (explBidir [clause [] (normalB (varE build)) []]) - (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) - ] - return (pat, r) - where - pat = rename cn - sig = forallT - (map plainTV tvs) - (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) - - mkRecC_pattern :: Name -> Name -> [Name] -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) - mkRecC_pattern tn cn tvs xs fs build match = do - r <- sequence [ patSynSigD pat sig - , patSynD pat - (recordPatSyn xs) - (explBidir [clause [] (normalB (varE build)) []]) - (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) - ] - return (pat, r) - where - pat = rename cn - sig = forallT - (map plainTV tvs) - (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) - - mkInfixC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) - mkInfixC_pattern tn cn tvs fs build match = do - _a <- newName "_a" - _b <- newName "_b" - r <- sequence [ patSynSigD pat sig - , patSynD pat - (infixPatSyn _a _b) - (explBidir [clause [] (normalB (varE build)) []]) - (parensP $ viewP (varE match) [p| Just $(tupP [varP _a, varP _b]) |]) - ] - return (pat, r) - where - pat = mkName (':' : nameBase cn) - sig = forallT - (map plainTV tvs) - (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) - - mkBuild :: Name -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) - mkBuild tn cn tvs tag fs0 fs fs1 = do - fun <- newName ("_build" ++ cn) - xs <- replicateM (length fs) (newName "_x") - let - vs = foldl' (\es e -> [| SmartExp ($es `Pair` $e) |]) [| SmartExp Nil |] - $ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat (reverse fs0)) - ++ map varE xs - ++ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat fs1) - - tagged = [| Exp $ SmartExp $ Pair (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) $(litE (IntegerL (toInteger tag))))) $vs |] - body = clause (map (\x -> [p| (Exp $(varP x)) |]) xs) (normalB tagged) [] - - r <- sequence [ sigD fun sig - , funD fun [body] - ] - return (fun, r) - where - sig = forallT - (map plainTV tvs) - (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) - (foldr (\t ts -> [t| $t -> $ts |]) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] - (map (\t -> [t| Exp $(return t) |]) fs)) - - - mkMatch :: Name -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) - mkMatch tn cn tvs tag fs0 fs fs1 = do - fun <- newName ("_match" ++ cn) - e <- newName "_e" - x <- newName "_x" - (ps,es) <- extract vs [| Prj PairIdxRight $(varE x) |] [] [] - let - lhs = [p| (Exp $(varP e)) |] - body = normalB $ caseE (varE e) - [ TH.match (conP 'SmartExp [(conP 'Match [matchP ps, varP x])]) (normalB [| Just $(tupE es) |]) [] - , TH.match (conP 'SmartExp [(recP 'Match [])]) (normalB [| Nothing |]) [] - , TH.match wildP (normalB [| error "Pattern synonym used outside 'match' context" |]) [] - ] - - r <- sequence [ sigD fun sig - , funD fun [clause [lhs] body []] - ] - return (fun, r) - where - sig = forallT - (map plainTV tvs) - (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) - [t| Exp $(foldl' appT (conT tn) (map varT tvs)) -> Maybe $(tupT (map (\t -> [t| Exp $(return t) |]) fs)) |] - - matchP us = [p| TagRtag $(litP (IntegerL (toInteger tag))) $pat |] - where - pat = [p| $(foldl (\ps p -> [p| TagRpair $ps $p |]) [p| TagRunit |] us) |] - - extract [] _ ps es = return (ps, es) - extract (u:us) x ps es = do - _u <- newName "_u" - let x' = [| Prj PairIdxLeft (SmartExp $x) |] - if not u - then extract us x' (wildP:ps) es - else extract us x' (varP _u:ps) ([| Exp (SmartExp (Match $(varE _u) (SmartExp (Prj PairIdxRight (SmartExp $x))))) |] : es) - - vs = reverse - $ [ False | _ <- concat fs0 ] ++ [ True | _ <- fs ] ++ [ False | _ <- concat fs1 ] - -fst3 :: (a,b,c) -> a -fst3 (a,_,_) = a - -thd3 :: (a,b,c) -> c -thd3 (_,_,c) = c - -rename :: Name -> Name -rename nm = - let - split acc [] = (reverse acc, '\0') -- shouldn't happen - split acc [l] = (reverse acc, l) - split acc (l:ls) = split (l:acc) ls - -- - nm' = nameBase nm - (base, suffix) = split [] nm' - in - case suffix of - '_' -> mkName base - _ -> mkName (nm' ++ "_") - -checkExts :: [Extension] -> Q () -checkExts req = do - enabled <- extsEnabled - let missing = req \\ enabled - unless (null missing) . fail . unlines - $ printf "You must enable the following language extensions to generate pattern synonyms:" - : map (printf " {-# LANGUAGE %s #-}" . show) missing - --- A simplified version of that stolen from GHC/Utils/Encoding.hs --- -type EncodedString = String - -zencode :: String -> EncodedString -zencode [] = [] -zencode (h:rest) = encode_digit h ++ go rest - where - go [] = [] - go (c:cs) = encode_ch c ++ go cs - -unencoded_char :: Char -> Bool -unencoded_char 'z' = False -unencoded_char 'Z' = False -unencoded_char c = isAlphaNum c - -encode_digit :: Char -> EncodedString -encode_digit c | isDigit c = encode_as_unicode_char c - | otherwise = encode_ch c - -encode_ch :: Char -> EncodedString -encode_ch c | unencoded_char c = [c] -- Common case first -encode_ch '(' = "ZL" -encode_ch ')' = "ZR" -encode_ch '[' = "ZM" -encode_ch ']' = "ZN" -encode_ch ':' = "ZC" -encode_ch 'Z' = "ZZ" -encode_ch 'z' = "zz" -encode_ch '&' = "za" -encode_ch '|' = "zb" -encode_ch '^' = "zc" -encode_ch '$' = "zd" -encode_ch '=' = "ze" -encode_ch '>' = "zg" -encode_ch '#' = "zh" -encode_ch '.' = "zi" -encode_ch '<' = "zl" -encode_ch '-' = "zm" -encode_ch '!' = "zn" -encode_ch '+' = "zp" -encode_ch '\'' = "zq" -encode_ch '\\' = "zr" -encode_ch '/' = "zs" -encode_ch '*' = "zt" -encode_ch '_' = "zu" -encode_ch '%' = "zv" -encode_ch c = encode_as_unicode_char c - -encode_as_unicode_char :: Char -> EncodedString -encode_as_unicode_char c - = 'z' - : if isDigit (head hex_str) then hex_str - else '0':hex_str - where - hex_str = showHex (ord c) "U" - - -- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of -- the (unremarkable) boilerplate for us. -- diff --git a/src/Data/Array/Accelerate/Pattern/Bool.hs b/src/Data/Array/Accelerate/Pattern/Bool.hs new file mode 100644 index 000000000..947f85fea --- /dev/null +++ b/src/Data/Array/Accelerate/Pattern/Bool.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.Pattern.Bool +-- Copyright : [2018..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Pattern.Bool ( + + Bool, pattern True_, pattern False_, + +) where + +import Data.Array.Accelerate.Pattern.TH + +mkPattern ''Bool + diff --git a/src/Data/Array/Accelerate/Pattern/Either.hs b/src/Data/Array/Accelerate/Pattern/Either.hs new file mode 100644 index 000000000..1aa91b5e0 --- /dev/null +++ b/src/Data/Array/Accelerate/Pattern/Either.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.Pattern.Either +-- Copyright : [2018..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Pattern.Either ( + + Either, pattern Left_, pattern Right_, + +) where + +import Data.Array.Accelerate.Pattern.TH + +mkPattern ''Either + diff --git a/src/Data/Array/Accelerate/Pattern/Maybe.hs b/src/Data/Array/Accelerate/Pattern/Maybe.hs new file mode 100644 index 000000000..50d72557d --- /dev/null +++ b/src/Data/Array/Accelerate/Pattern/Maybe.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.Pattern.Maybe +-- Copyright : [2018..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Pattern.Maybe ( + + Maybe, pattern Nothing_, pattern Just_, + +) where + +import Data.Array.Accelerate.Pattern.TH + +mkPattern ''Maybe + diff --git a/src/Data/Array/Accelerate/Pattern/Ordering.hs b/src/Data/Array/Accelerate/Pattern/Ordering.hs new file mode 100644 index 000000000..233cb8328 --- /dev/null +++ b/src/Data/Array/Accelerate/Pattern/Ordering.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.Pattern.Ordering +-- Copyright : [2018..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Pattern.Ordering ( + + Ordering, pattern LT_, pattern EQ_, pattern GT_, + +) where + +import Data.Array.Accelerate.Pattern.TH + +mkPattern ''Ordering + diff --git a/src/Data/Array/Accelerate/Pattern/TH.hs b/src/Data/Array/Accelerate/Pattern/TH.hs new file mode 100644 index 000000000..a6e78a657 --- /dev/null +++ b/src/Data/Array/Accelerate/Pattern/TH.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.Array.Accelerate.Pattern.TH +-- Copyright : [2018..2019] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.Pattern.TH ( + + mkPattern, + mkPatterns, + +) where + +import Data.Array.Accelerate.AST.Idx +import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Representation.Tag +import Data.Array.Accelerate.Smart +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Type + +import Control.Monad +import Data.Bits +import Data.Char +import Data.List ( (\\), foldl' ) +import Language.Haskell.TH hiding ( Exp, Match, match, tupP, tupE ) +import Language.Haskell.TH.Extra +import Numeric +import Text.Printf +import qualified Language.Haskell.TH as TH + +import GHC.Stack + + +-- | As 'mkPattern, but for a list of types +-- +mkPatterns :: [Name] -> DecsQ +mkPatterns nms = concat <$> mapM mkPattern nms + +-- | Generate pattern synonyms for the given simple (Haskell'98) sum or +-- product data type. +-- +-- Constructor and record selectors are renamed to add a trailing +-- underscore if it does not exist, or to remove it if it does. For infix +-- constructors, the name is prepended with a colon ':'. For example: +-- +-- > data Point = Point { xcoord_ :: Float, ycoord_ :: Float } +-- > deriving (Generic, Elt) +-- +-- Will create the pattern synonym: +-- +-- > Point_ :: Exp Float -> Exp Float -> Exp Point +-- +-- together with the selector functions +-- +-- > xcoord :: Exp Point -> Exp Float +-- > ycoord :: Exp Point -> Exp Float +-- +mkPattern :: Name -> DecsQ +mkPattern nm = do + info <- reify nm + case info of + TyConI dec -> mkDec dec + _ -> fail "mkPatterns: expected the name of a newtype or datatype" + +mkDec :: Dec -> DecsQ +mkDec dec = + case dec of + DataD _ nm tv _ cs _ -> mkDataD nm tv cs + NewtypeD _ nm tv _ c _ -> mkNewtypeD nm tv c + _ -> fail "mkPatterns: expected the name of a newtype or datatype" + +mkNewtypeD :: Name -> [TyVarBndr] -> Con -> DecsQ +mkNewtypeD tn tvs c = mkDataD tn tvs [c] + +mkDataD :: Name -> [TyVarBndr] -> [Con] -> DecsQ +mkDataD tn tvs cs = do + (pats, decs) <- unzip <$> go cs + comp <- pragCompleteD pats Nothing + return $ comp : concat decs + where + -- For single-constructor types we create the pattern synonym for the + -- type directly in terms of Pattern + go [] = fail "mkPatterns: empty data declarations not supported" + go [c] = return <$> mkConP tn tvs c + go _ = go' [] (map fieldTys cs) ctags cs + + -- For sum-types, when creating the pattern for an individual + -- constructor we need to know about the types of the fields all other + -- constructors as well + go' prev (this:next) (tag:tags) (con:cons) = do + r <- mkConS tn tvs prev next tag con + rs <- go' (this:prev) next tags cons + return (r : rs) + go' _ [] [] [] = return [] + go' _ _ _ _ = fail "mkPatterns: unexpected error" + + fieldTys (NormalC _ fs) = map snd fs + fieldTys (RecC _ fs) = map (\(_,_,t) -> t) fs + fieldTys (InfixC a _ b) = [snd a, snd b] + fieldTys _ = fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" + + -- TODO: The GTags class demonstrates a way to generate the tags for + -- a given constructor, rather than backwards-engineering the structure + -- as we've done here. We should use that instead! + -- + ctags = + let n = length cs + m = n `quot` 2 + l = take m (iterate (True:) [False]) + r = take (n-m) (iterate (True:) [True]) + -- + bitsToTag = foldl' f 0 + where + f i False = i `shiftL` 1 + f i True = setBit (i `shiftL` 1) 0 + in + map bitsToTag (l ++ r) + + +mkConP :: Name -> [TyVarBndr] -> Con -> Q (Name, [Dec]) +mkConP tn' tvs' con' = do + checkExts [ PatternSynonyms ] + case con' of + NormalC cn fs -> mkNormalC tn' cn (map tyVarBndrName tvs') (map snd fs) + RecC cn fs -> mkRecC tn' cn (map tyVarBndrName tvs') (map (rename . fst3) fs) (map thd3 fs) + InfixC a cn b -> mkInfixC tn' cn (map tyVarBndrName tvs') [snd a, snd b] + _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" + where + mkNormalC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec]) + mkNormalC tn cn tvs fs = do + xs <- replicateM (length fs) (newName "_x") + r <- sequence [ patSynSigD pat sig + , patSynD pat + (prefixPatSyn xs) + implBidir + [p| Pattern $(tupP (map varP xs)) |] + ] + return (pat, r) + where + pat = rename cn + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkRecC :: Name -> Name -> [Name] -> [Name] -> [Type] -> Q (Name, [Dec]) + mkRecC tn cn tvs xs fs = do + r <- sequence [ patSynSigD pat sig + , patSynD pat + (recordPatSyn xs) + implBidir + [p| Pattern $(tupP (map varP xs)) |] + ] + return (pat, r) + where + pat = rename cn + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkInfixC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec]) + mkInfixC tn cn tvs fs = do + _a <- newName "_a" + _b <- newName "_b" + r <- sequence [ patSynSigD pat sig + , patSynD pat + (infixPatSyn _a _b) + implBidir + [p| Pattern $(tupP [varP _a, varP _b]) |] + ] + return (pat, r) + where + pat = mkName (':' : nameBase cn) + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + +mkConS :: Name -> [TyVarBndr] -> [[Type]] -> [[Type]] -> Word8 -> Con -> Q (Name, [Dec]) +mkConS tn' tvs' prev' next' tag' con' = do + checkExts [GADTs, PatternSynonyms, ScopedTypeVariables, TypeApplications, ViewPatterns] + case con' of + NormalC cn fs -> mkNormalC tn' cn tag' (map tyVarBndrName tvs') prev' (map snd fs) next' + RecC cn fs -> mkRecC tn' cn tag' (map tyVarBndrName tvs') (map (rename . fst3) fs) prev' (map thd3 fs) next' + InfixC a cn b -> mkInfixC tn' cn tag' (map tyVarBndrName tvs') prev' [snd a, snd b] next' + _ -> fail "mkPatterns: only constructors for \"vanilla\" syntax are supported" + where + mkNormalC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkNormalC tn cn tag tvs ps fs ns = do + (fun_build, dec_build) <- mkBuild tn (nameBase cn) tvs tag ps fs ns + (fun_match, dec_match) <- mkMatch tn (nameBase cn) tvs tag ps fs ns + (pat, dec_pat) <- mkNormalC_pattern tn cn tvs fs fun_build fun_match + return $ (pat, concat [dec_pat, dec_build, dec_match]) + + mkRecC :: Name -> Name -> Word8 -> [Name] -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkRecC tn cn tag tvs xs ps fs ns = do + (fun_build, dec_build) <- mkBuild tn (nameBase cn) tvs tag ps fs ns + (fun_match, dec_match) <- mkMatch tn (nameBase cn) tvs tag ps fs ns + (pat, dec_pat) <- mkRecC_pattern tn cn tvs xs fs fun_build fun_match + return $ (pat, concat [dec_pat, dec_build, dec_match]) + + mkInfixC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkInfixC tn cn tag tvs ps fs ns = do + (fun_build, dec_build) <- mkBuild tn (zencode (nameBase cn)) tvs tag ps fs ns + (fun_match, dec_match) <- mkMatch tn (zencode (nameBase cn)) tvs tag ps fs ns + (pat, dec_pat) <- mkInfixC_pattern tn cn tvs fs fun_build fun_match + return $ (pat, concat [dec_pat, dec_build, dec_match]) + + mkNormalC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) + mkNormalC_pattern tn cn tvs fs build match = do + xs <- replicateM (length fs) (newName "_x") + r <- sequence [ patSynSigD pat sig + , patSynD pat + (prefixPatSyn xs) + (explBidir [clause [] (normalB (varE build)) []]) + (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) + ] + return (pat, r) + where + pat = rename cn + sig = forallT + (map plainTV tvs) + (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkRecC_pattern :: Name -> Name -> [Name] -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) + mkRecC_pattern tn cn tvs xs fs build match = do + r <- sequence [ patSynSigD pat sig + , patSynD pat + (recordPatSyn xs) + (explBidir [clause [] (normalB (varE build)) []]) + (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) + ] + return (pat, r) + where + pat = rename cn + sig = forallT + (map plainTV tvs) + (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkInfixC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) + mkInfixC_pattern tn cn tvs fs build match = do + _a <- newName "_a" + _b <- newName "_b" + r <- sequence [ patSynSigD pat sig + , patSynD pat + (infixPatSyn _a _b) + (explBidir [clause [] (normalB (varE build)) []]) + (parensP $ viewP (varE match) [p| Just $(tupP [varP _a, varP _b]) |]) + ] + return (pat, r) + where + pat = mkName (':' : nameBase cn) + sig = forallT + (map plainTV tvs) + (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + mkBuild :: Name -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkBuild tn cn tvs tag fs0 fs fs1 = do + fun <- newName ("_build" ++ cn) + xs <- replicateM (length fs) (newName "_x") + let + vs = foldl' (\es e -> [| SmartExp ($es `Pair` $e) |]) [| SmartExp Nil |] + $ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat (reverse fs0)) + ++ map varE xs + ++ map (\t -> [| unExp (undef @ $(return t)) |] ) (concat fs1) + + tagged = [| Exp $ SmartExp $ Pair (SmartExp (Const (SingleScalarType (NumSingleType (IntegralNumType TypeWord8))) $(litE (IntegerL (toInteger tag))))) $vs |] + body = clause (map (\x -> [p| (Exp $(varP x)) |]) xs) (normalB tagged) [] + + r <- sequence [ sigD fun sig + , funD fun [body] + ] + return (fun, r) + where + sig = forallT + (map plainTV tvs) + (cxt (map (\t -> [t| Elt $(varT t) |]) tvs)) + (foldr (\t ts -> [t| $t -> $ts |]) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] + (map (\t -> [t| Exp $(return t) |]) fs)) + + + mkMatch :: Name -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkMatch tn cn tvs tag fs0 fs fs1 = do + fun <- newName ("_match" ++ cn) + e <- newName "_e" + x <- newName "_x" + (ps,es) <- extract vs [| Prj PairIdxRight $(varE x) |] [] [] + let + lhs = [p| (Exp $(varP e)) |] + body = normalB $ caseE (varE e) + [ TH.match (conP 'SmartExp [(conP 'Match [matchP ps, varP x])]) (normalB [| Just $(tupE es) |]) [] + , TH.match (conP 'SmartExp [(recP 'Match [])]) (normalB [| Nothing |]) [] + , TH.match wildP (normalB [| error "Pattern synonym used outside 'match' context" |]) [] + ] + + r <- sequence [ sigD fun sig + , funD fun [clause [lhs] body []] + ] + return (fun, r) + where + sig = forallT + (map plainTV tvs) + (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) + [t| Exp $(foldl' appT (conT tn) (map varT tvs)) -> Maybe $(tupT (map (\t -> [t| Exp $(return t) |]) fs)) |] + + matchP us = [p| TagRtag $(litP (IntegerL (toInteger tag))) $pat |] + where + pat = [p| $(foldl (\ps p -> [p| TagRpair $ps $p |]) [p| TagRunit |] us) |] + + extract [] _ ps es = return (ps, es) + extract (u:us) x ps es = do + _u <- newName "_u" + let x' = [| Prj PairIdxLeft (SmartExp $x) |] + if not u + then extract us x' (wildP:ps) es + else extract us x' (varP _u:ps) ([| Exp (SmartExp (Match $(varE _u) (SmartExp (Prj PairIdxRight (SmartExp $x))))) |] : es) + + vs = reverse + $ [ False | _ <- concat fs0 ] ++ [ True | _ <- fs ] ++ [ False | _ <- concat fs1 ] + +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c + +rename :: Name -> Name +rename nm = + let + split acc [] = (reverse acc, '\0') -- shouldn't happen + split acc [l] = (reverse acc, l) + split acc (l:ls) = split (l:acc) ls + -- + nm' = nameBase nm + (base, suffix) = split [] nm' + in + case suffix of + '_' -> mkName base + _ -> mkName (nm' ++ "_") + +checkExts :: [Extension] -> Q () +checkExts req = do + enabled <- extsEnabled + let missing = req \\ enabled + unless (null missing) . fail . unlines + $ printf "You must enable the following language extensions to generate pattern synonyms:" + : map (printf " {-# LANGUAGE %s #-}" . show) missing + +-- A simplified version of that stolen from GHC/Utils/Encoding.hs +-- +type EncodedString = String + +zencode :: String -> EncodedString +zencode [] = [] +zencode (h:rest) = encode_digit h ++ go rest + where + go [] = [] + go (c:cs) = encode_ch c ++ go cs + +unencoded_char :: Char -> Bool +unencoded_char 'z' = False +unencoded_char 'Z' = False +unencoded_char c = isAlphaNum c + +encode_digit :: Char -> EncodedString +encode_digit c | isDigit c = encode_as_unicode_char c + | otherwise = encode_ch c + +encode_ch :: Char -> EncodedString +encode_ch c | unencoded_char c = [c] -- Common case first +encode_ch '(' = "ZL" +encode_ch ')' = "ZR" +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = encode_as_unicode_char c + +encode_as_unicode_char :: Char -> EncodedString +encode_as_unicode_char c + = 'z' + : if isDigit (head hex_str) then hex_str + else '0':hex_str + where + hex_str = showHex (ord c) "U" + diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 0d3d2c5cc..405ee3e98 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -65,7 +65,7 @@ module Data.Array.Accelerate.Prelude ( -- * Working with predicates -- ** Filtering - filter, + filter, compact, -- ** Scatter / Gather scatter, scatterIf, @@ -122,6 +122,7 @@ import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Language import Data.Array.Accelerate.Lift import Data.Array.Accelerate.Pattern +import Data.Array.Accelerate.Pattern.Maybe import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Array ( Arrays, Array, Scalar, Vector, Segments, fromList ) import Data.Array.Accelerate.Sugar.Elt @@ -997,7 +998,7 @@ scanlSeg f z arr seg = seg' = map (+1) seg arr' = permute const (fill (sh ::. sz + length seg) z) - (\(sx ::. i) -> sx ::. i + fromIntegral (inc ! I1 i)) + (\(sx ::. i) -> Just_ (sx ::. i + fromIntegral (inc ! I1 i))) (take (length flags) arr) -- Each element in the segments must be shifted to the right one additional @@ -1090,7 +1091,7 @@ scanl'Seg f z arr seg = offset = scanl1 (+) seg inc = scanl1 (+) $ permute (+) (fill (I1 $ size arr + 1) 0) - (\ix -> index1' $ offset ! ix) + (\ix -> Just_ (index1' (offset ! ix))) (fill (shape seg) (1 :: Exp i)) len = offset ! I1 (length offset - 1) @@ -1218,7 +1219,7 @@ scanrSeg f z arr seg = seg' = map (+1) seg arr' = permute const (fill (sh ::. sz + length seg) z) - (\(sx ::. i) -> sx ::. i + fromIntegral (inc !! i) - 1) + (\(sx ::. i) -> Just_ (sx ::. i + fromIntegral (inc !! i) - 1)) (drop (sz - length flags) arr) @@ -1364,7 +1365,7 @@ mkHeadFlags -> Acc (Segments i) mkHeadFlags seg = init - $ permute (+) zeros (\ix -> index1' (offset ! ix)) ones + $ permute (+) zeros (\ix -> Just_ (index1' (offset ! ix))) ones where T2 offset len = scanl' (+) 0 seg zeros = fill (index1' $ the len + 1) 0 @@ -1379,7 +1380,7 @@ mkTailFlags -> Acc (Segments i) mkTailFlags seg = init - $ permute (+) zeros (\ix -> index1' (the len - 1 - offset ! ix)) ones + $ permute (+) zeros (\ix -> Just_ (index1' (the len - 1 - offset ! ix))) ones where T2 offset len = scanr' (+) 0 seg zeros = fill (index1' $ the len + 1) 0 @@ -1631,18 +1632,34 @@ concatOn dim xs ys = -- >>> 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, Elt e) +filter :: (Shape sh, Elt e) => (Exp e -> Exp Bool) -> Acc (Array (sh:.Int) e) -> Acc (Vector e, Array sh Int) -filter p arr +filter p arr = compact (map p arr) arr +{-# NOINLINE filter #-} +{-# RULES + "ACC filter/filter" forall f g arr. + filter f (afst (filter g arr)) = filter (\x -> g x && f x) arr + #-} + + +-- | As 'filter', but with separate arrays for the data elements and the +-- flags indicating which elements of that array should be kept. +-- +compact :: forall sh e. (Shape sh, Elt e) + => Acc (Array (sh:.Int) Bool) + -> Acc (Array (sh:.Int) e) + -> Acc (Vector e, Array sh Int) +compact keep arr -- Optimise 1-dimensional arrays, where we can avoid additional computations -- for the offset indices. | Just Refl <- matchShapeType @sh @Z = let - keep = map p arr T2 target len = scanl' (+) 0 (map boolToInt keep) - prj ix = keep!ix ? ( I1 (target!ix), ignore ) + prj ix = if keep!ix + then Just_ (I1 (target!ix)) + else Nothing_ dummy = fill (I1 (the len)) undef result = permute const dummy prj arr in @@ -1650,15 +1667,14 @@ filter p arr then T2 emptyArray (fill Z_ 0) else T2 result len -filter p arr +compact keep arr = let sz = indexTail (shape arr) - keep = map p arr T2 target len = scanl' (+) 0 (map boolToInt keep) T2 offset valid = scanl' (+) 0 (flatten len) prj ix = if keep!ix - then I1 $ offset !! (toIndex sz (indexTail ix)) + target!ix - else ignore + then Just_ (I1 (offset !! (toIndex sz (indexTail ix)) + target!ix)) + else Nothing_ dummy = fill (I1 (the valid)) undef result = permute const dummy prj arr in @@ -1666,12 +1682,6 @@ filter p arr then T2 emptyArray (fill sz 0) else T2 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 -- ----------------- @@ -1745,7 +1755,7 @@ scatter -> Acc (Vector e) scatter to defaults input = permute const defaults pf input' where - pf ix = I1 (to ! ix) + pf ix = Just_ (I1 (to ! ix)) input' = backpermute (shape to `intersect` shape input) id input @@ -1772,8 +1782,10 @@ scatterIf -> Acc (Vector b) scatterIf to maskV pred defaults input = permute const defaults pf input' where - pf ix = pred (maskV ! ix) ? ( I1 (to ! ix), ignore ) input' = backpermute (shape to `intersect` shape input) id input + pf ix = if pred (maskV ! ix) + then Just_ (I1 (to ! ix)) + else Nothing_ -- Permutations @@ -2467,7 +2479,7 @@ length = unindex1 . shape -- new = -- let m = c2-c1 -- put i = let s = sieves ! i --- in s >= 0 && s < m ? (I1 s, ignore) +-- in s >= 0 && s < m ? (Just_ (I1 s), Nothing_) -- in -- afst -- $ filter (> 0) @@ -2501,7 +2513,7 @@ expand f g xs = m = the len n = m + 1 - put ix = I1 (offset ! ix) + put ix = Just_ (I1 (offset ! ix)) head_flags :: Acc (Vector Int) head_flags = permute const (fill (I1 n) 0) put (fill (shape szs) 1) diff --git a/src/Data/Array/Accelerate/Representation/Shape.hs b/src/Data/Array/Accelerate/Representation/Shape.hs index 3b29abc50..896bde50c 100644 --- a/src/Data/Array/Accelerate/Representation/Shape.hs +++ b/src/Data/Array/Accelerate/Representation/Shape.hs @@ -72,12 +72,6 @@ empty :: ShapeR sh -> sh empty ShapeRz = () empty (ShapeRsnoc shr) = (empty shr, 0) --- | Magic value identifying elements ignored in 'Data.Array.Accelerate.permute' --- -ignore :: ShapeR sh -> sh -ignore ShapeRz = () -ignore (ShapeRsnoc shr) = (ignore shr, -1) - -- | Yield the intersection of two shapes -- intersect :: ShapeR sh -> sh -> sh -> sh diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 88c3da89b..9bfc7967d 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -38,6 +38,7 @@ module Data.Array.Accelerate.Smart ( Stencil(..), Boundary(..), PreBoundary(..), PrimBool, + PrimMaybe, -- ** Extracting type information HasArraysR(..), @@ -101,6 +102,7 @@ import qualified Data.Array.Accelerate.Sugar.Array as Sugar import qualified Data.Array.Accelerate.Sugar.Shape as Sugar import Data.Array.Accelerate.AST ( Direction(..) + , PrimBool, PrimMaybe , PrimFun(..), primFunType , PrimConst(..), primConstType ) import Data.Primitive.Vec @@ -308,7 +310,6 @@ newtype SmartAcc a = SmartAcc (PreSmartAcc SmartAcc SmartExp a) -- the environment at the defining occurrence. -- type Level = Int -type PrimBool = TAG -- | Array-valued collective computations without a recursive knot -- @@ -427,7 +428,7 @@ data PreSmartAcc acc exp as where Permute :: ArrayR (Array sh e) -> (SmartExp e -> SmartExp e -> exp e) -> acc (Array sh' e) - -> (SmartExp sh -> exp sh') + -> (SmartExp sh -> exp (PrimMaybe sh')) -> acc (Array sh e) -> PreSmartAcc acc exp (Array sh' e) diff --git a/src/Data/Array/Accelerate/Sugar/Elt.hs b/src/Data/Array/Accelerate/Sugar/Elt.hs index 032937c67..9e204595f 100644 --- a/src/Data/Array/Accelerate/Sugar/Elt.hs +++ b/src/Data/Array/Accelerate/Sugar/Elt.hs @@ -299,6 +299,9 @@ untag (TupRpair ta tb) = TagRpair (untag ta) (untag tb) instance Elt () instance Elt Bool +instance Elt Ordering +instance Elt a => Elt (Maybe a) +instance (Elt a, Elt b) => Elt (Either a b) instance Elt Char where type EltR Char = Word32 diff --git a/src/Data/Array/Accelerate/Sugar/Shape.hs b/src/Data/Array/Accelerate/Sugar/Shape.hs index 276492b19..d4677e77c 100644 --- a/src/Data/Array/Accelerate/Sugar/Shape.hs +++ b/src/Data/Array/Accelerate/Sugar/Shape.hs @@ -148,11 +148,6 @@ size = R.size (shapeR @sh) . fromElt empty :: forall sh. Shape sh => sh empty = toElt $ R.empty (shapeR @sh) --- | Magic value identifying elements ignored in 'permute' --- -ignore :: forall sh. Shape sh => sh -ignore = toElt $ R.ignore (shapeR @sh) - -- | Yield the intersection of two shapes intersect :: forall sh. Shape sh => sh -> sh -> sh intersect x y = toElt $ R.intersect (shapeR @sh) (fromElt x) (fromElt y) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs index b61ed1850..0247563df 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs @@ -20,6 +20,7 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue137 ( ) where import Data.Array.Accelerate as A +import Data.Array.Accelerate.Data.Maybe as A import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty @@ -51,6 +52,6 @@ test1 = , lift (b1, A.min b2 a1) )) infsA - (\ix -> index1 (msA A.! ix)) + (\ix -> Just_ (index1 (msA A.! ix))) inpA diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs index cd9613807..0b04206f3 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs @@ -23,6 +23,7 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue185 ( ) where import Data.Array.Accelerate as A +import Data.Array.Accelerate.Data.Maybe as A import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty @@ -144,6 +145,6 @@ scatterIf -> Acc (Vector e') scatterIf to maskV p def input = permute const def pf input' where - pf ix = p (maskV ! ix) ? ( index1 (to ! ix), ignore ) + pf ix = p (maskV ! ix) ? ( Just_ (index1 (to ! ix)), Nothing_ ) input' = backpermute (shape to `intersect` shape input) id input diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs index 5a32eac28..982361008 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs @@ -18,6 +18,7 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue93 ( ) where import Data.Array.Accelerate as A +import Data.Array.Accelerate.Data.Maybe as A import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty @@ -32,7 +33,7 @@ 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' +test1 = permute (\c _ -> c) (fill (shape xs') (constant 0)) Just_ xs' where xs' = use xs diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs index 9bd22eb20..0e007e4a0 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs @@ -111,8 +111,8 @@ test_scatter runN dim dim' e = 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) + True -> return (Nothing : ts) + False -> return (Just (S.fromIndex sh' t) : ts) -- def <- forAll (array sh' e) new <- forAll (array sh e) @@ -138,8 +138,8 @@ test_accumulate runN dim dim' e = 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)) + ix <- forAll (array sh (Gen.choice [ return Nothing + , Just . 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 @@ -149,7 +149,7 @@ permuteRef :: forall sh sh' e. (Shape sh, Shape sh', P.Eq sh', Elt e) => (e -> e -> e) -> Array sh' e - -> (sh -> sh') + -> (sh -> Maybe sh') -> Array sh e -> Array sh' e permuteRef f def@(Array (R.Array _ aold)) p arr@(Array (R.Array _ anew)) = @@ -164,13 +164,13 @@ permuteRef f def@(Array (R.Array _ aold)) p arr@(Array (R.Array _ anew)) = | 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 <$> readArrayData tp anew i - x' <- toElt <$> readArrayData tp aold i' - writeArrayData tp aold i' (fromElt (f x x')) + case p ix of + Nothing -> return () + Just ix' -> do + let i' = S.toIndex sh' ix' + x <- toElt <$> readArrayData tp anew i + x' <- toElt <$> readArrayData tp aold i' + writeArrayData tp aold i' (fromElt (f x x')) -- go (i+1) -- diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs index 1c9576fb6..5c85e5ef1 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs @@ -29,6 +29,7 @@ import qualified Data.Bits as P import Data.Array.Accelerate as A import Data.Array.Accelerate.Data.Bits as A +import Data.Array.Accelerate.Data.Maybe as A import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config @@ -176,7 +177,7 @@ radixsortBy rdx arr = foldr1 (>->) (P.map radixPass [0..p-1]) arr 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 + permute const v (\ix -> Just_ (index1 (index!ix))) v -- This is rather slow. Speeding up the reference implementation by using, say, From cf1ba1e37d959470707470a37a60d59b6fb0f698 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 1 Jul 2020 17:27:44 +0200 Subject: [PATCH 269/316] add fixity declarations to generated patterns --- src/Data/Array/Accelerate/Pattern/TH.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Pattern/TH.hs b/src/Data/Array/Accelerate/Pattern/TH.hs index a6e78a657..cef2f3299 100644 --- a/src/Data/Array/Accelerate/Pattern/TH.hs +++ b/src/Data/Array/Accelerate/Pattern/TH.hs @@ -171,6 +171,7 @@ mkConP tn' tvs' con' = do mkInfixC :: Name -> Name -> [Name] -> [Type] -> Q (Name, [Dec]) mkInfixC tn cn tvs fs = do + mf <- reifyFixity cn _a <- newName "_a" _b <- newName "_b" r <- sequence [ patSynSigD pat sig @@ -179,7 +180,10 @@ mkConP tn' tvs' con' = do implBidir [p| Pattern $(tupP [varP _a, varP _b]) |] ] - return (pat, r) + r' <- case mf of + Nothing -> return r + Just f -> return (InfixD f pat : r) + return (pat, r') where pat = mkName (':' : nameBase cn) sig = forallT @@ -258,6 +262,7 @@ mkConS tn' tvs' prev' next' tag' con' = do mkInfixC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) mkInfixC_pattern tn cn tvs fs build match = do + mf <- reifyFixity cn _a <- newName "_a" _b <- newName "_b" r <- sequence [ patSynSigD pat sig @@ -266,7 +271,10 @@ mkConS tn' tvs' prev' next' tag' con' = do (explBidir [clause [] (normalB (varE build)) []]) (parensP $ viewP (varE match) [p| Just $(tupP [varP _a, varP _b]) |]) ] - return (pat, r) + r' <- case mf of + Nothing -> return r + Just f -> return (InfixD f pat : r) + return (pat, r') where pat = mkName (':' : nameBase cn) sig = forallT From ac4e1ab261f079c1e2fbf4ff2332a049d0964b4c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 1 Jul 2020 18:17:46 +0200 Subject: [PATCH 270/316] update haddock --- src/Data/Array/Accelerate.hs | 11 +++++---- src/Data/Array/Accelerate/Language.hs | 30 ++++++++++++------------- src/Data/Array/Accelerate/Pattern/TH.hs | 2 +- src/Data/Array/Accelerate/Sugar/Elt.hs | 3 +++ 4 files changed, 24 insertions(+), 22 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index e3d9d22d0..f4c96191b 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -85,7 +85,7 @@ -- -- - For more information on LULESH: . -- --- <> +-- <> -- -- [/Starting a new project:/] -- @@ -604,11 +604,10 @@ arrayReshape = S.reshape -- in two-dimensional space: -- -- > data Point = Point_ Float Float --- > deriving (Show, Generic, Elt, IsTuple) +-- > deriving (Generic, Elt) -- --- Here we derive instances for both the 'Elt' class, so that this data type can --- be used within Accelerate scalar expressions, and the 'IsTuple' class, as --- this is a product type (contains multiple values). +-- Here we derive instance an instance of the 'Elt' class (via 'Generic'), +-- so that this data type can be used within scalar Accelerate expressions -- -- In order to access the individual fields of the data constructor from within -- an Accelerate expression, we define the following pattern synonym: @@ -631,7 +630,7 @@ arrayReshape = S.reshape -- use record syntax to generate field accessors, if we desire: -- -- > data SparseVector a = SparseVector_ (Vector Int) (Vector a) --- > deriving (Show, Generic, Arrays, IsAtuple) +-- > deriving (Generic, Arrays) -- > -- > pattern SparseVector :: Elt a => Acc (Vector Int) -> Acc (Vector a) -> Acc (SparseVector a) -- > pattern SparseVector { indices, values } = Pattern (indices, values) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 6ccd4cf97..f68aa6ca4 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -128,6 +128,7 @@ import Prelude ( ($), (.), -- >>> :seti -XTypeOperators -- >>> :seti -XViewPatterns -- >>> import Data.Array.Accelerate +-- >>> import Data.Array.Accelerate.Data.Maybe -- >>> import Data.Array.Accelerate.Interpreter -- >>> :{ -- let runExp :: Elt e => Exp e -> e @@ -270,7 +271,7 @@ replicate = Acc $$ applyAcc (Replicate $ sliceIndex @slix) -- For example, the following will generate a one-dimensional array -- (`Vector`) of three floating point numbers: -- --- >>> run $ generate (index1 3) (\_ -> 1.2) :: Vector Float +-- >>> run $ generate (I1 3) (\_ -> 1.2) :: Vector Float -- Vector (Z :. 3) [1.2,1.2,1.2] -- -- Or equivalently: @@ -280,7 +281,7 @@ replicate = Acc $$ applyAcc (Replicate $ sliceIndex @slix) -- -- The following will create a vector with the elements @[1..10]@: -- --- >>> run $ generate (index1 10) (\ix -> unindex1 ix + 1) :: Vector Int +-- >>> run $ generate (I1 10) (\(I1 i) -> i + 1) :: Vector Int -- Vector (Z :. 10) [1,2,3,4,5,6,7,8,9,10] -- -- [/NOTE:/] @@ -489,24 +490,23 @@ zipWith = Acc $$$ applyAcc (ZipWith (eltR @a) (eltR @b) (eltR @c)) -- => 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) +-- = map (\(T4 x _ _ _) -> 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 +-- let T4 mssx misx mcsx tsx = x +-- T4 mssy misy mcsy tsy = y -- in --- lift ( mssx `max` (mssy `max` (mcsx+misy)) --- , misx `max` (tsx+misy) --- , mcsy `max` (mcsx+tsy) --- , tsx+tsy --- ) +-- T4 (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) +-- in T4 y y y x -- :} -- -- >>> let vec = fromList (Z:.10) [-2,1,-3,4,-1,2,1,-5,4,0] :: Vector Int @@ -716,7 +716,7 @@ scanr1 f (Acc a) = Acc $ SmartAcc $ Scan RightToLeft (eltR @a) (unExpBinaryFunct -- let zeros = fill (constant (Z:.10)) 0 -- ones = fill (shape xs) 1 -- in --- permute (+) zeros (\ix -> index1 (xs!ix)) ones +-- permute (+) zeros (\ix -> Just_ (I1 (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 @@ -730,10 +730,10 @@ scanr1 f (Acc a) = Acc $ SmartAcc $ Scan RightToLeft (eltR @a) (unExpBinaryFunct -- >>> :{ -- let identity :: Num a => Exp Int -> Acc (Matrix a) -- identity n = --- let zeros = fill (index2 n n) 0 --- ones = fill (index1 n) 1 +-- let zeros = fill (I2 n n) 0 +-- ones = fill (I1 n) 1 -- in --- permute const zeros (\(unindex1 -> i) -> index2 i i) ones +-- permute const zeros (\(I1 i) -> Just_ (I2 i i)) ones -- :} -- -- >>> run $ identity 5 :: Matrix Int diff --git a/src/Data/Array/Accelerate/Pattern/TH.hs b/src/Data/Array/Accelerate/Pattern/TH.hs index cef2f3299..01e315817 100644 --- a/src/Data/Array/Accelerate/Pattern/TH.hs +++ b/src/Data/Array/Accelerate/Pattern/TH.hs @@ -37,7 +37,7 @@ import qualified Language.Haskell.TH as TH import GHC.Stack --- | As 'mkPattern, but for a list of types +-- | As 'mkPattern', but for a list of types -- mkPatterns :: [Name] -> DecsQ mkPatterns nms = concat <$> mapM mkPattern nms diff --git a/src/Data/Array/Accelerate/Sugar/Elt.hs b/src/Data/Array/Accelerate/Sugar/Elt.hs index 9e204595f..ddb000518 100644 --- a/src/Data/Array/Accelerate/Sugar/Elt.hs +++ b/src/Data/Array/Accelerate/Sugar/Elt.hs @@ -72,6 +72,9 @@ import GHC.Generics -- > data Option a = None | Just a -- > deriving (Generic, Elt) -- +-- See the function 'Data.Array.Accelerate.match' for details on how to use +-- sum types in embedded code. +-- class Elt a where -- | Type representation mapping, which explains how to convert a type -- from the surface type into the internal representation type consisting From b4feb46c706efd8845f85d17cbf136a1fcf0540e Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 2 Jul 2020 13:46:28 +0200 Subject: [PATCH 271/316] update Maybe and Either modules to use pattern matching --- src/Data/Array/Accelerate/Data/Either.hs | 49 ++++++++++-------------- src/Data/Array/Accelerate/Data/Maybe.hs | 44 ++++++++++++--------- src/Data/Array/Accelerate/Prelude.hs | 7 ++++ 3 files changed, 53 insertions(+), 47 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index 61a812107..b20816f24 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} @@ -32,7 +34,7 @@ module Data.Array.Accelerate.Data.Either ( ) where import Data.Array.Accelerate.AST.Idx -import Data.Array.Accelerate.Language hiding ( chr ) +import Data.Array.Accelerate.Language import Data.Array.Accelerate.Lift import Data.Array.Accelerate.Pattern.Either import Data.Array.Accelerate.Prelude @@ -55,28 +57,15 @@ import Data.Either ( Either(..) import Prelude ( (.), ($) ) --- | 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 +isLeft = not . isRight -- | 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 +isRight (Exp e) = Exp $ SmartExp $ (SmartExp $ Prj PairIdxLeft e) `Pair` SmartExp Nil -- | The 'fromLeft' function extracts the element out of the 'Left' constructor. -- If the argument was actually 'Right', you will get an undefined value @@ -97,9 +86,9 @@ fromRight (Exp e) = Exp $ SmartExp $ Prj PairIdxRight $ SmartExp $ Prj PairIdxRi -- 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)) - +either f g = match \case + Left_ x -> f x + Right_ x -> g x -- | Extract from the array of 'Either' all of the 'Left' elements, together -- with a segment descriptor indicating how many elements along each dimension @@ -121,26 +110,28 @@ rights es = compact (map isRight es) (map fromRight es) instance Elt a => Functor (Either a) where - fmap f = either left (right . f) + 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 -} False_ )) + (==) = match go + where + go (Left_ x) (Left_ y) = x == y + go (Right_ x) (Right_ y) = x == y + go _ _ = 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) )) + compare = match go + where + go (Left_ x) (Left_ y) = compare x y + go (Right_ x) (Right_ y) = compare x y + go Left_{} Right_{} = LT_ + go Right_{} Left_{} = GT_ #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 (Exp e) = Exp $ SmartExp $ Prj PairIdxLeft e - 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) = Left_ (lift a) diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index e7144a728..43516177c 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternSynonyms #-} @@ -32,7 +34,7 @@ module Data.Array.Accelerate.Data.Maybe ( ) where import Data.Array.Accelerate.AST.Idx -import Data.Array.Accelerate.Language hiding ( chr ) +import Data.Array.Accelerate.Language import Data.Array.Accelerate.Lift import Data.Array.Accelerate.Pattern.Maybe import Data.Array.Accelerate.Prelude @@ -52,25 +54,27 @@ import Data.Array.Accelerate.Data.Semigroup #endif import Data.Maybe ( Maybe(..) ) -import Prelude ( ($) ) +import Prelude ( ($), (.) ) -- | Returns 'True' if the argument is 'Nothing' -- isNothing :: Elt a => Exp (Maybe a) -> Exp Bool -isNothing x = tag x == 0 +isNothing = not . isJust -- | Returns 'True' if the argument is of the form @Just _@ -- isJust :: Elt a => Exp (Maybe a) -> Exp Bool -isJust x = tag x == 1 +isJust (Exp x) = Exp $ SmartExp $ (SmartExp $ Prj PairIdxLeft x) `Pair` SmartExp Nil -- | 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) +fromMaybe d = match \case + Nothing_ -> d + Just_ x -> x -- | The 'fromJust' function extracts the element out of the 'Just' constructor. -- If the argument was actually 'Nothing', you will get an undefined value @@ -85,8 +89,9 @@ fromJust (Exp x) = Exp $ SmartExp (PairIdxRight `Prj` SmartExp (PairIdxRight `Pr -- 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)) - +maybe d f = match \case + Nothing_ -> d + Just_ x -> f x -- | Extract from an array all of the 'Just' values, together with a segment -- descriptor indicating how many elements along each dimension were returned. @@ -98,17 +103,24 @@ justs xs = compact (map isJust xs) (map fromJust xs) instance Functor Maybe where - fmap f x = cond (isNothing x) Nothing_ (Just_ (f (fromJust x))) + fmap f = match \case + Nothing_ -> Nothing_ + Just_ x -> Just_ (f x) instance Eq a => Eq (Maybe a) where - ma == mb = cond (isNothing ma && isNothing mb) True_ - $ cond (isJust ma && isJust mb) (fromJust ma == fromJust mb) - $ False_ + (==) = match go + where + go Nothing_ Nothing_ = True_ + go (Just_ x) (Just_ y) = x == y + go _ _ = 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)) + compare = match go + where + go (Just_ x) (Just_ y) = compare x y + go Nothing_ Nothing_ = EQ_ + go Nothing_ Just_{} = LT_ + go Just_{} Nothing_{} = GT_ instance (Monoid (Exp a), Elt a) => Monoid (Exp (Maybe a)) where mempty = Nothing_ @@ -125,10 +137,6 @@ instance (Semigroup (Exp a), Elt a) => Semigroup (Exp (Maybe a)) where $ lift (Just (fromJust ma <> fromJust mb)) #endif - -tag :: Elt a => Exp (Maybe a) -> Exp Word8 -tag (Exp x) = Exp $ SmartExp $ Prj PairIdxLeft x - instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Maybe a) where type Plain (Maybe a) = Maybe (Plain a) lift Nothing = Nothing_ diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 405ee3e98..4076601e0 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -2250,6 +2250,13 @@ instance IfThenElse Acc where -- > -- > mkPattern ''Option -- +-- Which can then be used such as: +-- +-- > isNone :: Elt a => Exp (Option a) -> Exp Bool +-- > isNone = match \case +-- > None_ -> True_ +-- > Some_{} -> False_ +-- match :: Matching f => f -> f match f = mkFun (mkMatch f) id From 178f5f58d83a4396a8f7e387b7ff42f5ec3b2cee Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 2 Jul 2020 13:56:42 +0200 Subject: [PATCH 272/316] single-line pretty printing of case statements --- src/Data/Array/Accelerate/Pretty/Print.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index ff38957ea..beae52344 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -522,9 +522,9 @@ prettyCase -> [(TagR a, OpenExp env aenv b)] -> Adoc prettyCase env aenv alts - = vcat - $ map (\(n,t,e) -> t <+> indent (w-n) ("->" <+> e)) alts' + = flatAlt (vcat cases) (encloseSep "{ " " }" "; " cases) where + cases = map (\(n,t,e) -> t <+> flatAlt (indent (w-n) ("->" <+> e)) ("->" <+> e)) alts' w = maximum (map (\(n,_,_) -> n) alts') alts' = map (\(t,e) -> let (n,t') = ppT t e' = prettyOpenExp context0 env aenv e From 4cbe1b4df649b26ae15e6a01e9f1655675340c07 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 3 Jul 2020 12:25:27 +0200 Subject: [PATCH 273/316] =?UTF-8?q?hacks=20aren=E2=80=99t=20hacks=20once?= =?UTF-8?q?=20they=20are=20commented=20(right=3F)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Array/Accelerate/Data/Either.hs | 2 ++ src/Data/Array/Accelerate/Data/Maybe.hs | 2 ++ 2 files changed, 4 insertions(+) diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index b20816f24..7979dd597 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -66,6 +66,8 @@ isLeft = not . isRight -- isRight :: (Elt a, Elt b) => Exp (Either a b) -> Exp Bool isRight (Exp e) = Exp $ SmartExp $ (SmartExp $ Prj PairIdxLeft e) `Pair` SmartExp Nil + -- TLM: This is a sneaky hack because we know that the tag bits for Right + -- and True are identical. -- | The 'fromLeft' function extracts the element out of the 'Left' constructor. -- If the argument was actually 'Right', you will get an undefined value diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index 43516177c..be551f18a 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -66,6 +66,8 @@ isNothing = not . isJust -- isJust :: Elt a => Exp (Maybe a) -> Exp Bool isJust (Exp x) = Exp $ SmartExp $ (SmartExp $ Prj PairIdxLeft x) `Pair` SmartExp Nil + -- TLM: This is a sneaky hack because we know that the tag bits for Just + -- and True are identical. -- | The 'fromMaybe' function takes a default value and a 'Maybe' value. If the -- 'Maybe' is 'Nothing', the default value is returned; otherwise, it returns From 5d51f8890f9366d3dd1a2f4444bd7dfb118e9cb7 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 3 Jul 2020 17:56:47 +0200 Subject: [PATCH 274/316] pretty print the optimised AST --- src/Data/Array/Accelerate/Pretty.hs | 10 +++++----- src/Data/Array/Accelerate/Pretty/Print.hs | 12 ++++++++---- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index 00c314400..dde59525a 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -34,15 +34,15 @@ module Data.Array.Accelerate.Pretty ( ) where -import Data.Array.Accelerate.Smart ( Acc, Exp ) import Data.Array.Accelerate.AST hiding ( Acc, Exp ) -import Data.Array.Accelerate.Sugar.Array -import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Pretty.Graphviz import Data.Array.Accelerate.Pretty.Print hiding ( Keyword(..) ) +import Data.Array.Accelerate.Smart ( Acc, Exp ) +import Data.Array.Accelerate.Sugar.Array +import Data.Array.Accelerate.Sugar.Elt +import Data.Array.Accelerate.Trafo import Data.Array.Accelerate.Trafo.Delayed -import Data.Array.Accelerate.Trafo.Sharing -import Data.Array.Accelerate.Pretty.Graphviz import Data.Maybe import Data.Text.Prettyprint.Doc diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index beae52344..590c1058c 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -380,8 +380,7 @@ prettyOpenExp ctx env aenv exp = Nil -> "()" VecPack _ e -> ppF1 "vecPack" (ppE e) VecUnpack _ e -> ppF1 "vecUnpack" (ppE e) - Case x xs -> hang shiftwidth - $ vsep [ case_ <+> ppE x ctx <+> of_, prettyCase env aenv xs ] + Case x xs -> prettyCase env aenv x xs Cond p t e -> flatAlt multi single where p' = ppE p context0 @@ -519,13 +518,18 @@ prettyTuple ctx env aenv exp = case collect exp of prettyCase :: Val env -> Val aenv + -> OpenExp env aenv a -> [(TagR a, OpenExp env aenv b)] -> Adoc -prettyCase env aenv alts - = flatAlt (vcat cases) (encloseSep "{ " " }" "; " cases) +prettyCase env aenv x alts + = hang shiftwidth + $ vsep [ case_ <+> x' <+> of_ + , flatAlt (vcat cases) (encloseSep "{ " " }" "; " cases) + ] where cases = map (\(n,t,e) -> t <+> flatAlt (indent (w-n) ("->" <+> e)) ("->" <+> e)) alts' w = maximum (map (\(n,_,_) -> n) alts') + x' = prettyOpenExp context0 env aenv x alts' = map (\(t,e) -> let (n,t') = ppT t e' = prettyOpenExp context0 env aenv e in (n, t', e')) alts From 20730f14a785a0bf13fa71652a3ef7817149becf Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 5 Jul 2020 12:02:46 +0200 Subject: [PATCH 275/316] generate nested case statements --- src/Data/Array/Accelerate/AST.hs | 14 +-- src/Data/Array/Accelerate/Analysis/Hash.hs | 24 ++--- src/Data/Array/Accelerate/Error.hs | 3 +- src/Data/Array/Accelerate/Interpreter.hs | 21 ++-- src/Data/Array/Accelerate/Prelude.hs | 5 +- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 2 +- src/Data/Array/Accelerate/Pretty/Print.hs | 32 ++---- src/Data/Array/Accelerate/Trafo/Fusion.hs | 2 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 98 +++++++++++++++++-- src/Data/Array/Accelerate/Trafo/Shrink.hs | 10 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 8 +- .../Array/Accelerate/Trafo/Substitution.hs | 8 +- 12 files changed, 152 insertions(+), 75 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index b535db648..4d6d04fa3 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -566,8 +566,9 @@ data OpenExp env aenv t where -> OpenExp env aenv sh -- Case statement - Case :: OpenExp env aenv a - -> [(TagR a, OpenExp env aenv b)] + Case :: OpenExp env aenv TAG + -> [(TAG, OpenExp env aenv b)] -- list of equations + -> Maybe (OpenExp env aenv b) -- default case -> OpenExp env aenv b -- Conditional expression (non-strict in 2nd and 3rd argument) @@ -800,8 +801,9 @@ expType = \case IndexFull si _ _ -> shapeType $ sliceDomainR si ToIndex{} -> TupRsingle scalarTypeInt FromIndex shr _ _ -> shapeType shr - Case _ ((_,e):_) -> expType e - Case _ [] -> internalError "empty case encountered" + Case _ ((_,e):_) _ -> expType e + Case _ [] (Just e) -> expType e + Case{} -> internalError "empty case encountered" Cond _ e _ -> expType e While _ (Lam lhs _) _ -> lhsToTupR lhs While{} -> error "What's the matter, you're running in the shadows" @@ -1054,7 +1056,7 @@ rnfOpenExp topExp = IndexFull slice slix sl -> rnfSliceIndex slice `seq` rnfE slix `seq` rnfE sl ToIndex shr sh ix -> rnfShapeR shr `seq` rnfE sh `seq` rnfE ix FromIndex shr sh ix -> rnfShapeR shr `seq` rnfE sh `seq` rnfE ix - Case e rhs -> rnfE e `seq` rnfList (\(t,c) -> rnfTag t `seq` rnfE c) rhs + Case e rhs def -> rnfE e `seq` rnfList (\(t,c) -> t `seq` rnfE c) rhs `seq` rnfMaybe rnfE def 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 @@ -1263,7 +1265,7 @@ liftOpenExp pexp = IndexFull slice slix sl -> [|| IndexFull $$(liftSliceIndex slice) $$(liftE slix) $$(liftE sl) ||] ToIndex shr sh ix -> [|| ToIndex $$(liftShapeR shr) $$(liftE sh) $$(liftE ix) ||] FromIndex shr sh ix -> [|| FromIndex $$(liftShapeR shr) $$(liftE sh) $$(liftE ix) ||] - Case p rhs -> [|| Case $$(liftE p) $$(liftList (\(t,c) -> [|| ($$(liftTag t), $$(liftE c)) ||]) rhs) ||] + Case p rhs def -> [|| Case $$(liftE p) $$(liftList (\(t,c) -> [|| (t, $$(liftE c)) ||]) rhs) $$(liftMaybe liftE def) ||] 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) ||] diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index fb5e00565..6c7d74e24 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -44,7 +44,6 @@ import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Representation.Shape import Data.Array.Accelerate.Representation.Slice import Data.Array.Accelerate.Representation.Stencil -import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type import Data.Primitive.Vec @@ -155,10 +154,6 @@ encodePreOpenAcc options encodeAcc pacc = travD LeftToRight = intHost $(hashQ "L") travD RightToLeft = intHost $(hashQ "R") - travMaybe :: (a -> Builder) -> Maybe a -> Builder - travMaybe _ Nothing = intHost $(hashQ "Nothing") - travMaybe f (Just x) = intHost $(hashQ "Just") <> f x - deep :: Builder -> Builder deep | perfect options = id | otherwise = const mempty @@ -189,9 +184,9 @@ encodePreOpenAcc options encodeAcc pacc = Slice spec a ix -> intHost $(hashQ "Slice") <> deepE 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 <> travMaybe travE e <> travA a - FoldSeg _ f e a s -> intHost $(hashQ "FoldSeg") <> travF f <> travMaybe travE e <> travA a <> travA s - Scan d f e a -> intHost $(hashQ "Scan") <> travD d <> travF f <> travMaybe travE e <> travA a + Fold f e a -> intHost $(hashQ "Fold") <> travF f <> encodeMaybe travE e <> travA a + FoldSeg _ f e a s -> intHost $(hashQ "FoldSeg") <> travF f <> encodeMaybe travE e <> travA a <> travA s + Scan d f e a -> intHost $(hashQ "Scan") <> travD d <> travF f <> encodeMaybe travE e <> travA a Scan' d f e a -> intHost $(hashQ "Scan'") <> travD d <> travF f <> travE e <> travA a Permute f1 a1 f2 a2 -> intHost $(hashQ "Permute") <> travF f1 <> travA a1 <> travF f2 <> travA a2 Stencil s _ f b a -> intHost $(hashQ "Stencil") <> travF f <> encodeBoundary (stencilEltR s) b <> travA a @@ -329,7 +324,7 @@ encodeOpenExp exp = 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 - Case e rhs -> intHost $(hashQ "Case") <> travE e <> mconcat [ encodeTag t <> travE c | (t,c) <- rhs ] + Case e rhs def -> intHost $(hashQ "Case") <> travE e <> mconcat [ word8 t <> travE c | (t,c) <- rhs ] <> encodeMaybe travE def 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 @@ -344,13 +339,6 @@ encodeOpenExp exp = encodeArrayVar :: ArrayVar aenv a -> Builder encodeArrayVar (Var repr v) = encodeArrayType repr <> encodeIdx v -encodeTag :: TagR t -> Builder -encodeTag TagRunit = intHost $(hashQ "TagRunit") -encodeTag (TagRsingle t) = intHost $(hashQ "TagRsingle") <> encodeScalarType t -encodeTag (TagRundef t) = intHost $(hashQ "TagRundef") <> encodeScalarType t -encodeTag (TagRtag t a) = intHost $(hashQ "TagRtag") <> word8 t <> encodeTag a -encodeTag (TagRpair ta tb) = intHost $(hashQ "TagRpair") <> encodeTag ta <> encodeTag tb - {-# INLINEABLE encodeOpenFun #-} encodeOpenFun :: OpenFun env aenv f @@ -510,3 +498,7 @@ encodeFloatingType TypeHalf{} = intHost $(hashQ "Half") encodeFloatingType TypeFloat{} = intHost $(hashQ "Float") encodeFloatingType TypeDouble{} = intHost $(hashQ "Double") +encodeMaybe :: (a -> Builder) -> Maybe a -> Builder +encodeMaybe _ Nothing = intHost $(hashQ "Nothing") +encodeMaybe f (Just x) = intHost $(hashQ "Just") <> f x + diff --git a/src/Data/Array/Accelerate/Error.hs b/src/Data/Array/Accelerate/Error.hs index 466caa248..ec6de19d8 100644 --- a/src/Data/Array/Accelerate/Error.hs +++ b/src/Data/Array/Accelerate/Error.hs @@ -109,7 +109,8 @@ ppCallStack = intercalate "\n" . ppLines ppLines cs = case getCallStack cs of [] -> [] - st -> "CallStack (from HasCallStack):" + st -> "" + : "CallStack (from HasCallStack):" : map ((" " ++) . ppCallSite) st ppCallSite (f, loc) = f ++ ": " ++ ppSrcLoc loc diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 56b9480ca..592102181 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -955,22 +955,17 @@ evalOpenExp pexp env aenv = ToIndex shr sh ix -> toIndex shr (evalE sh) (evalE ix) FromIndex shr sh ix -> fromIndex shr (evalE sh) (evalE ix) - Case e rhs -> evalE (caseof (evalE e) rhs) + Case e rhs def -> evalE (caseof (evalE e) rhs) where - caseof :: a -> [(TagR a, OpenExp env aenv b)] -> OpenExp env aenv b - caseof v = go + caseof :: TAG -> [(TAG, OpenExp env aenv t)] -> OpenExp env aenv t + caseof tag = go where - go ((t,cont):cs) - | eqTag t v = cont + go ((t,c):cs) + | tag == t = c | otherwise = go cs - go [] = internalError "unmatched case" - - eqTag :: TagR a -> a -> Bool - eqTag TagRunit () = True - eqTag TagRsingle{} _ = True - eqTag TagRundef{} _ = True - eqTag (TagRtag tag aR) (t,a) = tag == t && eqTag aR a - eqTag (TagRpair aR bR) (a,b) = eqTag aR a && eqTag bR b + go [] + | Just d <- def = d + | otherwise = internalError "unmatched case" Cond c t e | toBool (evalE c) -> evalE t diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 4076601e0..8fbe92db9 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -138,9 +138,10 @@ import Data.Array.Accelerate.Classes.Ord import Data.Array.Accelerate.Data.Bits import Control.Lens ( Lens', (&), (^.), (.~), (+~), (-~), lens, over ) -import GHC.Base ( Constraint ) import Prelude ( (.), ($), Maybe(..), const, id, flip ) +import GHC.Base ( Constraint ) + -- $setup -- >>> :seti -XFlexibleContexts @@ -2291,7 +2292,7 @@ instance (Elt e, Matching r) => Matching (Exp e -> r) where -- If there is only a single alternative, we can elide the case -- statement at this point. This can occur when pattern matching on - -- product types + -- product types. _ -> case rhs of [(_,r)] -> Exp r _ -> Exp (SmartExp (Case p rhs)) diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index 88907aa8e..b8e2dc1ee 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -540,7 +540,7 @@ fvOpenExp env aenv = fv fv (FromIndex _ sh ix) = concat [ fv sh, fv ix ] fv (ShapeSize _ sh) = fv sh fv Foreign{} = [] - fv (Case e rhs) = concat [ fv e, concat [ fv c | (_,c) <- rhs ] ] + fv (Case e rhs def) = concat [ fv e, concat [ fv c | (_,c) <- rhs ], maybe [] fv def ] 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 diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 590c1058c..9b49bc77b 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -380,7 +380,7 @@ prettyOpenExp ctx env aenv exp = Nil -> "()" VecPack _ e -> ppF1 "vecPack" (ppE e) VecUnpack _ e -> ppF1 "vecUnpack" (ppE e) - Case x xs -> prettyCase env aenv x xs + Case x xs d -> prettyCase env aenv x xs d Cond p t e -> flatAlt multi single where p' = ppE p context0 @@ -519,32 +519,20 @@ prettyCase :: Val env -> Val aenv -> OpenExp env aenv a - -> [(TagR a, OpenExp env aenv b)] + -> [(TAG, OpenExp env aenv b)] + -> Maybe (OpenExp env aenv b) -> Adoc -prettyCase env aenv x alts +prettyCase env aenv x xs def = hang shiftwidth $ vsep [ case_ <+> x' <+> of_ - , flatAlt (vcat cases) (encloseSep "{ " " }" "; " cases) + , flatAlt (vcat xs') (encloseSep "{ " " }" "; " xs') ] where - cases = map (\(n,t,e) -> t <+> flatAlt (indent (w-n) ("->" <+> e)) ("->" <+> e)) alts' - w = maximum (map (\(n,_,_) -> n) alts') - x' = prettyOpenExp context0 env aenv x - alts' = map (\(t,e) -> let (n,t') = ppT t - e' = prettyOpenExp context0 env aenv e - in (n, t', e')) alts - - ppT :: TagR s -> (Int, Adoc) - ppT tag = let s = go tag - n = length s - in (2*n, encloseSep "" "#" "." s) - where - go :: TagR s -> [Adoc] - go TagRunit = [] - go TagRsingle{} = [] - go TagRundef{} = [pretty '.'] - go (TagRtag t r) = pretty t : go r - go (TagRpair ta tb) = go ta ++ go tb + x' = prettyOpenExp context0 env aenv x + xs' = map (\(t,e) -> pretty t <+> "->" <+> prettyOpenExp context0 env aenv e) xs + ++ case def of + Nothing -> [] + Just d -> ["_" <+> "->" <+> prettyOpenExp context0 env aenv d] {- diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 55d81d094..37ef0abf1 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -1448,7 +1448,7 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en IndexFull x ix sl -> IndexFull x (cvtE ix) (cvtE sl) ToIndex shR' sh ix -> ToIndex shR' (cvtE sh) (cvtE ix) FromIndex shR' sh i -> FromIndex shR' (cvtE sh) (cvtE i) - Case e rhs -> Case (cvtE e) (over (mapped . _2) cvtE rhs) + Case e rhs def -> Case (cvtE e) (over (mapped . _2) cvtE rhs) (fmap cvtE def) Cond p t e -> Cond (cvtE p) (cvtE t) (cvtE e) PrimConst c -> PrimConst c PrimApp g x -> PrimApp g (cvtE x) diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 35a1c0b9e..23ebc0917 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -49,32 +49,35 @@ import Data.Array.Accelerate.AST.Environment import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.AST.LeftHandSide import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Debug.Flags as Debug import Data.Array.Accelerate.Debug.Trace as Debug import Data.Array.Accelerate.Error import Data.Array.Accelerate.Representation.Array ( Array, ArraysR, ArrayR(..), showArraysR ) import Data.Array.Accelerate.Representation.Shape hiding ( zip ) import Data.Array.Accelerate.Representation.Stencil +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Smart as Smart hiding ( StencilR ) import Data.Array.Accelerate.Sugar.Array hiding ( Array, ArraysR, (!!) ) import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Trafo.Config -import Data.Array.Accelerate.Trafo.Var import Data.Array.Accelerate.Trafo.Substitution -import Data.Array.Accelerate.Analysis.Match +import Data.Array.Accelerate.Trafo.Var import Data.Array.Accelerate.Type import Data.BitSet ( (\\), member ) import qualified Data.Array.Accelerate.AST as AST -import qualified Data.Array.Accelerate.Sugar.Array as Sugar import qualified Data.Array.Accelerate.Representation.Stencil as R +import qualified Data.Array.Accelerate.Sugar.Array as Sugar import Control.Applicative hiding ( Const ) -import Control.Lens ( over, mapped, _2 ) +import Control.Lens ( over, mapped, _1, _2 ) import Control.Monad.Fix +import Data.Function ( on ) import Data.Hashable import Data.List ( elemIndex, findIndex, groupBy, intercalate, partition ) import Data.Maybe +import Data.Monoid ( Any(..) ) import System.IO.Unsafe ( unsafePerformIO ) import System.Mem.StableName import Text.Printf @@ -763,7 +766,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp VecUnpack vec e -> AST.VecUnpack vec (cvt e) ToIndex shr sh ix -> AST.ToIndex shr (cvt sh) (cvt ix) FromIndex shr sh e -> AST.FromIndex shr (cvt sh) (cvt e) - Case e rhs -> AST.Case (cvt e) (over (mapped . _2) cvt rhs) + Case e rhs -> cvtCase (cvt e) (over (mapped . _2) cvt rhs) Cond e1 e2 e3 -> AST.Cond (cvt e1) (cvt e2) (cvt e3) While tp p it i -> AST.While (cvtFun1 tp p) (cvtFun1 tp it) (cvt i) PrimConst c -> AST.PrimConst c @@ -780,7 +783,7 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp cvtPrj PairIdxRight (AST.Pair _ b) = b cvtPrj ix a | DeclareVars lhs _ value <- declareVars $ AST.expType a - = AST.Let lhs a $ cvtPrj ix $ expVars $ value weakenId + = AST.Let lhs a (cvtPrj ix (expVars (value weakenId))) cvtA :: HasCallStack => ScopedAcc a -> AST.OpenAcc aenv a cvtA = convertSharingAcc config alyt aenv @@ -807,6 +810,89 @@ convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp AST.Let lhs bnd body -> AST.Let lhs bnd (cvtPrimFun f body) x -> AST.PrimApp f x + -- Convert the flat list of equations into nested case statement + -- directly on the tag variables. + -- + cvtCase :: HasCallStack => AST.OpenExp env' aenv' a -> [(TagR a, AST.OpenExp env' aenv' b)] -> AST.OpenExp env' aenv' b + cvtCase s es + | AST.Pair{} <- s + = nested s es + | DeclareVars lhs _ value <- declareVars (AST.expType s) + = AST.Let lhs s $ nested (expVars (value weakenId)) (over (mapped . _2) (weakenE (weakenWithLHS lhs)) es) + where + nested :: HasCallStack => AST.OpenExp env' aenv' a -> [(TagR a, AST.OpenExp env' aenv' b)] -> AST.OpenExp env' aenv' b + nested _ [(_,r)] = r + nested s rs = + let groups = groupBy (eqT `on` fst) rs + tags = map (firstT . fst . head) groups + e = prjT (fst (head rs)) s + rhs = map (nested s . map (over _1 ignore)) groups + in + AST.Case e (zip tags rhs) Nothing + + -- Extract the variable representing this particular tag from the + -- scrutinee. This is safe because we let-bind the argument first. + prjT :: TagR a -> AST.OpenExp env' aenv' a -> AST.OpenExp env' aenv' TAG + prjT = fromJust $$ go + where + go :: TagR a -> AST.OpenExp env' aenv' a -> Maybe (AST.OpenExp env' aenv' TAG) + go TagRtag{} (AST.Pair l _) = Just l + go (TagRpair ta tb) (AST.Pair l r) = + case go ta l of + Just t -> Just t + Nothing -> go tb r + go _ _ = Nothing + + -- Equality up to the first constructor tag encountered + eqT :: TagR a -> TagR a -> Bool + eqT a b = snd $ go a b + where + go :: TagR a -> TagR a -> (Any, Bool) + go TagRunit TagRunit = no True + go TagRsingle{} TagRsingle{} = no True + go TagRundef{} TagRundef{} = no True + go (TagRtag v1 _) (TagRtag v2 _) = yes (v1 == v2) + go (TagRpair a1 b1) (TagRpair a2 b2) = + let (Any r, s) = go a1 a2 + in case r of + True -> yes s + False -> go b1 b2 + go _ _ = no False + + firstT :: TagR a -> TAG + firstT = fromJust . go + where + go :: TagR a -> Maybe TAG + go (TagRtag v _) = Just v + go (TagRpair a b) = + case go a of + Just t -> Just t + Nothing -> go b + go _ = Nothing + + -- Replace the first constructor tag encountered with a regular + -- scalar tag, so that that tag will be ignored in the recursive + -- case. + ignore = snd . go + where + go :: TagR a -> (Any, TagR a) + go TagRunit = no $ TagRunit + go (TagRsingle t) = no $ TagRsingle t + go (TagRundef t) = no $ TagRundef t + go (TagRtag _ a) = yes $ TagRpair (TagRundef scalarType) a + go (TagRpair a1 a2) = + let (Any r, a1') = go a1 + in case r of + True -> yes $ TagRpair a1' a2 + False -> TagRpair a1' <$> go a2 + + yes :: x -> (Any, x) + yes e = (Any True, e) + + no :: x -> (Any, x) + no = pure + + -- | Convert a unary functions -- convertSharingFun1 diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index fddb34db4..856be9a67 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -299,7 +299,7 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE IndexFull x ix sl -> IndexFull x <$> shrinkE ix <*> shrinkE sl ToIndex shr sh ix -> ToIndex shr <$> shrinkE sh <*> shrinkE ix FromIndex shr sh i -> FromIndex shr <$> shrinkE sh <*> shrinkE i - Case e rhs -> Case <$> shrinkE e <*> sequenceA [ (t,) <$> shrinkE c | (t,c) <- rhs ] + Case e rhs def -> Case <$> shrinkE e <*> sequenceA [ (t,) <$> shrinkE c | (t,c) <- rhs ] <*> shrinkMaybeE def 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) @@ -314,6 +314,10 @@ shrinkExp = Stats.substitution "shrinkE" . first getAny . shrinkE shrinkF :: HasCallStack => OpenFun env aenv t -> (Any, OpenFun env aenv t) shrinkF = first Any . shrinkFun + shrinkMaybeE :: HasCallStack => Maybe (OpenExp env aenv t) -> (Any, Maybe (OpenExp env aenv t)) + shrinkMaybeE Nothing = pure Nothing + shrinkMaybeE (Just e) = Just <$> shrinkE e + first :: (a -> a') -> (a,b) -> (a',b) first f (x,y) = (f x, y) @@ -496,7 +500,7 @@ usesOfExp range = countE IndexFull _ ix sl -> countE ix <> countE sl FromIndex _ sh i -> countE sh <> countE i ToIndex _ sh e -> countE sh <> countE e - Case e rhs -> countE e <> mconcat [ countE c | (_,c) <- rhs ] + Case e rhs def -> countE e <> mconcat [ countE c | (_,c) <- rhs ] <> maybe (Finite 0) countE def Cond p t e -> countE p <> countE t <> countE e While p f x -> countE x <> loopCount (usesOfFun range p) <> loopCount (usesOfFun range f) PrimConst _ -> Finite 0 @@ -582,7 +586,7 @@ usesOfPreAcc withShape countAcc idx = count IndexFull _ ix sl -> countE ix + countE sl ToIndex _ sh ix -> countE sh + countE ix FromIndex _ sh i -> countE sh + countE i - Case e rhs -> countE e + sum [ countE c | (_,c) <- rhs ] + Case e rhs def -> countE e + sum [ countE c | (_,c) <- rhs ] + maybe 0 countE def Cond p t e -> countE p + countE t + countE e While p f x -> countF p + countF f + countE x PrimConst _ -> 0 diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index 368d83fb5..343f3609d 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -226,7 +226,7 @@ simplifyOpenExp env = first getAny . cvtE IndexFull x ix sl -> IndexFull x <$> cvtE ix <*> cvtE sl ToIndex shr sh ix -> toIndex shr (cvtE sh) (cvtE ix) FromIndex shr sh ix -> fromIndex shr (cvtE sh) (cvtE ix) - Case e rhs -> Case <$> cvtE e <*> sequenceA [ (t,) <$> cvtE c | (t,c) <- rhs ] + Case e rhs def -> Case <$> cvtE e <*> sequenceA [ (t,) <$> cvtE c | (t,c) <- rhs ] <*> cvtMaybeE def Cond p t e -> cond (cvtE p) (cvtE t) (cvtE e) PrimConst c -> pure $ PrimConst c PrimApp f x -> (u<>v, fx) @@ -247,6 +247,10 @@ simplifyOpenExp env = first getAny . cvtE cvtF :: Gamma env' env' aenv -> OpenFun env' aenv f -> (Any, OpenFun env' aenv f) cvtF env' = first Any . simplifyOpenFun env' + cvtMaybeE :: Maybe (OpenExp env aenv e') -> (Any, Maybe (OpenExp env aenv e')) + cvtMaybeE Nothing = pure Nothing + cvtMaybeE (Just e) = Just <$> cvtE e + cvtLet :: Gamma env' env' aenv -> ELeftHandSide bnd env' env'' -> OpenExp env' aenv bnd @@ -511,7 +515,7 @@ summariseOpenExp = (terms +~ 1) . goE 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 - Case e rhs -> travE e +++ mconcat [ travE c | (_,c) <- rhs ] + Case e rhs def -> travE e +++ mconcat [ travE c | (_,c) <- rhs ] +++ maybe zero travE def Cond p t e -> travE p +++ travE t +++ travE e While p f x -> travF p +++ travF f +++ travE x PrimConst c -> travC c diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index a19eb0577..6359615ec 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -162,7 +162,7 @@ inlineVars lhsBound expr bound IndexFull si e1 e2 -> IndexFull si <$> travE e1 <*> travE e2 ToIndex shr e1 e2 -> ToIndex shr <$> travE e1 <*> travE e2 FromIndex shr e1 e2 -> FromIndex shr <$> travE e1 <*> travE e2 - Case e1 rhs -> Case <$> travE e1 <*> mapM (\(t,c) -> (t,) <$> travE c) rhs + Case e1 rhs def -> Case <$> travE e1 <*> mapM (\(t,c) -> (t,) <$> travE c) rhs <*> travMaybeE def Cond e1 e2 e3 -> Cond <$> travE e1 <*> travE e2 <*> travE e3 While f1 f2 e1 -> While <$> travF f1 <*> travF f2 <*> travE e1 Const t c -> Just $ Const t c @@ -182,6 +182,10 @@ inlineVars lhsBound expr bound travF :: OpenFun env1 aenv s -> Maybe (OpenFun env2 aenv s) travF = substituteF k1 k2 vars + travMaybeE :: Maybe (OpenExp env1 aenv s) -> Maybe (Maybe (OpenExp env2 aenv s)) + travMaybeE Nothing = pure Nothing + travMaybeE (Just x) = Just <$> travE x + substituteF :: forall env1 env2 t. env1 :?> env2 -> env :> env2 @@ -559,7 +563,7 @@ rebuildOpenExp v av@(ReindexAvar reindex) exp = IndexFull x ix sl -> IndexFull x <$> rebuildOpenExp v av ix <*> rebuildOpenExp v av sl ToIndex shr sh ix -> ToIndex shr <$> rebuildOpenExp v av sh <*> rebuildOpenExp v av ix FromIndex shr sh ix -> FromIndex shr <$> rebuildOpenExp v av sh <*> rebuildOpenExp v av ix - Case e rhs -> Case <$> rebuildOpenExp v av e <*> sequenceA [ (t,) <$> rebuildOpenExp v av c | (t,c) <- rhs ] + Case e rhs def -> Case <$> rebuildOpenExp v av e <*> sequenceA [ (t,) <$> rebuildOpenExp v av c | (t,c) <- rhs ] <*> rebuildMaybeExp v av def Cond p t e -> Cond <$> rebuildOpenExp v av p <*> rebuildOpenExp v av t <*> rebuildOpenExp v av e While p f x -> While <$> rebuildFun v av p <*> rebuildFun v av f <*> rebuildOpenExp v av x PrimApp f x -> PrimApp f <$> rebuildOpenExp v av x From f3b9bc52566f5a4c835079c4bde4fd8f55d07b3b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sun, 5 Jul 2020 20:50:09 +0200 Subject: [PATCH 276/316] add simplifications for case statements --- src/Data/Array/Accelerate/Debug/Stats.hs | 18 +++++++--- src/Data/Array/Accelerate/Prelude.hs | 2 ++ src/Data/Array/Accelerate/Trafo/Simplify.hs | 40 ++++++++++++++++++++- 3 files changed, 55 insertions(+), 5 deletions(-) diff --git a/src/Data/Array/Accelerate/Debug/Stats.hs b/src/Data/Array/Accelerate/Debug/Stats.hs index 1cd284d99..bd3e5ef36 100644 --- a/src/Data/Array/Accelerate/Debug/Stats.hs +++ b/src/Data/Array/Accelerate/Debug/Stats.hs @@ -18,7 +18,7 @@ module Data.Array.Accelerate.Debug.Stats ( simplCount, resetSimplCount, dumpSimplStats, - inline, ruleFired, knownBranch, betaReduce, substitution, simplifierDone, fusionDone, + inline, ruleFired, knownBranch, caseElim, caseDefault, betaReduce, substitution, simplifierDone, fusionDone, ) where @@ -42,10 +42,12 @@ import qualified Data.Text.Prettyprint.Doc as Pretty -- Recording statistics -- -------------------- -ruleFired, inline, knownBranch, betaReduce, substitution :: Text -> a -> a +ruleFired, inline, knownBranch, caseElim, caseDefault, betaReduce, substitution :: Text -> a -> a inline = annotate Inline ruleFired = annotate RuleFired knownBranch = annotate KnownBranch +caseElim = annotate CaseElim +caseDefault = annotate CaseDefault betaReduce = annotate BetaReduce substitution = annotate Substitution @@ -166,6 +168,8 @@ data Tick = Inline Id | RuleFired Id | KnownBranch Id + | CaseElim Id + | CaseDefault Id | BetaReduce Id | Substitution Id @@ -202,8 +206,10 @@ tickToTag :: Tick -> Int tickToTag Inline{} = 0 tickToTag RuleFired{} = 1 tickToTag KnownBranch{} = 2 -tickToTag BetaReduce{} = 3 -tickToTag Substitution{} = 4 +tickToTag CaseElim{} = 3 +tickToTag CaseDefault{} = 4 +tickToTag BetaReduce{} = 5 +tickToTag Substitution{} = 6 tickToTag SimplifierDone = 99 tickToTag FusionDone = 100 @@ -211,6 +217,8 @@ tickToStr :: Tick -> Doc tickToStr Inline{} = "Inline" tickToStr RuleFired{} = "RuleFired" tickToStr KnownBranch{} = "KnownBranch" +tickToStr CaseElim{} = "CaseElim" +tickToStr CaseDefault{} = "CaseDefault" tickToStr BetaReduce{} = "BetaReduce" tickToStr Substitution{} = "Substitution" tickToStr SimplifierDone = "SimplifierDone" @@ -220,6 +228,8 @@ pprTickCtx :: Tick -> Doc pprTickCtx (Inline v) = pprId v pprTickCtx (RuleFired v) = pprId v pprTickCtx (KnownBranch v) = pprId v +pprTickCtx (CaseElim v) = pprId v +pprTickCtx (CaseDefault v) = pprId v pprTickCtx (BetaReduce v) = pprId v pprTickCtx (Substitution v) = pprId v pprTickCtx SimplifierDone = mempty diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 8fbe92db9..3a4744a14 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -2258,6 +2258,8 @@ instance IfThenElse Acc where -- > None_ -> True_ -- > Some_{} -> False_ -- +-- @since 1.4.0.0 +-- match :: Matching f => f -> f match f = mkFun (mkMatch f) id diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index 343f3609d..79b341257 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -34,10 +34,12 @@ import Data.Array.Accelerate.AST.Environment import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.AST.LeftHandSide import Data.Array.Accelerate.AST.Var +import Data.Array.Accelerate.Analysis.Hash import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Error import Data.Array.Accelerate.Representation.Array ( Array, ArrayR(..) ) import Data.Array.Accelerate.Representation.Shape ( ShapeR(..), shapeToList ) +import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Trafo.Algebra import Data.Array.Accelerate.Trafo.Environment import Data.Array.Accelerate.Trafo.Shrink @@ -50,10 +52,12 @@ import qualified Data.Array.Accelerate.Debug.Trace as Debug import Control.Applicative hiding ( Const ) import Control.Lens hiding ( Const, ix ) +import Data.List ( partition ) import Data.Maybe import Data.Monoid import Text.Printf import Prelude hiding ( exp, iterate ) +import qualified Data.Map.Strict as Map import GHC.Stack @@ -226,7 +230,7 @@ simplifyOpenExp env = first getAny . cvtE IndexFull x ix sl -> IndexFull x <$> cvtE ix <*> cvtE sl ToIndex shr sh ix -> toIndex shr (cvtE sh) (cvtE ix) FromIndex shr sh ix -> fromIndex shr (cvtE sh) (cvtE ix) - Case e rhs def -> Case <$> cvtE e <*> sequenceA [ (t,) <$> cvtE c | (t,c) <- rhs ] <*> cvtMaybeE def + Case e rhs def -> caseof (cvtE e) (sequenceA [ (t,) <$> cvtE c | (t,c) <- rhs ]) (cvtMaybeE def) Cond p t e -> cond (cvtE p) (cvtE t) (cvtE e) PrimConst c -> pure $ PrimConst c PrimApp f x -> (u<>v, fx) @@ -277,6 +281,40 @@ simplifyOpenExp env = first getAny . cvtE | Just Refl <- matchOpenExp t' e' = Stats.knownBranch "redundant" (yes e') | otherwise = Cond <$> p <*> t <*> e + caseof :: (Any, OpenExp env aenv TAG) + -> (Any, [(TAG, OpenExp env aenv b)]) + -> (Any, Maybe (OpenExp env aenv b)) + -> (Any, OpenExp env aenv b) + caseof x@(_,x') xs@(_,xs') md@(_,md') + | Const _ t <- x' + = Stats.caseElim "known" (yes (fromJust $ lookup t xs')) + | Just d <- md' + , [] <- xs' + = Stats.caseElim "redundant" (yes d) + | Just d <- md' + , [(_,(_,u))] <- us + , Just Refl <- matchOpenExp d u + = Stats.caseDefault "merge" $ yes (Case x' (map snd vs) (Just u)) + | Nothing <- md' + , [] <- vs + , [(_,(_,u))] <- us + = Stats.caseElim "overlap" (yes u) + | Nothing <- md' + , [(_,(_,u))] <- us + = Stats.caseDefault "introduction" $ yes (Case x' (map snd vs) (Just u)) + | otherwise + = Case <$> x <*> xs <*> md + where + (us,vs) = partition (\(n,_) -> n > 1) + $ Map.elems + . Map.fromListWith merge + $ [ (hashOpenExp e, (1,(t, e))) | (t,e) <- xs' ] + + merge :: (Int, (TAG, OpenExp env aenv b)) -> (Int, (TAG, OpenExp env aenv b)) -> (Int, (TAG, OpenExp env aenv b)) + merge (n,(_,a)) (m,(_,b)) + = internalCheck "hashOpenExp/collision" (maybe False (const True) (matchOpenExp a b)) + $ (n+m, (0xff, a)) + -- Shape manipulations -- shape :: ArrayVar aenv (Array sh t) -> (Any, OpenExp env aenv sh) From 3edfeda1c15e63974ac3c297de6a604970d77cdf Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 6 Jul 2020 10:27:34 +0200 Subject: [PATCH 277/316] improve error message on embedded pattern matches --- src/Data/Array/Accelerate.hs | 8 +++- src/Data/Array/Accelerate/Pattern/TH.hs | 64 ++++++++++++++++--------- 2 files changed, 47 insertions(+), 25 deletions(-) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index f4c96191b..87ff15ae2 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -403,8 +403,8 @@ module Data.Array.Accelerate ( -- --------------------------------------------------------------------------- -- * Useful re-exports - (.), ($), error, undefined, const, otherwise, - Show, Generic, + (.), ($), (&), error, undefined, const, otherwise, + Show, Generic, HasCallStack, -- --------------------------------------------------------------------------- -- Types @@ -436,8 +436,12 @@ import Data.Primitive.Vec import qualified Data.Array.Accelerate.Sugar.Array as S import qualified Data.Array.Accelerate.Sugar.Shape as S +import Data.Function ( (&) ) import Prelude ( (.), ($), Char, Show, undefined, error, const, otherwise ) + import GHC.Generics ( Generic ) +import GHC.Stack + -- $setup -- >>> :seti -XTypeOperators diff --git a/src/Data/Array/Accelerate/Pattern/TH.hs b/src/Data/Array/Accelerate/Pattern/TH.hs index 01e315817..b67aaaf79 100644 --- a/src/Data/Array/Accelerate/Pattern/TH.hs +++ b/src/Data/Array/Accelerate/Pattern/TH.hs @@ -204,27 +204,30 @@ mkConS tn' tvs' prev' next' tag' con' = do where mkNormalC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) mkNormalC tn cn tag tvs ps fs ns = do + let pat = rename cn (fun_build, dec_build) <- mkBuild tn (nameBase cn) tvs tag ps fs ns - (fun_match, dec_match) <- mkMatch tn (nameBase cn) tvs tag ps fs ns - (pat, dec_pat) <- mkNormalC_pattern tn cn tvs fs fun_build fun_match + (fun_match, dec_match) <- mkMatch tn (nameBase pat) (nameBase cn) tvs tag ps fs ns + dec_pat <- mkNormalC_pattern tn pat tvs fs fun_build fun_match return $ (pat, concat [dec_pat, dec_build, dec_match]) mkRecC :: Name -> Name -> Word8 -> [Name] -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) mkRecC tn cn tag tvs xs ps fs ns = do + let pat = rename cn (fun_build, dec_build) <- mkBuild tn (nameBase cn) tvs tag ps fs ns - (fun_match, dec_match) <- mkMatch tn (nameBase cn) tvs tag ps fs ns - (pat, dec_pat) <- mkRecC_pattern tn cn tvs xs fs fun_build fun_match + (fun_match, dec_match) <- mkMatch tn (nameBase pat) (nameBase cn) tvs tag ps fs ns + dec_pat <- mkRecC_pattern tn pat tvs xs fs fun_build fun_match return $ (pat, concat [dec_pat, dec_build, dec_match]) mkInfixC :: Name -> Name -> Word8 -> [Name] -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) mkInfixC tn cn tag tvs ps fs ns = do + let pat = mkName (':' : nameBase cn) (fun_build, dec_build) <- mkBuild tn (zencode (nameBase cn)) tvs tag ps fs ns - (fun_match, dec_match) <- mkMatch tn (zencode (nameBase cn)) tvs tag ps fs ns - (pat, dec_pat) <- mkInfixC_pattern tn cn tvs fs fun_build fun_match + (fun_match, dec_match) <- mkMatch tn ("(" ++ nameBase pat ++ ")") (zencode (nameBase cn)) tvs tag ps fs ns + dec_pat <- mkInfixC_pattern tn cn pat tvs fs fun_build fun_match return $ (pat, concat [dec_pat, dec_build, dec_match]) - mkNormalC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) - mkNormalC_pattern tn cn tvs fs build match = do + mkNormalC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q [Dec] + mkNormalC_pattern tn pat tvs fs build match = do xs <- replicateM (length fs) (newName "_x") r <- sequence [ patSynSigD pat sig , patSynD pat @@ -232,9 +235,8 @@ mkConS tn' tvs' prev' next' tag' con' = do (explBidir [clause [] (normalB (varE build)) []]) (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) ] - return (pat, r) + return r where - pat = rename cn sig = forallT (map plainTV tvs) (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) @@ -242,17 +244,16 @@ mkConS tn' tvs' prev' next' tag' con' = do [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] (map (\t -> [t| Exp $(return t) |]) fs)) - mkRecC_pattern :: Name -> Name -> [Name] -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) - mkRecC_pattern tn cn tvs xs fs build match = do + mkRecC_pattern :: Name -> Name -> [Name] -> [Name] -> [Type] -> Name -> Name -> Q [Dec] + mkRecC_pattern tn pat tvs xs fs build match = do r <- sequence [ patSynSigD pat sig , patSynD pat (recordPatSyn xs) (explBidir [clause [] (normalB (varE build)) []]) (parensP $ viewP (varE match) [p| Just $(tupP (map varP xs)) |]) ] - return (pat, r) + return r where - pat = rename cn sig = forallT (map plainTV tvs) (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) @@ -260,8 +261,8 @@ mkConS tn' tvs' prev' next' tag' con' = do [t| Exp $(foldl' appT (conT tn) (map varT tvs)) |] (map (\t -> [t| Exp $(return t) |]) fs)) - mkInfixC_pattern :: Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q (Name, [Dec]) - mkInfixC_pattern tn cn tvs fs build match = do + mkInfixC_pattern :: Name -> Name -> Name -> [Name] -> [Type] -> Name -> Name -> Q [Dec] + mkInfixC_pattern tn cn pat tvs fs build match = do mf <- reifyFixity cn _a <- newName "_a" _b <- newName "_b" @@ -274,9 +275,8 @@ mkConS tn' tvs' prev' next' tag' con' = do r' <- case mf of Nothing -> return r Just f -> return (InfixD f pat : r) - return (pat, r') + return r' where - pat = mkName (':' : nameBase cn) sig = forallT (map plainTV tvs) (cxt ([t| HasCallStack |] : map (\t -> [t| Elt $(varT t) |]) tvs)) @@ -310,8 +310,8 @@ mkConS tn' tvs' prev' next' tag' con' = do (map (\t -> [t| Exp $(return t) |]) fs)) - mkMatch :: Name -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) - mkMatch tn cn tvs tag fs0 fs fs1 = do + mkMatch :: Name -> String -> String -> [Name] -> Word8 -> [[Type]] -> [Type] -> [[Type]] -> Q (Name, [Dec]) + mkMatch tn pn cn tvs tag fs0 fs fs1 = do fun <- newName ("_match" ++ cn) e <- newName "_e" x <- newName "_x" @@ -319,9 +319,9 @@ mkConS tn' tvs' prev' next' tag' con' = do let lhs = [p| (Exp $(varP e)) |] body = normalB $ caseE (varE e) - [ TH.match (conP 'SmartExp [(conP 'Match [matchP ps, varP x])]) (normalB [| Just $(tupE es) |]) [] - , TH.match (conP 'SmartExp [(recP 'Match [])]) (normalB [| Nothing |]) [] - , TH.match wildP (normalB [| error "Pattern synonym used outside 'match' context" |]) [] + [ TH.match (conP 'SmartExp [(conP 'Match [matchP ps, varP x])]) (normalB [| Just $(tupE es) |]) [] + , TH.match (conP 'SmartExp [(recP 'Match [])]) (normalB [| Nothing |]) [] + , TH.match wildP (normalB [| error $error_msg |]) [] ] r <- sequence [ sigD fun sig @@ -349,6 +349,24 @@ mkConS tn' tvs' prev' next' tag' con' = do vs = reverse $ [ False | _ <- concat fs0 ] ++ [ True | _ <- fs ] ++ [ False | _ <- concat fs1 ] + error_msg = + let pv = unwords + $ take (length fs + 1) + $ concatMap (map reverse) + $ iterate (concatMap (\xs -> [ x:xs | x <- ['a'..'z'] ])) [""] + in stringE $ unlines + [ "Embedded pattern synonym used outside 'match' context." + , "" + , "To use case statements in the embedded language the case statement must" + , "be applied as an n-ary function to the 'match' operator. For single" + , "argument case statements this can be done inline using LambdaCase, for" + , "example:" + , "" + , "> x & match \\case" + , printf "> %s%s -> ..." pn pv + , printf "> _%s -> ..." (replicate (length pn + length pv - 1) ' ') + ] + fst3 :: (a,b,c) -> a fst3 (a,_,_) = a From 170395676d7b51868ec21186dcde33736baaf6e5 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 6 Jul 2020 17:36:01 +0200 Subject: [PATCH 278/316] remove invalid TODO --- src/Data/Array/Accelerate/Representation/Stencil.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Representation/Stencil.hs b/src/Data/Array/Accelerate/Representation/Stencil.hs index 1ab243807..81855cd90 100644 --- a/src/Data/Array/Accelerate/Representation/Stencil.hs +++ b/src/Data/Array/Accelerate/Representation/Stencil.hs @@ -102,8 +102,6 @@ stencilR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) = tupR9 (stencilR s1) (stenci stencilArrayR :: StencilR sh e pat -> ArrayR (Array sh e) stencilArrayR sR = ArrayR (stencilShapeR sR) (stencilEltR sR) --- XXX: This is incorrect: stencils are not required to be rectangular --- stencilHalo :: StencilR sh e stencil -> (ShapeR sh, sh) stencilHalo = go' where From ac00e57b146f7be20a248b932d0950770df49ad7 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 6 Jul 2020 22:48:16 +0200 Subject: [PATCH 279/316] ci: disable windows build --- .github/workflows/ci.yml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 43906f317..b59e72752 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -28,12 +28,9 @@ jobs: - os: macOS-latest ghc: "8.10" allow_failure: false - # ghc-8.8 currently doesn't work on the windows test machines due to a - # 32-bit linker problem, failing with the error: - # Access violation in generated code when writing 0x0 - - os: windows-latest - ghc: "8.10" - allow_failure: true + # - os: windows-latest + # ghc: "8.10" + # allow_failure: true env: STACK_FLAGS: "--system-ghc --no-install-ghc --fast --flag accelerate:nofib" From 262dba342a8e3b7ab85190cd53b31c0df5ec19ce Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 7 Jul 2020 12:29:09 +0200 Subject: [PATCH 280/316] update issue templates --- .github/ISSUE_TEMPLATE/bug_report.md | 42 +++++++++++++ .github/ISSUE_TEMPLATE/config.yml | 9 +++ .github/ISSUE_TEMPLATE/feature_request.md | 23 +++++++ .github/issue_template.md | 73 ++++------------------- 4 files changed, 87 insertions(+), 60 deletions(-) create mode 100644 .github/ISSUE_TEMPLATE/bug_report.md create mode 100644 .github/ISSUE_TEMPLATE/config.yml create mode 100644 .github/ISSUE_TEMPLATE/feature_request.md diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md new file mode 100644 index 000000000..1ad58a0c1 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/bug_report.md @@ -0,0 +1,42 @@ +--- +name: Bug report +about: Create a report to help us improve Accelerate +title: "[BUG]" +labels: '' +assignees: '' + +--- + +Hi! Thanks for trying out Accelerate! We are sorry that you ran into trouble ): Please fill in the following report to help us fix the problem. + +**Description** +Provide a clear and concise description of what the bug is. +If applicable, include screenshots to help explain the problem. + +**Steps to reproduce** +Please provide as much information as possible so that somebody can understand and reproduce the problem. Remember: only bugs which are understood can be fixed. + +Providing a link to a minimal example which shows the faulty behaviour is best. https://gist.github.com is useful for pasting longer code snippets. If your program requires any additional packages, please include the `.cabal` and `stack.yaml` files so that it is easy to build. + +Steps to reproduce the behaviour: + +1. +2. +3. + +**Expected behaviour** +A clear and concise description of what you expected to happen. + +**Your environment** +Include any relevant details about the environment you experienced the bug in. When reporting the versions of Accelerate packages used, include either the release number or the commit SHA if building from source. + +If the bug is with the `accelerate-llvm-ptx` GPU backend, include the output of `nvidia-device-query` + + - Accelerate: + - Accelerate backend(s): + - GHC: + - OS: + +**Additional context** +Add any other context about the problem here. + diff --git a/.github/ISSUE_TEMPLATE/config.yml b/.github/ISSUE_TEMPLATE/config.yml new file mode 100644 index 000000000..1f4ad8f63 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/config.yml @@ -0,0 +1,9 @@ +blank_issues_enabled: true +contact_links: + - name: Accelerate community chat + about: Community chat room + url: https://gitter.im/AccelerateHS/Lobby + - name: Accelerate mailing list + about: Please ask and answer questions here + url: mailto:accelerate-haskell@googlegroups.com + diff --git a/.github/ISSUE_TEMPLATE/feature_request.md b/.github/ISSUE_TEMPLATE/feature_request.md new file mode 100644 index 000000000..83f15b457 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/feature_request.md @@ -0,0 +1,23 @@ +--- +name: Feature request +about: Suggest an idea to improve Accelerate +title: '' +labels: '' +assignees: '' + +--- + +**Is your feature request related to a problem? Please describe.** +A clear and concise description of what the problem is. For example: I'm always frustrated when [...] + +For difficulties using Accelerate you might also like to ask on the [mailing list](mailto:accelerate-haskell@googlegroups.com) or [chat room](https://gitter.im/AccelerateHS/Lobby). + +**Describe the solution you'd like** +A clear and concise description of what you want to happen, or how the new feature should work. + +**Describe alternatives you've considered** +A clear and concise description of any alternative solutions or features you've considered. + +**Additional context** +Add any other context or screenshots about the feature request here. + diff --git a/.github/issue_template.md b/.github/issue_template.md index ea56b6f8d..a80eff10b 100644 --- a/.github/issue_template.md +++ b/.github/issue_template.md @@ -1,67 +1,20 @@ - +**Description** +Provide a clear and concise description of what the problem is. - -I am submitting a... -- [ ] bug report -- [ ] feature request -- [ ] support request => you might also like to ask your question on the [mailing list](mailto:accelerate-haskell@googlegroups.com) or [gitter chat](https://gitter.im/AccelerateHS/Lobby). +**Your environment** +Include any relevant details about the environment you experienced the bug in. When reporting the versions of Accelerate packages used, include either the release number or the commit SHA if building from source. -## Description - +If the bug is with the `accelerate-llvm-ptx` GPU backend, include the output of `nvidia-device-query` + - Accelerate: + - Accelerate backend(s): + - GHC: + - OS: -## Expected behaviour - - -## Current behaviour - - -## Possible solution (optional) - - -## Steps to reproduce (for bugs) - - - 1. - 2. - 3. - -## Your environment - - -- Accelerate version: -- Accelerate backend(s) used: -- GHC version: -- Operating system and version: -- Link to your project/example: -- If this is a bug with the GPU backend, include the output of `nvidia-device-query`: +**Additional context** +Add any other context about the problem here. From 8ab04c31c10b11de9a6458ad144277dcb2f6380a Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 7 Jul 2020 12:35:11 +0200 Subject: [PATCH 281/316] update issue template config --- .github/ISSUE_TEMPLATE/config.yml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/.github/ISSUE_TEMPLATE/config.yml b/.github/ISSUE_TEMPLATE/config.yml index 1f4ad8f63..0035b91fd 100644 --- a/.github/ISSUE_TEMPLATE/config.yml +++ b/.github/ISSUE_TEMPLATE/config.yml @@ -1,9 +1,10 @@ blank_issues_enabled: true contact_links: - name: Accelerate community chat - about: Community chat room + about: Ask and answer questions here url: https://gitter.im/AccelerateHS/Lobby - name: Accelerate mailing list - about: Please ask and answer questions here - url: mailto:accelerate-haskell@googlegroups.com + about: Ask and answer questions here + url: http://groups.google.com/group/accelerate-haskell + # url: mailto:accelerate-haskell@googlegroups.com From 7cd4b6a745a9b273b808058475309e2854f7f71e Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 7 Jul 2020 12:48:58 +0200 Subject: [PATCH 282/316] update pull request template --- .github/pull_request_template.md | 50 +++++++++++--------------------- 1 file changed, 17 insertions(+), 33 deletions(-) diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md index 050292399..c96ca94cd 100644 --- a/.github/pull_request_template.md +++ b/.github/pull_request_template.md @@ -1,45 +1,29 @@ - -## Description - +**Description** +Provide a description of the changes proposed by this pull request. -## Motivation and context - +**Motivation and context** +Why is this change required? What problem does it solve? If it fixes an open issue(s), link to the issue here. -## How has this been tested? - +**How has this been tested?** +Describe how your changes have been tested. Include details of your testing environment. -## Types of changes - +**Types of changes** +What types of changes does your code introduce? Put an `x` in all the boxes that apply: - [ ] Bug fix (non-breaking change which fixes an issue) - [ ] New feature (non-breaking change which adds functionality) - [ ] Breaking change (fix or feature that would cause existing functionality to change) -## Checklist: - - -- [ ] My code follows the code style of this project. -- [ ] My change requires a change to the documentation. -- [ ] I have updated the documentation accordingly. -- [ ] I have added tests to cover my changes. -- [ ] All new and existing tests passed. +**Checklist** +Go over all the following points, and put an `x` in all the boxes that apply. If you're unsure about any of these, don't hesitate to ask. We're here to help! + +- [ ] My code follows the code style of this project +- [ ] My change requires a change to the documentation +- [ ] I have updated the documentation accordingly +- [ ] I have added tests to cover my changes +- [ ] All new and existing tests passed From b18fca00e73082c9b8215212f32c329c6af555bf Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 9 Jul 2020 12:35:14 +0200 Subject: [PATCH 283/316] update array data witnesses --- src/Data/Array/Accelerate/Array/Data.hs | 45 +++++++------------------ 1 file changed, 12 insertions(+), 33 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 6d19339d7..7eb1ae947 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -124,8 +124,10 @@ type family ScalarArrayDataR t where data ScalarArrayDict a where - ScalarArrayDict :: ( GArrayData a ~ ScalarArrayData a ) - => ScalarArrayDict a + ScalarArrayDict :: ( GArrayData a ~ ScalarArrayData a, ScalarArrayDataR a ~ ScalarArrayDataR b ) + => {-# UNPACK #-} !Int -- vector width + -> SingleType b -- base type + -> ScalarArrayDict a data SingleArrayDict a where SingleArrayDict :: ( GArrayData a ~ ScalarArrayData a, ScalarArrayDataR a ~ a ) @@ -135,38 +137,15 @@ scalarArrayDict :: ScalarType a -> ScalarArrayDict a scalarArrayDict = scalar where scalar :: ScalarType a -> ScalarArrayDict a - scalar (SingleScalarType t) = single t scalar (VectorScalarType t) = vector t - - single :: SingleType a -> ScalarArrayDict a - single (NumSingleType t) = num t + scalar (SingleScalarType t) + | SingleArrayDict <- singleArrayDict t + = ScalarArrayDict 1 t vector :: VectorType a -> ScalarArrayDict a - vector (VectorType _ s) - | ScalarArrayDict <- single s - = ScalarArrayDict - - num :: NumType a -> ScalarArrayDict a - num (IntegralNumType t) = integral t - num (FloatingNumType t) = floating t - - integral :: IntegralType a -> ScalarArrayDict a - integral TypeInt = ScalarArrayDict - integral TypeInt8 = ScalarArrayDict - integral TypeInt16 = ScalarArrayDict - integral TypeInt32 = ScalarArrayDict - integral TypeInt64 = ScalarArrayDict - integral TypeWord = ScalarArrayDict - integral TypeWord8 = ScalarArrayDict - integral TypeWord16 = ScalarArrayDict - integral TypeWord32 = ScalarArrayDict - integral TypeWord64 = ScalarArrayDict - - floating :: FloatingType a -> ScalarArrayDict a - floating TypeHalf = ScalarArrayDict - floating TypeFloat = ScalarArrayDict - floating TypeDouble = ScalarArrayDict - + vector (VectorType w s) + | SingleArrayDict <- singleArrayDict s + = ScalarArrayDict w s singleArrayDict :: SingleType a -> SingleArrayDict a singleArrayDict = single @@ -269,14 +248,14 @@ writeArrayData (TupRsingle t) arr !ix !val unsafeArrayDataPtr :: ScalarType e -> ArrayData e -> Ptr (ScalarArrayDataR e) unsafeArrayDataPtr t arr - | ScalarArrayDict <- scalarArrayDict t + | ScalarArrayDict{} <- scalarArrayDict t = unsafeUniqueArrayPtr arr touchArrayData :: TupR ScalarType e -> ArrayData e -> IO () touchArrayData TupRunit () = return () touchArrayData (TupRpair t1 t2) (a1, a2) = touchArrayData t1 a1 >> touchArrayData t2 a2 touchArrayData (TupRsingle t) arr - | ScalarArrayDict <- scalarArrayDict t + | ScalarArrayDict{} <- scalarArrayDict t = touchUniqueArray arr rnfArrayData :: TupR ScalarType e -> ArrayData e -> () From ebf705e8d58635f05f4d08c34026b75dca99a98e Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 9 Jul 2020 13:08:19 +0200 Subject: [PATCH 284/316] remove CPP cruft required for old versions of GHC --- .../Array/Accelerate/Classes/FromIntegral.hs | 9 --- .../Array/Accelerate/Classes/ToFloating.hs | 9 --- src/Data/Array/Accelerate/Data/Complex.hs | 9 --- src/Data/Array/Accelerate/Data/Either.hs | 5 -- src/Data/Array/Accelerate/Data/Functor.hs | 8 +- src/Data/Array/Accelerate/Data/Maybe.hs | 14 +--- src/Data/Array/Accelerate/Data/Monoid.hs | 75 ++----------------- src/Data/Array/Accelerate/Debug/Flags.hs | 4 +- src/Data/Array/Accelerate/Debug/Timed.hs | 23 ------ src/Data/Array/Accelerate/Interpreter.hs | 24 ------ src/Data/Array/Accelerate/Language.hs | 10 +-- src/Data/Array/Accelerate/Lifetime.hs | 7 +- src/Data/Array/Accelerate/Lift.hs | 4 - src/Data/Array/Accelerate/Pretty/Print.hs | 4 - .../Accelerate/Test/NoFib/Issues/Issue364.hs | 4 - .../Accelerate/Test/NoFib/Prelude/Map.hs | 23 ------ src/Data/Array/Accelerate/Trafo/Algebra.hs | 23 ------ src/Data/Array/Accelerate/Trafo/Vectorise.hs | 7 -- src/Data/BitSet.hs | 7 -- 19 files changed, 17 insertions(+), 252 deletions(-) diff --git a/src/Data/Array/Accelerate/Classes/FromIntegral.hs b/src/Data/Array/Accelerate/Classes/FromIntegral.hs index a4c68d8a2..64b6089e8 100644 --- a/src/Data/Array/Accelerate/Classes/FromIntegral.hs +++ b/src/Data/Array/Accelerate/Classes/FromIntegral.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} @@ -55,24 +54,16 @@ $(runQ $ do -- 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 diff --git a/src/Data/Array/Accelerate/Classes/ToFloating.hs b/src/Data/Array/Accelerate/Classes/ToFloating.hs index bcba995e4..0bab978d7 100644 --- a/src/Data/Array/Accelerate/Classes/ToFloating.hs +++ b/src/Data/Array/Accelerate/Classes/ToFloating.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -50,24 +49,16 @@ $(runQ $ do -- 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 diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index 494a2d678..c763c0d3f 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -328,21 +327,13 @@ polar z = T2 (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 diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index 7979dd597..24bfa1e33 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -49,9 +48,7 @@ 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.Either ( Either(..) ) import Prelude ( (.), ($) ) @@ -129,10 +126,8 @@ instance (Ord a, Ord b) => Ord (Either a b) where go Left_{} Right_{} = LT_ go Right_{} Left_{} = GT_ -#if __GLASGOW_HASKELL__ >= 800 instance (Elt a, Elt b) => Semigroup (Exp (Either a b)) where ex <> ey = isLeft ex ? ( ey, ex ) -#endif 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) diff --git a/src/Data/Array/Accelerate/Data/Functor.hs b/src/Data/Array/Accelerate/Data/Functor.hs index b78c69a82..ee3fa4b19 100644 --- a/src/Data/Array/Accelerate/Data/Functor.hs +++ b/src/Data/Array/Accelerate/Data/Functor.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RebindableSyntax #-} -- | -- Module : Data.Array.Accelerate.Data.Functor @@ -31,11 +30,8 @@ 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 ) +import Prelude ( (.), const, flip ) -- | The 'Functor' class is used for scalar types which can be mapped over. @@ -91,11 +87,9 @@ instance Functor Sum where 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 diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index be551f18a..89688e89b 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -49,9 +48,7 @@ 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.Maybe ( Maybe(..) ) import Prelude ( ($), (.) ) @@ -125,19 +122,12 @@ instance Ord a => Ord (Maybe a) where go Just_{} Nothing_{} = GT_ instance (Monoid (Exp a), Elt a) => Monoid (Exp (Maybe a)) where - mempty = 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 + mempty = Nothing_ + 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 instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Maybe a) where type Plain (Maybe a) = Maybe (Plain a) diff --git a/src/Data/Array/Accelerate/Data/Monoid.hs b/src/Data/Array/Accelerate/Data/Monoid.hs index 7c95fd3a3..691f57fc4 100644 --- a/src/Data/Array/Accelerate/Data/Monoid.hs +++ b/src/Data/Array/Accelerate/Data/Monoid.hs @@ -39,23 +39,17 @@ 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.Data.Semigroup () import Data.Array.Accelerate.Language import Data.Array.Accelerate.Lift import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Elt 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 qualified Prelude as P @@ -101,21 +95,12 @@ instance Ord a => Ord (Sum a) where max x y = 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 + mempty = 0 -#if __GLASGOW_HASKELL__ >= 800 -- | @since 1.2.0.0 instance Num a => Semigroup (Exp (Sum a)) where (<>) = (+) stimes n (Sum_ x) = Sum_ $ P.fromIntegral n * x -#endif -- Product: Monoid under multiplication @@ -160,73 +145,29 @@ instance Ord a => Ord (Product a) where max x y = 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 + mempty = 1 -#if __GLASGOW_HASKELL__ >= 800 -- | @since 1.2.0.0 instance Num a => Semigroup (Exp (Product a)) where (<>) = (*) stimes n (Product_ x) = Product_ $ x ^ (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 + mempty = constant () --- 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 + mempty = T2 mempty mempty 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 + mempty = T3 mempty mempty mempty 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 + mempty = T4 mempty mempty mempty mempty 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 + mempty = T5 mempty mempty mempty mempty mempty diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index 19e59b3df..e0c46a4f6 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -4,10 +4,8 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} {-# OPTIONS_GHC -fobject-code #-} -- SEE: [linking to .c files] -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -#endif -- | -- Module : Data.Array.Accelerate.Debug.Flags -- Copyright : [2008..2019] The Accelerate Team diff --git a/src/Data/Array/Accelerate/Debug/Timed.hs b/src/Data/Array/Accelerate/Debug/Timed.hs index a0955a07a..e6467dcf6 100644 --- a/src/Data/Array/Accelerate/Debug/Timed.hs +++ b/src/Data/Array/Accelerate/Debug/Timed.hs @@ -81,31 +81,14 @@ timed_simpl fmt action = do {-# 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 w64 (W64# w#) = D# (word2Double# w#) i64 (I64# i#) = D# (int2Double# i#) -- -#if __GLASGOW_HASKELL__ < 802 - allocated = i64 (bytesAllocated gc1 - bytesAllocated gc0) - copied = i64 (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 = w64 (allocated_bytes rts1 - allocated_bytes rts0) copied = w64 (copied_bytes rts1 - copied_bytes rts0) totalWall = i64 (elapsed_ns rts1 - elapsed_ns rts0) * 1.0E-9 @@ -115,7 +98,6 @@ timed_gc fmt action = do gcWall = i64 (gc_elapsed_ns rts1 - gc_elapsed_ns rts0) * 1.0E-9 gcCPU = i64 (gc_cpu_ns rts1 - gc_cpu_ns rts0) * 1.0E-9 totalGCs = gcs rts1 - gcs rts0 -#endif liftIO . putTraceMsg $ intercalate "\n" [ fmt totalWall totalCPU @@ -126,11 +108,6 @@ timed_gc fmt action = do ] -- return res - -#if __GLASGOW_HASKELL__ < 802 -getRTSStatsEnabled :: IO Bool -getRTSStatsEnabled = getGCStatsEnabled -#endif #endif elapsed :: Double -> Double -> String diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index 592102181..d0d8fc8ef 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} @@ -1360,33 +1359,10 @@ 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 (/) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index f68aa6ca4..bd130499a 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -1336,11 +1335,10 @@ while :: forall e. Elt e -> (Exp e -> Exp e) -- ^ function to apply -> Exp e -- ^ initial value -> Exp e -#if __GLASGOW_HASKELL__ < 804 -while c f (Exp e) = mkExp $ While @SmartAcc @SmartExp @(EltR e) (eltR @e) (mkCoerce' . unExp . c . Exp) (unExp . f . Exp) e -#else -while c f (Exp e) = mkExp $ While @(EltR e) (eltR @e) (mkCoerce' . unExp . c . Exp) (unExp . f . Exp) e -#endif +while c f (Exp e) = + mkExp $ While @(EltR e) (eltR @e) + (mkCoerce' . unExp . c . Exp) + (unExp . f . Exp) e -- Array operations with a scalar result diff --git a/src/Data/Array/Accelerate/Lifetime.hs b/src/Data/Array/Accelerate/Lifetime.hs index ed22f523b..ba39bd002 100644 --- a/src/Data/Array/Accelerate/Lifetime.hs +++ b/src/Data/Array/Accelerate/Lifetime.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UnboxedTuples #-} @@ -121,11 +120,7 @@ finalize (Lifetime ref _ _) = finalizer ref 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 + go (IO f) = -- GHC-8.x IO $ \s -> case mkWeak# r# v f s of (# s', w# #) -> (# s', Weak w# #) diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index e2819cf85..380bdc6bc 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -9,10 +9,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE UndecidableInstances #-} #endif diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 9b49bc77b..4b2026fb7 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -716,9 +715,6 @@ sizeEnv (Push env _) = 1 + sizeEnv env prj :: Idx env t -> Val env -> Adoc prj ZeroIdx (Push _ v) = v prj (SuccIdx ix) (Push env _) = prj ix env -#if __GLASGOW_HASKELL__ < 800 -prj _ _ = error "inconsistent valuation" -#endif -- Utilities diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs index 9bd8136e5..0444d5664 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -26,9 +25,6 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue364 ( import Prelude ( fromInteger, show ) import qualified Prelude as P -#if __GLASGOW_HASKELL__ == 800 -import Prelude ( fail ) -#endif import Data.Array.Accelerate hiding ( fromInteger ) import Data.Array.Accelerate.Sugar.Elt as S diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs index 05c99bda1..57ae9591b 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} @@ -454,30 +453,8 @@ mapRef :: (Shape sh, Elt a, Elt b) => (a -> b) -> Array sh a -> Array sh b mapRef f xs = fromFunction (arrayShape xs) (\ix -> f (xs S.! 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 diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index 8a7191a10..82ef1550b 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -510,32 +509,10 @@ evalPopCount :: IntegralType a -> a :-> Int evalPopCount ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType TypeInt) popCount evalCountLeadingZeros :: IntegralType a -> a :-> Int -#if __GLASGOW_HASKELL__ >= 710 evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType TypeInt) countLeadingZeros -#else -evalCountLeadingZeros ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType TypeInt) 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 (NumSingleType $ IntegralNumType TypeInt) countTrailingZeros -#else -evalCountTrailingZeros ty | IntegralDict <- integralDict ty = eval1 (NumSingleType $ IntegralNumType TypeInt) 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 diff --git a/src/Data/Array/Accelerate/Trafo/Vectorise.hs b/src/Data/Array/Accelerate/Trafo/Vectorise.hs index 5d7684e8e..41d8350dc 100644 --- a/src/Data/Array/Accelerate/Trafo/Vectorise.hs +++ b/src/Data/Array/Accelerate/Trafo/Vectorise.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -560,9 +559,6 @@ liftPreOpenAcc vectAcc strength ctx size acc | AvoidedAcc (a' :: acc aenv' a) <- a , IsC <- isArraysFlat (undefined :: a) -> Right (SnocAtup li (replicateA a' size)) -#if __GLASGOW_HASKELL__ < 800 - _ -> error "unreachable" -#endif aprjL :: forall a arrs. (Arrays a, Arrays arrs, IsAtuple arrs, Arrays (Vector' a)) @@ -1876,9 +1872,6 @@ liftedCond pred th el cvtT :: ProdR Arrays t -> Atuple S.Acc (LiftedTupleRepr t) -> Atuple S.Acc (LiftedTupleRepr t) -> Atuple S.Acc (LiftedTupleRepr t) cvtT ProdRunit NilAtup NilAtup = NilAtup cvtT (ProdRsnoc t) (SnocAtup t1 a1) (SnocAtup t2 a2) = SnocAtup (cvtT t t1 t2) (liftedCond pred a1 a2) -#if __GLASGOW_HASKELL__ < 800 - cvtT _ _ _ = error "unreachable" -#endif liftedCond1 :: (Elt e, Shape sh) => S.Acc (LiftedArray sh e) -> S.Acc (LiftedArray sh e) -> S.Acc (LiftedArray sh e) liftedCond1 t e = liftedArray segs vals diff --git a/src/Data/BitSet.hs b/src/Data/BitSet.hs index e952a0459..676963397 100644 --- a/src/Data/BitSet.hs +++ b/src/Data/BitSet.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} -- | @@ -17,9 +16,6 @@ module Data.BitSet where import Data.Bits import Prelude hiding ( foldl, foldr ) import qualified Data.List as List -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup -#endif import GHC.Exts ( IsList, build ) import qualified GHC.Exts as Exts @@ -41,9 +37,6 @@ instance (Enum a, Bits c) => Semigroup (BitSet c a) where instance (Enum a, Bits c, Num c) => Monoid (BitSet c a) where mempty = empty -#if __GLASGOW_HASKELL__ < 804 - mappend = (<>) -#endif instance (Enum a, Bits c, Num c) => IsList (BitSet c a) where type Item (BitSet c a) = a From a03e361262e617f8944dbfdcacf80117996e7147 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 9 Jul 2020 13:34:54 +0200 Subject: [PATCH 285/316] export module D.A.A.Trafo.Delayed --- accelerate.cabal | 2 +- src/Data/Array/Accelerate/Trafo/Delayed.hs | 1 + src/Data/Array/Accelerate/Trafo/Var.hs | 1 - 3 files changed, 2 insertions(+), 2 deletions(-) diff --git a/accelerate.cabal b/accelerate.cabal index 11bd557c6..44989b516 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -348,6 +348,7 @@ Library Data.Array.Accelerate.Sugar.Vec Data.Array.Accelerate.Trafo Data.Array.Accelerate.Trafo.Config + Data.Array.Accelerate.Trafo.Delayed Data.Array.Accelerate.Trafo.Fusion Data.Array.Accelerate.Trafo.Sharing Data.Array.Accelerate.Type @@ -399,7 +400,6 @@ Library Data.Array.Accelerate.Pretty.Graphviz.Type Data.Array.Accelerate.Pretty.Print Data.Array.Accelerate.Trafo.Algebra - Data.Array.Accelerate.Trafo.Delayed Data.Array.Accelerate.Trafo.Environment Data.Array.Accelerate.Trafo.LetSplit Data.Array.Accelerate.Trafo.Shrink diff --git a/src/Data/Array/Accelerate/Trafo/Delayed.hs b/src/Data/Array/Accelerate/Trafo/Delayed.hs index ab2300a44..03c440eb9 100644 --- a/src/Data/Array/Accelerate/Trafo/Delayed.hs +++ b/src/Data/Array/Accelerate/Trafo/Delayed.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Delayed -- Copyright : [2012..2019] The Accelerate Team diff --git a/src/Data/Array/Accelerate/Trafo/Var.hs b/src/Data/Array/Accelerate/Trafo/Var.hs index 684874617..d5829671b 100644 --- a/src/Data/Array/Accelerate/Trafo/Var.hs +++ b/src/Data/Array/Accelerate/Trafo/Var.hs @@ -76,4 +76,3 @@ avarsOut extract = \case -> Just (TupRpair as bs) _ -> Nothing - From bc53cb506dfcdfc68ede1a94ae07251c7905bded Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 9 Jul 2020 13:43:22 +0200 Subject: [PATCH 286/316] update .cabal tested-with --- accelerate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/accelerate.cabal b/accelerate.cabal index 44989b516..ec06b7514 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -1,7 +1,7 @@ Name: accelerate Version: 1.4.0.0 Cabal-version: >= 1.18 -Tested-with: GHC >= 8.2 +Tested-with: GHC >= 8.6 Build-type: Custom Synopsis: An embedded language for accelerated array processing From 4da947c78ec1a1e65e932bb6ca2e3bd4b384d20b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 9 Jul 2020 13:44:14 +0200 Subject: [PATCH 287/316] update copyright in header --- LICENSE | 2 +- cbits/atomic.c | 2 +- cbits/clock.c | 2 +- cbits/flags.c | 2 +- cbits/flags.h | 2 +- cbits/monitoring.c | 2 +- src/Data/Array/Accelerate.hs | 2 +- src/Data/Array/Accelerate/AST.hs | 2 +- src/Data/Array/Accelerate/AST/Environment.hs | 2 +- src/Data/Array/Accelerate/AST/Idx.hs | 2 +- src/Data/Array/Accelerate/AST/LeftHandSide.hs | 2 +- src/Data/Array/Accelerate/AST/Var.hs | 2 +- src/Data/Array/Accelerate/Analysis/Hash.hs | 2 +- src/Data/Array/Accelerate/Analysis/Hash/TH.hs | 2 +- src/Data/Array/Accelerate/Analysis/Match.hs | 2 +- src/Data/Array/Accelerate/Array/Data.hs | 2 +- src/Data/Array/Accelerate/Array/Remote.hs | 2 +- src/Data/Array/Accelerate/Array/Remote/Class.hs | 2 +- src/Data/Array/Accelerate/Array/Remote/LRU.hs | 2 +- src/Data/Array/Accelerate/Array/Remote/Nursery.hs | 2 +- src/Data/Array/Accelerate/Array/Remote/Table.hs | 2 +- src/Data/Array/Accelerate/Array/Unique.hs | 2 +- src/Data/Array/Accelerate/Async.hs | 2 +- src/Data/Array/Accelerate/Classes.hs | 2 +- src/Data/Array/Accelerate/Classes/Bounded.hs | 2 +- src/Data/Array/Accelerate/Classes/Enum.hs | 2 +- src/Data/Array/Accelerate/Classes/Eq.hs | 2 +- src/Data/Array/Accelerate/Classes/Floating.hs | 2 +- src/Data/Array/Accelerate/Classes/Fractional.hs | 2 +- src/Data/Array/Accelerate/Classes/FromIntegral.hs | 2 +- src/Data/Array/Accelerate/Classes/Integral.hs | 2 +- src/Data/Array/Accelerate/Classes/Num.hs | 2 +- src/Data/Array/Accelerate/Classes/Ord.hs | 2 +- src/Data/Array/Accelerate/Classes/Rational.hs | 2 +- src/Data/Array/Accelerate/Classes/Real.hs | 2 +- src/Data/Array/Accelerate/Classes/RealFloat.hs | 2 +- src/Data/Array/Accelerate/Classes/RealFloat.hs-boot | 2 +- src/Data/Array/Accelerate/Classes/RealFrac.hs | 2 +- src/Data/Array/Accelerate/Classes/RealFrac.hs-boot | 2 +- src/Data/Array/Accelerate/Classes/ToFloating.hs | 2 +- src/Data/Array/Accelerate/Data/Bits.hs | 2 +- src/Data/Array/Accelerate/Data/Complex.hs | 2 +- src/Data/Array/Accelerate/Data/Either.hs | 2 +- src/Data/Array/Accelerate/Data/Fold.hs | 2 +- src/Data/Array/Accelerate/Data/Functor.hs | 2 +- src/Data/Array/Accelerate/Data/Maybe.hs | 2 +- src/Data/Array/Accelerate/Data/Monoid.hs | 2 +- src/Data/Array/Accelerate/Data/Ratio.hs | 2 +- src/Data/Array/Accelerate/Data/Semigroup.hs | 2 +- src/Data/Array/Accelerate/Debug.hs | 2 +- src/Data/Array/Accelerate/Debug/Clock.hs | 2 +- src/Data/Array/Accelerate/Debug/Flags.hs | 2 +- src/Data/Array/Accelerate/Debug/Monitoring.hs | 2 +- src/Data/Array/Accelerate/Debug/Stats.hs | 2 +- src/Data/Array/Accelerate/Debug/Timed.hs | 2 +- src/Data/Array/Accelerate/Debug/Trace.hs | 2 +- src/Data/Array/Accelerate/Error.hs | 2 +- src/Data/Array/Accelerate/Interpreter.hs | 2 +- src/Data/Array/Accelerate/Language.hs | 2 +- src/Data/Array/Accelerate/Lifetime.hs | 2 +- src/Data/Array/Accelerate/Lift.hs | 2 +- src/Data/Array/Accelerate/Orphans.hs | 2 +- src/Data/Array/Accelerate/Pattern.hs | 2 +- src/Data/Array/Accelerate/Pattern/Bool.hs | 2 +- src/Data/Array/Accelerate/Pattern/Either.hs | 2 +- src/Data/Array/Accelerate/Pattern/Maybe.hs | 2 +- src/Data/Array/Accelerate/Pattern/Ordering.hs | 2 +- src/Data/Array/Accelerate/Pattern/TH.hs | 2 +- src/Data/Array/Accelerate/Prelude.hs | 2 +- src/Data/Array/Accelerate/Pretty.hs | 2 +- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 2 +- src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs | 2 +- src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs | 2 +- src/Data/Array/Accelerate/Pretty/Print.hs | 2 +- src/Data/Array/Accelerate/Representation/Elt.hs | 2 +- src/Data/Array/Accelerate/Representation/Stencil.hs | 2 +- src/Data/Array/Accelerate/Representation/Vec.hs | 2 +- src/Data/Array/Accelerate/Smart.hs | 2 +- src/Data/Array/Accelerate/Sugar/Array.hs | 2 +- src/Data/Array/Accelerate/Sugar/Elt.hs | 2 +- src/Data/Array/Accelerate/Sugar/Foreign.hs | 2 +- src/Data/Array/Accelerate/Sugar/Shape.hs | 2 +- src/Data/Array/Accelerate/Sugar/Stencil.hs | 2 +- src/Data/Array/Accelerate/Sugar/Vec.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Base.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Config.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue286.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Sharing.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Spectral.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs | 2 +- src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs | 2 +- src/Data/Array/Accelerate/Test/Similar.hs | 2 +- src/Data/Array/Accelerate/Trafo.hs | 2 +- src/Data/Array/Accelerate/Trafo/Algebra.hs | 2 +- src/Data/Array/Accelerate/Trafo/Config.hs | 2 +- src/Data/Array/Accelerate/Trafo/Delayed.hs | 2 +- src/Data/Array/Accelerate/Trafo/Environment.hs | 2 +- src/Data/Array/Accelerate/Trafo/Fusion.hs | 2 +- src/Data/Array/Accelerate/Trafo/LetSplit.hs | 2 +- src/Data/Array/Accelerate/Trafo/Normalise.hs | 2 +- src/Data/Array/Accelerate/Trafo/Sharing.hs | 2 +- src/Data/Array/Accelerate/Trafo/Shrink.hs | 2 +- src/Data/Array/Accelerate/Trafo/Simplify.hs | 2 +- src/Data/Array/Accelerate/Trafo/Substitution.hs | 2 +- src/Data/Array/Accelerate/Trafo/Var.hs | 2 +- src/Data/Array/Accelerate/Trafo/Vectorise.hs | 2 +- src/Data/Array/Accelerate/Type.hs | 2 +- src/Data/Array/Accelerate/Unsafe.hs | 2 +- src/Data/Atomic.hs | 2 +- src/Data/BitSet.hs | 2 +- src/Data/Primitive/Vec.hs | 2 +- src/Language/Haskell/TH/Extra.hs | 2 +- test/doctest/Main.hs | 2 +- test/nofib/Main.hs | 2 +- 153 files changed, 153 insertions(+), 153 deletions(-) diff --git a/LICENSE b/LICENSE index d06db852b..8bf816b76 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) [2007..2017] The Accelerate Team. All rights reserved. +Copyright (c) [2007..2020] The Accelerate Team. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/cbits/atomic.c b/cbits/atomic.c index 157ac0eed..b540d7f40 100644 --- a/cbits/atomic.c +++ b/cbits/atomic.c @@ -1,6 +1,6 @@ /* * Module : Data.Atomic - * Copyright : [2017..2019] The Accelerate Team + * Copyright : [2017..2020] The Accelerate Team * License : BSD3 * * Maintainer : Trevor L. McDonell diff --git a/cbits/clock.c b/cbits/clock.c index 9ba0d3220..b7dc72680 100644 --- a/cbits/clock.c +++ b/cbits/clock.c @@ -1,6 +1,6 @@ /* * Module : Data.Array.Accelerate.Debug.Clock - * Copyright : [2017..2019] The Accelerate Team + * Copyright : [2017..2020] The Accelerate Team * License : BSD3 * * Maintainer : Trevor L. McDonell diff --git a/cbits/flags.c b/cbits/flags.c index 1a2c8321e..5e6ee01cc 100644 --- a/cbits/flags.c +++ b/cbits/flags.c @@ -1,6 +1,6 @@ /* * Module : Data.Array.Accelerate.Debug.Flags - * Copyright : [2017..2019] The Accelerate Team + * Copyright : [2017..2020] The Accelerate Team * License : BSD3 * * Maintainer : Trevor L. McDonell diff --git a/cbits/flags.h b/cbits/flags.h index c64c6f08b..a355b7684 100644 --- a/cbits/flags.h +++ b/cbits/flags.h @@ -1,6 +1,6 @@ /* * Module : Data.Array.Accelerate.Debug.Flags - * Copyright : [2017..2019] The Accelerate Team + * Copyright : [2017..2020] The Accelerate Team * License : BSD3 * * Maintainer : Trevor L. McDonell diff --git a/cbits/monitoring.c b/cbits/monitoring.c index fc8133267..6c917c84b 100644 --- a/cbits/monitoring.c +++ b/cbits/monitoring.c @@ -1,6 +1,6 @@ /* * Module : Data.Array.Accelerate.Debug.Monitoring - * Copyright : [2016..2019] The Accelerate Team + * Copyright : [2016..2020] The Accelerate Team * License : BSD3 * * Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 87ff15ae2..31017450a 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -4,7 +4,7 @@ -- | -- Module : Data.Array.Accelerate -- Description : The Accelerate standard prelude --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 4d6d04fa3..5d9295e05 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -11,7 +11,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.AST --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/AST/Environment.hs b/src/Data/Array/Accelerate/AST/Environment.hs index 6e0c2d3be..33df02937 100644 --- a/src/Data/Array/Accelerate/AST/Environment.hs +++ b/src/Data/Array/Accelerate/AST/Environment.hs @@ -7,7 +7,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.AST.Environment --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/AST/Idx.hs b/src/Data/Array/Accelerate/AST/Idx.hs index 2026c05a2..494bc057a 100644 --- a/src/Data/Array/Accelerate/AST/Idx.hs +++ b/src/Data/Array/Accelerate/AST/Idx.hs @@ -3,7 +3,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.AST.Idx --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/AST/LeftHandSide.hs b/src/Data/Array/Accelerate/AST/LeftHandSide.hs index fe019a64e..f92b3024a 100644 --- a/src/Data/Array/Accelerate/AST/LeftHandSide.hs +++ b/src/Data/Array/Accelerate/AST/LeftHandSide.hs @@ -6,7 +6,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.AST.LeftHandSide --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/AST/Var.hs b/src/Data/Array/Accelerate/AST/Var.hs index fc7a07661..a0e0d705f 100644 --- a/src/Data/Array/Accelerate/AST/Var.hs +++ b/src/Data/Array/Accelerate/AST/Var.hs @@ -4,7 +4,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.AST.Var --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Analysis/Hash.hs b/src/Data/Array/Accelerate/Analysis/Hash.hs index 6c7d74e24..2c8a38dab 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash.hs @@ -9,7 +9,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Analysis.Hash --- Copyright : [2017..2019] The Accelerate Team +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Analysis/Hash/TH.hs b/src/Data/Array/Accelerate/Analysis/Hash/TH.hs index 06d97a318..50224ff17 100644 --- a/src/Data/Array/Accelerate/Analysis/Hash/TH.hs +++ b/src/Data/Array/Accelerate/Analysis/Hash/TH.hs @@ -1,6 +1,6 @@ -- | -- Module : Data.Array.Accelerate.Analysis.Hash.TH --- Copyright : [2017..2019] The Accelerate Team +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Analysis/Match.hs b/src/Data/Array/Accelerate/Analysis/Match.hs index 3a9dd9d14..98a0818a4 100644 --- a/src/Data/Array/Accelerate/Analysis/Match.hs +++ b/src/Data/Array/Accelerate/Analysis/Match.hs @@ -9,7 +9,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Analysis.Match --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 7eb1ae947..66ff0f44c 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -9,7 +9,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Data --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Array/Remote.hs b/src/Data/Array/Accelerate/Array/Remote.hs index cc8c03ad4..eee2b189d 100644 --- a/src/Data/Array/Accelerate/Array/Remote.hs +++ b/src/Data/Array/Accelerate/Array/Remote.hs @@ -1,7 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Remote --- Copyright : [2015..2019] The Accelerate Team +-- Copyright : [2015..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Array/Remote/Class.hs b/src/Data/Array/Accelerate/Array/Remote/Class.hs index 522e51b5a..7a871bd1a 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Class.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Class.hs @@ -4,7 +4,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Remote.Class --- Copyright : [2015..2019] The Accelerate Team +-- Copyright : [2015..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Array/Remote/LRU.hs b/src/Data/Array/Accelerate/Array/Remote/LRU.hs index e09c01db2..633ddc06d 100644 --- a/src/Data/Array/Accelerate/Array/Remote/LRU.hs +++ b/src/Data/Array/Accelerate/Array/Remote/LRU.hs @@ -12,7 +12,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Remote.LRU --- Copyright : [2015..2019] The Accelerate Team +-- Copyright : [2015..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Array/Remote/Nursery.hs b/src/Data/Array/Accelerate/Array/Remote/Nursery.hs index 816a30b8f..7965e5bf9 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Nursery.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Nursery.hs @@ -2,7 +2,7 @@ {-# LANGUAGE LambdaCase #-} -- | -- Module : Data.Array.Accelerate.Array.Remote.Nursery --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Array/Remote/Table.hs b/src/Data/Array/Accelerate/Array/Remote/Table.hs index e7f77f69c..3e95d3222 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Table.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Table.hs @@ -15,7 +15,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Remote.Table --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Array/Unique.hs b/src/Data/Array/Accelerate/Array/Unique.hs index a54634a20..5dbd05492 100644 --- a/src/Data/Array/Accelerate/Array/Unique.hs +++ b/src/Data/Array/Accelerate/Array/Unique.hs @@ -4,7 +4,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Array.Unique --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Async.hs b/src/Data/Array/Accelerate/Async.hs index b227a5320..c7a7aae2c 100644 --- a/src/Data/Array/Accelerate/Async.hs +++ b/src/Data/Array/Accelerate/Async.hs @@ -4,7 +4,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Async --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes.hs b/src/Data/Array/Accelerate/Classes.hs index 7e7d15092..34c7ef396 100644 --- a/src/Data/Array/Accelerate/Classes.hs +++ b/src/Data/Array/Accelerate/Classes.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : Data.Array.Accelerate.Classes --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Bounded.hs b/src/Data/Array/Accelerate/Classes/Bounded.hs index 4d1fb7b97..16b5d6d2a 100644 --- a/src/Data/Array/Accelerate/Classes/Bounded.hs +++ b/src/Data/Array/Accelerate/Classes/Bounded.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Bounded --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Enum.hs b/src/Data/Array/Accelerate/Classes/Enum.hs index ae11bd347..84b344273 100644 --- a/src/Data/Array/Accelerate/Classes/Enum.hs +++ b/src/Data/Array/Accelerate/Classes/Enum.hs @@ -5,7 +5,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Enum --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index 18be66fc3..c3f5c76df 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -12,7 +12,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Eq --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Floating.hs b/src/Data/Array/Accelerate/Classes/Floating.hs index a132a7040..b2f067af9 100644 --- a/src/Data/Array/Accelerate/Classes/Floating.hs +++ b/src/Data/Array/Accelerate/Classes/Floating.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Floating --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Fractional.hs b/src/Data/Array/Accelerate/Classes/Fractional.hs index b297aa037..52bdc61e9 100644 --- a/src/Data/Array/Accelerate/Classes/Fractional.hs +++ b/src/Data/Array/Accelerate/Classes/Fractional.hs @@ -5,7 +5,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Fractional --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/FromIntegral.hs b/src/Data/Array/Accelerate/Classes/FromIntegral.hs index 64b6089e8..d8678ee9d 100644 --- a/src/Data/Array/Accelerate/Classes/FromIntegral.hs +++ b/src/Data/Array/Accelerate/Classes/FromIntegral.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.Classes.FromIntegral --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Integral.hs b/src/Data/Array/Accelerate/Classes/Integral.hs index 312c9e0cd..c6cadf7cc 100644 --- a/src/Data/Array/Accelerate/Classes/Integral.hs +++ b/src/Data/Array/Accelerate/Classes/Integral.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Integral --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Num.hs b/src/Data/Array/Accelerate/Classes/Num.hs index b7570f75d..942b38673 100644 --- a/src/Data/Array/Accelerate/Classes/Num.hs +++ b/src/Data/Array/Accelerate/Classes/Num.hs @@ -5,7 +5,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Num --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Ord.hs b/src/Data/Array/Accelerate/Classes/Ord.hs index f3e46f7c1..7dbd140fd 100644 --- a/src/Data/Array/Accelerate/Classes/Ord.hs +++ b/src/Data/Array/Accelerate/Classes/Ord.hs @@ -13,7 +13,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Ord --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Rational.hs b/src/Data/Array/Accelerate/Classes/Rational.hs index c5ee9db30..a668e5ef1 100644 --- a/src/Data/Array/Accelerate/Classes/Rational.hs +++ b/src/Data/Array/Accelerate/Classes/Rational.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Data.Array.Accelerate.Classes.Rational --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/Real.hs b/src/Data/Array/Accelerate/Classes/Real.hs index 879f1f0e3..a6bd1b185 100644 --- a/src/Data/Array/Accelerate/Classes/Real.hs +++ b/src/Data/Array/Accelerate/Classes/Real.hs @@ -7,7 +7,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.Real --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs b/src/Data/Array/Accelerate/Classes/RealFloat.hs index 5d1200210..140dce286 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs @@ -10,7 +10,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.RealFloat --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot b/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot index 6085b7841..a4f2878bd 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs-boot @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Data.Array.Accelerate.Classes.RealFloat --- Copyright : [2019] The Accelerate Team +-- Copyright : [2019..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs b/src/Data/Array/Accelerate/Classes/RealFrac.hs index 52c0f330b..9a12e5029 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs @@ -8,7 +8,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Classes.RealFrac --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/RealFrac.hs-boot b/src/Data/Array/Accelerate/Classes/RealFrac.hs-boot index 00a7f96c9..0c2fa7307 100644 --- a/src/Data/Array/Accelerate/Classes/RealFrac.hs-boot +++ b/src/Data/Array/Accelerate/Classes/RealFrac.hs-boot @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : Data.Array.Accelerate.Classes.RealFrac --- Copyright : [2019] The Accelerate Team +-- Copyright : [2019..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Classes/ToFloating.hs b/src/Data/Array/Accelerate/Classes/ToFloating.hs index 0bab978d7..c3f4545c6 100644 --- a/src/Data/Array/Accelerate/Classes/ToFloating.hs +++ b/src/Data/Array/Accelerate/Classes/ToFloating.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.Classes.ToFloating --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Bits.hs b/src/Data/Array/Accelerate/Data/Bits.hs index 58c746d2a..19a2890ce 100644 --- a/src/Data/Array/Accelerate/Data/Bits.hs +++ b/src/Data/Array/Accelerate/Data/Bits.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Data.Bits --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index c763c0d3f..d46c279c5 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -15,7 +15,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Complex --- Copyright : [2015..2019] The Accelerate Team +-- Copyright : [2015..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Either.hs b/src/Data/Array/Accelerate/Data/Either.hs index 24bfa1e33..00d2fb960 100644 --- a/src/Data/Array/Accelerate/Data/Either.hs +++ b/src/Data/Array/Accelerate/Data/Either.hs @@ -15,7 +15,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Either --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Fold.hs b/src/Data/Array/Accelerate/Data/Fold.hs index a37581cce..f38f770ac 100644 --- a/src/Data/Array/Accelerate/Data/Fold.hs +++ b/src/Data/Array/Accelerate/Data/Fold.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Data.Fold --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Functor.hs b/src/Data/Array/Accelerate/Data/Functor.hs index ee3fa4b19..60015e1b7 100644 --- a/src/Data/Array/Accelerate/Data/Functor.hs +++ b/src/Data/Array/Accelerate/Data/Functor.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RebindableSyntax #-} -- | -- Module : Data.Array.Accelerate.Data.Functor --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Maybe.hs b/src/Data/Array/Accelerate/Data/Maybe.hs index 89688e89b..cebf7f895 100644 --- a/src/Data/Array/Accelerate/Data/Maybe.hs +++ b/src/Data/Array/Accelerate/Data/Maybe.hs @@ -15,7 +15,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Maybe --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Monoid.hs b/src/Data/Array/Accelerate/Data/Monoid.hs index 691f57fc4..23576be77 100644 --- a/src/Data/Array/Accelerate/Data/Monoid.hs +++ b/src/Data/Array/Accelerate/Data/Monoid.hs @@ -14,7 +14,7 @@ #endif -- | -- Module : Data.Array.Accelerate.Data.Monoid --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Ratio.hs b/src/Data/Array/Accelerate/Data/Ratio.hs index d78ad9d59..190317297 100644 --- a/src/Data/Array/Accelerate/Data/Ratio.hs +++ b/src/Data/Array/Accelerate/Data/Ratio.hs @@ -10,7 +10,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Data.Ratio --- Copyright : [2019] The Accelerate Team +-- Copyright : [2019..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Data/Semigroup.hs b/src/Data/Array/Accelerate/Data/Semigroup.hs index 79e6a2d22..030c51243 100644 --- a/src/Data/Array/Accelerate/Data/Semigroup.hs +++ b/src/Data/Array/Accelerate/Data/Semigroup.hs @@ -15,7 +15,7 @@ #endif -- | -- Module : Data.Array.Accelerate.Data.Semigroup --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Debug.hs b/src/Data/Array/Accelerate/Debug.hs index 3a47435e3..33729c1f6 100644 --- a/src/Data/Array/Accelerate/Debug.hs +++ b/src/Data/Array/Accelerate/Debug.hs @@ -2,7 +2,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Debug --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Debug/Clock.hs b/src/Data/Array/Accelerate/Debug/Clock.hs index b75433266..f96b02722 100644 --- a/src/Data/Array/Accelerate/Debug/Clock.hs +++ b/src/Data/Array/Accelerate/Debug/Clock.hs @@ -3,7 +3,7 @@ {-# OPTIONS_GHC -fobject-code #-} -- | -- Module : Data.Array.Accelerate.Debug.Clock --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Debug/Flags.hs b/src/Data/Array/Accelerate/Debug/Flags.hs index e0c46a4f6..97dfbe30c 100644 --- a/src/Data/Array/Accelerate/Debug/Flags.hs +++ b/src/Data/Array/Accelerate/Debug/Flags.hs @@ -8,7 +8,7 @@ {-# OPTIONS_GHC -fobject-code #-} -- SEE: [linking to .c files] -- | -- Module : Data.Array.Accelerate.Debug.Flags --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Debug/Monitoring.hs b/src/Data/Array/Accelerate/Debug/Monitoring.hs index 545b1c521..d85631252 100644 --- a/src/Data/Array/Accelerate/Debug/Monitoring.hs +++ b/src/Data/Array/Accelerate/Debug/Monitoring.hs @@ -8,7 +8,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Debug.Monitoring --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Debug/Stats.hs b/src/Data/Array/Accelerate/Debug/Stats.hs index bd3e5ef36..95cd16cfe 100644 --- a/src/Data/Array/Accelerate/Debug/Stats.hs +++ b/src/Data/Array/Accelerate/Debug/Stats.hs @@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | -- Module : Data.Array.Accelerate.Debug.Simpl --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Debug/Timed.hs b/src/Data/Array/Accelerate/Debug/Timed.hs index e6467dcf6..29584e82c 100644 --- a/src/Data/Array/Accelerate/Debug/Timed.hs +++ b/src/Data/Array/Accelerate/Debug/Timed.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MagicHash #-} -- | -- Module : Data.Array.Accelerate.Debug.Timed --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Debug/Trace.hs b/src/Data/Array/Accelerate/Debug/Trace.hs index f252535ca..1a882edbf 100644 --- a/src/Data/Array/Accelerate/Debug/Trace.hs +++ b/src/Data/Array/Accelerate/Debug/Trace.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} -- | -- Module : Data.Array.Accelerate.Debug.Trace --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Error.hs b/src/Data/Array/Accelerate/Error.hs index ec6de19d8..0d39a9765 100644 --- a/src/Data/Array/Accelerate/Error.hs +++ b/src/Data/Array/Accelerate/Error.hs @@ -3,7 +3,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Error --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index d0d8fc8ef..c8da5b100 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -15,7 +15,7 @@ -- | -- Module : Data.Array.Accelerate.Interpreter -- Description : Reference backend (interpreted) --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index bd130499a..242f1abed 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -9,7 +9,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Language --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Lifetime.hs b/src/Data/Array/Accelerate/Lifetime.hs index ba39bd002..7a9dacf37 100644 --- a/src/Data/Array/Accelerate/Lifetime.hs +++ b/src/Data/Array/Accelerate/Lifetime.hs @@ -4,7 +4,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Lifetime --- Copyright : [2015..2019] The Accelerate Team +-- Copyright : [2015..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Lift.hs b/src/Data/Array/Accelerate/Lift.hs index 380bdc6bc..a0930b5b7 100644 --- a/src/Data/Array/Accelerate/Lift.hs +++ b/src/Data/Array/Accelerate/Lift.hs @@ -14,7 +14,7 @@ #endif -- | -- Module : Data.Array.Accelerate.Lift --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Orphans.hs b/src/Data/Array/Accelerate/Orphans.hs index 7d0b8e29f..0722c3287 100644 --- a/src/Data/Array/Accelerate/Orphans.hs +++ b/src/Data/Array/Accelerate/Orphans.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Orphans --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index daa45377a..76efb340f 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -15,7 +15,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pattern --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pattern/Bool.hs b/src/Data/Array/Accelerate/Pattern/Bool.hs index 947f85fea..d968aaf34 100644 --- a/src/Data/Array/Accelerate/Pattern/Bool.hs +++ b/src/Data/Array/Accelerate/Pattern/Bool.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pattern.Bool --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pattern/Either.hs b/src/Data/Array/Accelerate/Pattern/Either.hs index 1aa91b5e0..67c7b3a3f 100644 --- a/src/Data/Array/Accelerate/Pattern/Either.hs +++ b/src/Data/Array/Accelerate/Pattern/Either.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pattern.Either --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pattern/Maybe.hs b/src/Data/Array/Accelerate/Pattern/Maybe.hs index 50d72557d..67e341d64 100644 --- a/src/Data/Array/Accelerate/Pattern/Maybe.hs +++ b/src/Data/Array/Accelerate/Pattern/Maybe.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pattern.Maybe --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pattern/Ordering.hs b/src/Data/Array/Accelerate/Pattern/Ordering.hs index 233cb8328..2407cf9e9 100644 --- a/src/Data/Array/Accelerate/Pattern/Ordering.hs +++ b/src/Data/Array/Accelerate/Pattern/Ordering.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pattern.Ordering --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pattern/TH.hs b/src/Data/Array/Accelerate/Pattern/TH.hs index b67aaaf79..333142dce 100644 --- a/src/Data/Array/Accelerate/Pattern/TH.hs +++ b/src/Data/Array/Accelerate/Pattern/TH.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Pattern.TH --- Copyright : [2018..2019] The Accelerate Team +-- Copyright : [2018..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 3a4744a14..a88cdb42c 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -15,7 +15,7 @@ {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- pattern synonyms -- | -- Module : Data.Array.Accelerate.Prelude --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index dde59525a..ca4d66039 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -10,7 +10,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Pretty --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index b8e2dc1ee..fcc8ce3d8 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -12,7 +12,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pretty.Graphviz --- Copyright : [2015..2019] The Accelerate Team +-- Copyright : [2015..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs b/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs index 09cabcc47..eb7b6f8b0 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz/Monad.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-} -- | -- Module : Data.Array.Accelerate.Pretty.Graphviz.Monad --- Copyright : [2015..2019] The Accelerate Team +-- Copyright : [2015..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs b/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs index 3f3f2de22..79a16c6c8 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz/Type.hs @@ -3,7 +3,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pretty.Graphviz.Type --- Copyright : [2015..2019] The Accelerate Team +-- Copyright : [2015..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 4b2026fb7..4e6ee83ef 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -11,7 +11,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Pretty.Print --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Representation/Elt.hs b/src/Data/Array/Accelerate/Representation/Elt.hs index ea6b468b5..081ba4369 100644 --- a/src/Data/Array/Accelerate/Representation/Elt.hs +++ b/src/Data/Array/Accelerate/Representation/Elt.hs @@ -5,7 +5,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Representation.Elt --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Representation/Stencil.hs b/src/Data/Array/Accelerate/Representation/Stencil.hs index 81855cd90..f237d990c 100644 --- a/src/Data/Array/Accelerate/Representation/Stencil.hs +++ b/src/Data/Array/Accelerate/Representation/Stencil.hs @@ -3,7 +3,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Representation.Stencil --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Representation/Vec.hs b/src/Data/Array/Accelerate/Representation/Vec.hs index e10f25ce2..84cb4c73b 100644 --- a/src/Data/Array/Accelerate/Representation/Vec.hs +++ b/src/Data/Array/Accelerate/Representation/Vec.hs @@ -8,7 +8,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Representation.Vec --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 9bfc7967d..6cff9f6b2 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -14,7 +14,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Smart --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Sugar/Array.hs b/src/Data/Array/Accelerate/Sugar/Array.hs index 6efeace6e..bef852e1d 100644 --- a/src/Data/Array/Accelerate/Sugar/Array.hs +++ b/src/Data/Array/Accelerate/Sugar/Array.hs @@ -11,7 +11,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Sugar.Array --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Sugar/Elt.hs b/src/Data/Array/Accelerate/Sugar/Elt.hs index ddb000518..9ef734d5b 100644 --- a/src/Data/Array/Accelerate/Sugar/Elt.hs +++ b/src/Data/Array/Accelerate/Sugar/Elt.hs @@ -13,7 +13,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Sugar.Elt --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Sugar/Foreign.hs b/src/Data/Array/Accelerate/Sugar/Foreign.hs index b6dc7b4a8..6fbcc5297 100644 --- a/src/Data/Array/Accelerate/Sugar/Foreign.hs +++ b/src/Data/Array/Accelerate/Sugar/Foreign.hs @@ -2,7 +2,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Sugar.Foreign --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Sugar/Shape.hs b/src/Data/Array/Accelerate/Sugar/Shape.hs index d4677e77c..a60f904c2 100644 --- a/src/Data/Array/Accelerate/Sugar/Shape.hs +++ b/src/Data/Array/Accelerate/Sugar/Shape.hs @@ -11,7 +11,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Sugar.Shape --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Sugar/Stencil.hs b/src/Data/Array/Accelerate/Sugar/Stencil.hs index 9fa49629a..15039c320 100644 --- a/src/Data/Array/Accelerate/Sugar/Stencil.hs +++ b/src/Data/Array/Accelerate/Sugar/Stencil.hs @@ -10,7 +10,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Sugar.Stencil --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Sugar/Vec.hs b/src/Data/Array/Accelerate/Sugar/Vec.hs index 488537793..723d32c7b 100644 --- a/src/Data/Array/Accelerate/Sugar/Vec.hs +++ b/src/Data/Array/Accelerate/Sugar/Vec.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Array.Accelerate.Sugar.Vec --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib.hs b/src/Data/Array/Accelerate/Test/NoFib.hs index a81d298e6..b1b31dd04 100644 --- a/src/Data/Array/Accelerate/Test/NoFib.hs +++ b/src/Data/Array/Accelerate/Test/NoFib.hs @@ -3,7 +3,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Base.hs b/src/Data/Array/Accelerate/Test/NoFib/Base.hs index 4df85e395..1307c6cbb 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Base.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Base.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Base --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Config.hs b/src/Data/Array/Accelerate/Test/NoFib/Config.hs index 657e00d9c..6e9ecd590 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Config.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Config.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Config --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs index 992d11820..eab17e9c4 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Imaginary --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs index 9c2e3f486..b89174831 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/DotP.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Imaginary.DotP --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs index 42068ee71..52f4face8 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SASUM.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Imaginary.SASUM --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs index 7f2e84e51..0314d03bf 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Imaginary/SAXPY.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Imaginary.SAXPY --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs index 21087fffe..f1a5e2b1d 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs index 592e98523..dedec6cf6 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue102.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue102 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs index 7bf8df932..bad2de273 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue114.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue114 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs index 58d486d8e..6bcab3d55 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue119.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue119 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs index 95972d3fe..239c04201 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue123.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue123 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs index 0247563df..7e2e69a69 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue137 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs index 05a320ad7..ed096251b 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue168.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue168 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs index eaa9c8f19..2e8a848f3 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue184.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue184 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs index 0b04206f3..56f75b144 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue185 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs index 140f015eb..9c11a5d85 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue187.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue187 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs index 579510d67..4015773c9 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue228.hs @@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue228 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs index 3fd518259..23491188b 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue255.hs @@ -5,7 +5,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue255 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs index e6f6430ad..afdbe9294 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue264.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue264 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue286.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue286.hs index c9d47f5f5..5a9feb17b 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue286.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue286.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue286 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs index ac223e261..3f0216cb3 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue287.hs @@ -4,7 +4,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue287 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs index 0d9e85033..84c18a7d5 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue288.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue288 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs index cb3440421..77365ce80 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue362.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue362 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs index 0444d5664..ddc167342 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue364.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue364 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs index f13531bbe..1f42aa3f9 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue407.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue407 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs index 87f7bc0f8..3486ccb4f 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue409.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue409 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs index bf028b8e2..57420f447 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue436.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue436 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs index e377bd160..956b6956e 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue437.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue437 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs index f0c295649..3bfa18b40 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue439.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue439 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs index 982361008..0b1ad4571 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Issues.Issue93 --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs index ec263b231..3a3508228 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs index 053b5278e..4b2ba6f1b 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Backpermute.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Backpermute --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs index 3cd23ffa9..cfafc2da1 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Filter.hs @@ -9,7 +9,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Filter --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs index 47f5bc41c..8219c8806 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Fold.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Fold --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs index 57ae9591b..dec03973d 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Map.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Map --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs index 0e007e4a0..abcc5f705 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Permute.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Permute --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs index 620f40419..cc8b69e1b 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/SIMD.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.SIMD --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs index d2c405d53..71aa2b9b3 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Scan.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Scan --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs index d4188a550..c6c44bba1 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/Stencil.hs @@ -10,7 +10,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.Stencil --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs b/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs index d52058280..b73785db2 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Prelude/ZipWith.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Prelude.ZipWith --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs b/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs index 7ee5e0aa7..8c1b348c3 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Sharing.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Sharing --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral.hs index 9b0933433..ee9246279 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Spectral --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs index c3e49e471..4bd106ee7 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/BlackScholes.hs @@ -8,7 +8,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Spectral.BlackScholes --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs index 5c85e5ef1..7aff75ac3 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Spectral.RadixSort --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs index 874953632..3aba23a7a 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/SMVM.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Test.NoFib.Spectral.SMVM --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Test/Similar.hs b/src/Data/Array/Accelerate/Test/Similar.hs index da802e0fa..1017408cc 100644 --- a/src/Data/Array/Accelerate/Test/Similar.hs +++ b/src/Data/Array/Accelerate/Test/Similar.hs @@ -6,7 +6,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Test.Similar --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo.hs b/src/Data/Array/Accelerate/Trafo.hs index d5c3005c2..7e82abd06 100644 --- a/src/Data/Array/Accelerate/Trafo.hs +++ b/src/Data/Array/Accelerate/Trafo.hs @@ -2,7 +2,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Algebra.hs b/src/Data/Array/Accelerate/Trafo/Algebra.hs index 82ef1550b..77f242238 100644 --- a/src/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/src/Data/Array/Accelerate/Trafo/Algebra.hs @@ -10,7 +10,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Trafo.Algebra --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Config.hs b/src/Data/Array/Accelerate/Trafo/Config.hs index e43f6a4f8..529f15cd2 100644 --- a/src/Data/Array/Accelerate/Trafo/Config.hs +++ b/src/Data/Array/Accelerate/Trafo/Config.hs @@ -1,7 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Config --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Delayed.hs b/src/Data/Array/Accelerate/Trafo/Delayed.hs index 03c440eb9..c5166cc83 100644 --- a/src/Data/Array/Accelerate/Trafo/Delayed.hs +++ b/src/Data/Array/Accelerate/Trafo/Delayed.hs @@ -9,7 +9,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Delayed --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Environment.hs b/src/Data/Array/Accelerate/Trafo/Environment.hs index b93c9db92..351f7cdb1 100644 --- a/src/Data/Array/Accelerate/Trafo/Environment.hs +++ b/src/Data/Array/Accelerate/Trafo/Environment.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Trafo.Environment --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 37ef0abf1..9a6f39f5b 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -17,7 +17,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Fusion --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/LetSplit.hs b/src/Data/Array/Accelerate/Trafo/LetSplit.hs index 236aa0e6d..acf5453d9 100644 --- a/src/Data/Array/Accelerate/Trafo/LetSplit.hs +++ b/src/Data/Array/Accelerate/Trafo/LetSplit.hs @@ -2,7 +2,7 @@ {-# LANGUAGE GADTs #-} -- | -- Module : Data.Array.Accelerate.Trafo.LetSplit --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Normalise.hs b/src/Data/Array/Accelerate/Trafo/Normalise.hs index 7124e9889..53f84cb72 100644 --- a/src/Data/Array/Accelerate/Trafo/Normalise.hs +++ b/src/Data/Array/Accelerate/Trafo/Normalise.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} -- | -- Module : Data.Array.Accelerate.Trafo.Normalise --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 23ebc0917..3dd2bb411 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -17,7 +17,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Sharing --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 856be9a67..13e3d902f 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -11,7 +11,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Trafo.Shrink --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index 79b341257..872c8453c 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -14,7 +14,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Trafo.Simplify --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 6359615ec..0a149a075 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -15,7 +15,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Trafo.Substitution --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Var.hs b/src/Data/Array/Accelerate/Trafo/Var.hs index d5829671b..76cb2b741 100644 --- a/src/Data/Array/Accelerate/Trafo/Var.hs +++ b/src/Data/Array/Accelerate/Trafo/Var.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Trafo.Var --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Trafo/Vectorise.hs b/src/Data/Array/Accelerate/Trafo/Vectorise.hs index 41d8350dc..aa5c8d8f8 100644 --- a/src/Data/Array/Accelerate/Trafo/Vectorise.hs +++ b/src/Data/Array/Accelerate/Trafo/Vectorise.hs @@ -17,7 +17,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | -- Module : Data.Array.Accelerate.Trafo.Vectorise --- Copyright : [2012..2019] The Accelerate Team +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index 51b2bb8c1..ac330f50d 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -17,7 +17,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Type --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Array/Accelerate/Unsafe.hs b/src/Data/Array/Accelerate/Unsafe.hs index dcb8e95c7..289cf7a2b 100644 --- a/src/Data/Array/Accelerate/Unsafe.hs +++ b/src/Data/Array/Accelerate/Unsafe.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Data.Array.Accelerate.Unsafe --- Copyright : [2009..2019] The Accelerate Team +-- Copyright : [2009..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Atomic.hs b/src/Data/Atomic.hs index e200e40df..2c1f8ef39 100644 --- a/src/Data/Atomic.hs +++ b/src/Data/Atomic.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fobject-code #-} -- | -- Module : Data.Atomic --- Copyright : [2016..2019] The Accelerate Team +-- Copyright : [2016..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/BitSet.hs b/src/Data/BitSet.hs index 676963397..f06169bcf 100644 --- a/src/Data/BitSet.hs +++ b/src/Data/BitSet.hs @@ -3,7 +3,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.BitSet --- Copyright : [2019] The Accelerate Team +-- Copyright : [2019..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Data/Primitive/Vec.hs b/src/Data/Primitive/Vec.hs index 8ae7ff2d3..734430e8b 100644 --- a/src/Data/Primitive/Vec.hs +++ b/src/Data/Primitive/Vec.hs @@ -13,7 +13,7 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Primitive.Vec --- Copyright : [2008..2019] The Accelerate Team +-- Copyright : [2008..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/src/Language/Haskell/TH/Extra.hs b/src/Language/Haskell/TH/Extra.hs index ae0e25984..ed92b0f25 100644 --- a/src/Language/Haskell/TH/Extra.hs +++ b/src/Language/Haskell/TH/Extra.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} -- | -- Module : Language.Haskell.TH.Extra --- Copyright : [2019] The Accelerate Team +-- Copyright : [2019..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/test/doctest/Main.hs b/test/doctest/Main.hs index 68e7106ef..d2b98743e 100644 --- a/test/doctest/Main.hs +++ b/test/doctest/Main.hs @@ -1,6 +1,6 @@ -- | -- Module : Main --- Copyright : [2017..2019] The Accelerate Team +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell diff --git a/test/nofib/Main.hs b/test/nofib/Main.hs index 47ba1e1cd..1e82cce7f 100644 --- a/test/nofib/Main.hs +++ b/test/nofib/Main.hs @@ -1,6 +1,6 @@ -- | -- Module : nofib-interpreter --- Copyright : [2017..2019] The Accelerate Team +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- -- Maintainer : Trevor L. McDonell From cb58da3d40529d534e05e4541ce9d39ae069e70d Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 9 Jul 2020 14:32:51 +0200 Subject: [PATCH 288/316] export module D.A.A.Trafo.Substitution --- accelerate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/accelerate.cabal b/accelerate.cabal index ec06b7514..ab11b296b 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -351,6 +351,7 @@ Library Data.Array.Accelerate.Trafo.Delayed Data.Array.Accelerate.Trafo.Fusion Data.Array.Accelerate.Trafo.Sharing + Data.Array.Accelerate.Trafo.Substitution Data.Array.Accelerate.Type -- For testing @@ -404,7 +405,6 @@ Library Data.Array.Accelerate.Trafo.LetSplit Data.Array.Accelerate.Trafo.Shrink Data.Array.Accelerate.Trafo.Simplify - Data.Array.Accelerate.Trafo.Substitution Data.Array.Accelerate.Trafo.Var Data.Atomic From aca8e9a575c945ee9ca882bb8e1267016343e4c7 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 9 Jul 2020 16:55:46 +0200 Subject: [PATCH 289/316] reexport HasCallStack --- src/Data/Array/Accelerate/AST.hs | 1 - src/Data/Array/Accelerate/AST/Environment.hs | 2 -- src/Data/Array/Accelerate/Array/Data.hs | 1 - src/Data/Array/Accelerate/Array/Remote/Nursery.hs | 2 -- src/Data/Array/Accelerate/Classes/RealFloat.hs | 2 -- src/Data/Array/Accelerate/Error.hs | 1 + src/Data/Array/Accelerate/Interpreter.hs | 2 -- src/Data/Array/Accelerate/Pretty.hs | 2 -- src/Data/Array/Accelerate/Pretty/Graphviz.hs | 2 -- src/Data/Array/Accelerate/Representation/Array.hs | 2 -- src/Data/Array/Accelerate/Representation/Shape.hs | 1 - src/Data/Array/Accelerate/Smart.hs | 1 - src/Data/Array/Accelerate/Sugar/Foreign.hs | 2 -- src/Data/Array/Accelerate/Trafo/Environment.hs | 2 -- src/Data/Array/Accelerate/Trafo/Fusion.hs | 2 -- src/Data/Array/Accelerate/Trafo/Sharing.hs | 2 -- src/Data/Array/Accelerate/Trafo/Shrink.hs | 2 -- src/Data/Array/Accelerate/Trafo/Simplify.hs | 2 -- src/Data/Array/Accelerate/Trafo/Substitution.hs | 2 -- 19 files changed, 1 insertion(+), 32 deletions(-) diff --git a/src/Data/Array/Accelerate/AST.hs b/src/Data/Array/Accelerate/AST.hs index 5d9295e05..92d1e0060 100644 --- a/src/Data/Array/Accelerate/AST.hs +++ b/src/Data/Array/Accelerate/AST.hs @@ -153,7 +153,6 @@ import Language.Haskell.TH ( Q, TExp ) import Prelude import GHC.TypeLits -import GHC.Stack -- Array expressions diff --git a/src/Data/Array/Accelerate/AST/Environment.hs b/src/Data/Array/Accelerate/AST/Environment.hs index 33df02937..78c296d98 100644 --- a/src/Data/Array/Accelerate/AST/Environment.hs +++ b/src/Data/Array/Accelerate/AST/Environment.hs @@ -22,8 +22,6 @@ import Data.Array.Accelerate.AST.Idx import Data.Array.Accelerate.AST.LeftHandSide import Data.Array.Accelerate.Error -import GHC.Stack - -- Valuation for an environment -- diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 66ff0f44c..61d456e33 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -77,7 +77,6 @@ import Prelude hiding ( map import GHC.Base import GHC.ForeignPtr import GHC.Ptr -import GHC.Stack -- | Immutable array representation diff --git a/src/Data/Array/Accelerate/Array/Remote/Nursery.hs b/src/Data/Array/Accelerate/Array/Remote/Nursery.hs index 7965e5bf9..20019bab9 100644 --- a/src/Data/Array/Accelerate/Array/Remote/Nursery.hs +++ b/src/Data/Array/Accelerate/Array/Remote/Nursery.hs @@ -31,8 +31,6 @@ import qualified Data.HashTable.IO as HT import qualified Data.Sequence as Seq import qualified Data.Traversable as Seq -import GHC.Stack - -- 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 diff --git a/src/Data/Array/Accelerate/Classes/RealFloat.hs b/src/Data/Array/Accelerate/Classes/RealFloat.hs index 140dce286..8667ef485 100644 --- a/src/Data/Array/Accelerate/Classes/RealFloat.hs +++ b/src/Data/Array/Accelerate/Classes/RealFloat.hs @@ -43,8 +43,6 @@ import Text.Printf import Prelude ( (.), ($), String, error, undefined, unlines, otherwise ) import qualified Prelude as P -import GHC.Stack - -- | Efficient, machine-independent access to the components of a floating-point -- number diff --git a/src/Data/Array/Accelerate/Error.hs b/src/Data/Array/Accelerate/Error.hs index 0d39a9765..fbc2aacaf 100644 --- a/src/Data/Array/Accelerate/Error.hs +++ b/src/Data/Array/Accelerate/Error.hs @@ -13,6 +13,7 @@ module Data.Array.Accelerate.Error ( + HasCallStack, internalError, boundsError, unsafeError, internalCheck, boundsCheck, unsafeCheck, indexCheck, internalWarning, boundsWarning, unsafeWarning, diff --git a/src/Data/Array/Accelerate/Interpreter.hs b/src/Data/Array/Accelerate/Interpreter.hs index c8da5b100..eaac9fd8f 100644 --- a/src/Data/Array/Accelerate/Interpreter.hs +++ b/src/Data/Array/Accelerate/Interpreter.hs @@ -77,8 +77,6 @@ import Text.Printf ( printf ) import Unsafe.Coerce import Prelude hiding ( (!!), sum ) -import GHC.Stack - -- Program execution -- ----------------- diff --git a/src/Data/Array/Accelerate/Pretty.hs b/src/Data/Array/Accelerate/Pretty.hs index ca4d66039..b83c63160 100644 --- a/src/Data/Array/Accelerate/Pretty.hs +++ b/src/Data/Array/Accelerate/Pretty.hs @@ -61,8 +61,6 @@ import Data.Array.Accelerate.Debug.Flags import Data.Array.Accelerate.Debug.Stats #endif -import GHC.Stack - instance Arrays arrs => Show (Acc arrs) where show = withSimplStats . show . convertAcc diff --git a/src/Data/Array/Accelerate/Pretty/Graphviz.hs b/src/Data/Array/Accelerate/Pretty/Graphviz.hs index fcc8ce3d8..8ebe845eb 100644 --- a/src/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/src/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -57,8 +57,6 @@ import Prelude hiding ( exp ) import qualified Data.HashSet as Set import qualified Data.Sequence as Seq -import GHC.Stack - -- Configuration options -- --------------------- diff --git a/src/Data/Array/Accelerate/Representation/Array.hs b/src/Data/Array/Accelerate/Representation/Array.hs index a29c31a0f..4b28def23 100644 --- a/src/Data/Array/Accelerate/Representation/Array.hs +++ b/src/Data/Array/Accelerate/Representation/Array.hs @@ -32,8 +32,6 @@ import Text.Show ( showListWi import Prelude hiding ( (!!) ) import qualified Data.Vector.Unboxed as U -import GHC.Stack - -- | Array data type, where the type arguments regard the representation -- types of the shape and elements. diff --git a/src/Data/Array/Accelerate/Representation/Shape.hs b/src/Data/Array/Accelerate/Representation/Shape.hs index 896bde50c..c7e15a418 100644 --- a/src/Data/Array/Accelerate/Representation/Shape.hs +++ b/src/Data/Array/Accelerate/Representation/Shape.hs @@ -23,7 +23,6 @@ import Language.Haskell.TH import Prelude hiding ( zip ) import GHC.Base ( quotInt, remInt ) -import GHC.Stack -- | Shape and index representations as nested pairs diff --git a/src/Data/Array/Accelerate/Smart.hs b/src/Data/Array/Accelerate/Smart.hs index 6cff9f6b2..4d3c56a86 100644 --- a/src/Data/Array/Accelerate/Smart.hs +++ b/src/Data/Array/Accelerate/Smart.hs @@ -111,7 +111,6 @@ import Data.Kind import Prelude import GHC.TypeLits -import GHC.Stack -- Array computations diff --git a/src/Data/Array/Accelerate/Sugar/Foreign.hs b/src/Data/Array/Accelerate/Sugar/Foreign.hs index 6fbcc5297..c07dccf29 100644 --- a/src/Data/Array/Accelerate/Sugar/Foreign.hs +++ b/src/Data/Array/Accelerate/Sugar/Foreign.hs @@ -18,8 +18,6 @@ import Data.Array.Accelerate.Error import Data.Typeable import Language.Haskell.TH -import GHC.Stack - -- 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 diff --git a/src/Data/Array/Accelerate/Trafo/Environment.hs b/src/Data/Array/Accelerate/Trafo/Environment.hs index 351f7cdb1..c08e84599 100644 --- a/src/Data/Array/Accelerate/Trafo/Environment.hs +++ b/src/Data/Array/Accelerate/Trafo/Environment.hs @@ -27,8 +27,6 @@ import Data.Array.Accelerate.Type import Data.Array.Accelerate.Debug.Stats as Stats -import GHC.Stack - -- An environment that holds let-bound scalar expressions. The second -- environment variable env' is used to project out the corresponding diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 9a6f39f5b..2ada0a3d3 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -70,8 +70,6 @@ import System.IO.Unsafe -- for debugging import Control.Lens ( over, mapped, _2 ) import Prelude hiding ( exp, until ) -import GHC.Stack - -- Delayed Array Fusion -- ==================== diff --git a/src/Data/Array/Accelerate/Trafo/Sharing.hs b/src/Data/Array/Accelerate/Trafo/Sharing.hs index 3dd2bb411..5d05aab18 100644 --- a/src/Data/Array/Accelerate/Trafo/Sharing.hs +++ b/src/Data/Array/Accelerate/Trafo/Sharing.hs @@ -87,8 +87,6 @@ import qualified Data.HashTable.IO as Hash import qualified Data.IntMap as IntMap import Prelude -import GHC.Stack - -- Layouts -- ------- diff --git a/src/Data/Array/Accelerate/Trafo/Shrink.hs b/src/Data/Array/Accelerate/Trafo/Shrink.hs index 13e3d902f..8916cc7ee 100644 --- a/src/Data/Array/Accelerate/Trafo/Shrink.hs +++ b/src/Data/Array/Accelerate/Trafo/Shrink.hs @@ -61,8 +61,6 @@ import Data.Monoid import Data.Semigroup import Prelude hiding ( exp, seq ) -import GHC.Stack - data VarsRange env = VarsRange !(Exists (Idx env)) -- rightmost variable diff --git a/src/Data/Array/Accelerate/Trafo/Simplify.hs b/src/Data/Array/Accelerate/Trafo/Simplify.hs index 872c8453c..b97b1aa26 100644 --- a/src/Data/Array/Accelerate/Trafo/Simplify.hs +++ b/src/Data/Array/Accelerate/Trafo/Simplify.hs @@ -59,8 +59,6 @@ import Text.Printf import Prelude hiding ( exp, iterate ) import qualified Data.Map.Strict as Map -import GHC.Stack - -- Scalar optimisations -- ==================== diff --git a/src/Data/Array/Accelerate/Trafo/Substitution.hs b/src/Data/Array/Accelerate/Trafo/Substitution.hs index 0a149a075..7f39593ff 100644 --- a/src/Data/Array/Accelerate/Trafo/Substitution.hs +++ b/src/Data/Array/Accelerate/Trafo/Substitution.hs @@ -62,8 +62,6 @@ import Control.Applicative hiding ( Const ) import Control.Monad import Prelude hiding ( exp, seq ) -import GHC.Stack - -- NOTE: [Renaming and Substitution] -- From ca5b57bf04e4588f3867a554ab9168b339f85f46 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 9 Jul 2020 19:34:46 +0200 Subject: [PATCH 290/316] Char is not a valid array data type --- src/Data/Array/Accelerate/Array/Data.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 61d456e33..c6288ccef 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -118,7 +118,6 @@ type family ScalarArrayDataR t where ScalarArrayDataR Half = Half ScalarArrayDataR Float = Float ScalarArrayDataR Double = Double - ScalarArrayDataR Char = Char ScalarArrayDataR (Vec n t) = ScalarArrayDataR t From 67a060b32a3916d88087001bd456c2172516f10b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 15 Jul 2020 10:16:47 +0200 Subject: [PATCH 291/316] update CHANGELOG.md --- CHANGELOG.md | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 45948d0c3..b2946a1ae 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,7 +8,6 @@ Policy (PVP)](https://pvp.haskell.org) ## [next] ### Changed - * Instances of `Elt` are now derivable via `Generic` * The `stencil` functions now support fusion. Note however that the source (delayed) array will be evaluated at _every_ access to the stencil pattern; if the delayed function is expensive, you may wish to explicitly `compute` @@ -20,14 +19,17 @@ Policy (PVP)](https://pvp.haskell.org) * (internal) `EltRepr` is now a class-associated type of `Elt` * (internal) `GArrayData` has been simplified * (internal) SIMD representation has been improved and generalised - * (internal) Massive internal refactoring of the internal AST ([#449], [#455], [#457]) + * (internal) Internal refactoring ([#449], [#455], [#457], [#460]) ### Added - * Pattern synonyms for manipulating custom product types can now be created; - see `Pattern` + * Instances of `Elt` are now derivable via `Generic` for simple (Haskell'98) + product _and_ sum data types. + * Pattern synonyms for manipulating custom product and sum types can now be + created; see `Pattern`, `mkPattern` + * Support for pattern matching in the embedded language; see `match` ### Removed - * Drop support for GHC-7.10, 8.0 + * Drop support for GHC-7.10 .. 8.4. ### Contributors From 641cc787633db93cede13459adf44263ca4447f7 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 15 Jul 2020 10:53:20 +0200 Subject: [PATCH 292/316] alignment --- src/Data/Array/Accelerate/Array/Data.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index c6288ccef..5dcbfe2cb 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -177,9 +177,9 @@ singleArrayDict = single -- ---------------- newArrayData :: HasCallStack => TupR ScalarType e -> Int -> IO (MutableArrayData e) -newArrayData TupRunit !_ = return () -newArrayData (TupRpair t1 t2) !size = (,) <$> newArrayData t1 size <*> newArrayData t2 size -newArrayData (TupRsingle t) !size +newArrayData TupRunit !_ = return () +newArrayData (TupRpair t1 t2) !size = (,) <$> newArrayData t1 size <*> newArrayData t2 size +newArrayData (TupRsingle t) !size | SingleScalarType s <- t , SingleDict <- singleDict s , SingleArrayDict <- singleArrayDict s From 8106124d735da1ebde97b059333fb9344a9cb6bb Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 15 Jul 2020 12:24:21 +0200 Subject: [PATCH 293/316] generalise GArrayData over the container type --- src/Data/Array/Accelerate/Array/Data.hs | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 5dcbfe2cb..97bb6e496 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -25,7 +25,7 @@ module Data.Array.Accelerate.Array.Data ( -- * Array operations and representations - ArrayData, MutableArrayData, GArrayData, ScalarArrayData, ScalarArrayDataR, + ArrayData, MutableArrayData, ScalarArrayData, GArrayDataR, ScalarArrayDataR, runArrayData, newArrayData, indexArrayData, readArrayData, writeArrayData, @@ -85,19 +85,16 @@ type ArrayData e = MutableArrayData e -- | Mutable array representation -- -type MutableArrayData e = GArrayData e +type MutableArrayData e = GArrayDataR UniqueArray e -- | Underlying array representation. -- --- In previous versions this was abstracted over by the mutable/immutable array --- representation, but this is now fixed to our UniqueArray type. --- -- NOTE: We use a standard (non-strict) pair to enable lazy device-host data transfers -- -type family GArrayData a where - GArrayData () = () - GArrayData (a, b) = (GArrayData a, GArrayData b) - GArrayData a = ScalarArrayData a +type family GArrayDataR ba a where + GArrayDataR ba () = () + GArrayDataR ba (a, b) = (GArrayDataR ba a, GArrayDataR ba b) + GArrayDataR ba a = ba (ScalarArrayDataR a) type ScalarArrayData a = UniqueArray (ScalarArrayDataR a) @@ -122,13 +119,13 @@ type family ScalarArrayDataR t where data ScalarArrayDict a where - ScalarArrayDict :: ( GArrayData a ~ ScalarArrayData a, ScalarArrayDataR a ~ ScalarArrayDataR b ) + ScalarArrayDict :: ( GArrayDataR UniqueArray a ~ ScalarArrayData a, ScalarArrayDataR a ~ ScalarArrayDataR b ) => {-# UNPACK #-} !Int -- vector width -> SingleType b -- base type -> ScalarArrayDict a data SingleArrayDict a where - SingleArrayDict :: ( GArrayData a ~ ScalarArrayData a, ScalarArrayDataR a ~ a ) + SingleArrayDict :: ( GArrayDataR UniqueArray a ~ ScalarArrayData a, ScalarArrayDataR a ~ a ) => SingleArrayDict a scalarArrayDict :: ScalarType a -> ScalarArrayDict a From 7ff11c75e1c9249a3846b3e15f9d0a92cd859a43 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jul 2020 16:09:07 +0200 Subject: [PATCH 294/316] make pattern synonyms for vector types useful --- src/Data/Array/Accelerate/Data/Complex.hs | 30 +++++------ src/Data/Array/Accelerate/Pattern.hs | 62 ++++++++++++++--------- src/Data/Array/Accelerate/Pretty/Print.hs | 4 +- 3 files changed, 56 insertions(+), 40 deletions(-) diff --git a/src/Data/Array/Accelerate/Data/Complex.hs b/src/Data/Array/Accelerate/Data/Complex.hs index d46c279c5..c9d07d85b 100644 --- a/src/Data/Array/Accelerate/Data/Complex.hs +++ b/src/Data/Array/Accelerate/Data/Complex.hs @@ -50,6 +50,7 @@ import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Prelude import Data.Array.Accelerate.Representation.Tag import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Representation.Vec import Data.Array.Accelerate.Smart import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Sugar.Vec @@ -57,7 +58,7 @@ import Data.Array.Accelerate.Type import Data.Primitive.Vec import Data.Complex ( Complex(..) ) -import Prelude (($)) +import Prelude ( ($) ) import qualified Data.Complex as C import qualified Prelude as P @@ -117,6 +118,10 @@ type family ComplexR a where ComplexR Word64 = Vec2 Word64 ComplexR a = (((), a), a) +-- This isn't ideal because we gather the evidence based on the +-- representation type, so we really get the evidence (VecElt (EltR a)), +-- which is not very useful... +-- - TLM 2020-07-16 data ComplexType a c where ComplexVec :: VecElt a => SingleType a -> ComplexType a (Vec2 a) ComplexTup :: ComplexType a (((), a), a) @@ -159,22 +164,17 @@ complexR = tuple constructComplex :: forall a. Elt a => Exp a -> Exp a -> Exp (Complex a) -constructComplex r i = case complexR (eltR @a) of - ComplexVec _ -> - let - r', i' :: Exp (EltR a) - r' = coerce @a @(EltR a) r - i' = coerce i - v :: Exp (Vec2 (EltR a)) - v = V2 r' i' - in - coerce @(Vec2 (EltR a)) @(Complex a) $ v - ComplexTup -> coerce $ T2 r i +constructComplex r i = + case complexR (eltR @a) of + ComplexTup -> coerce $ T2 r i + ComplexVec _ -> V2 (coerce @a @(EltR a) r) (coerce @a @(EltR a) i) deconstructComplex :: forall a. Elt a => Exp (Complex a) -> (Exp a, Exp a) -deconstructComplex c = case complexR (eltR @a) of - ComplexVec _ -> let V2 r i = coerce @(Complex a) @(Vec2 (EltR a)) c in (coerce r, coerce i) - ComplexTup -> let T2 r i = coerce c in (r, i) +deconstructComplex c@(Exp c') = + case complexR (eltR @a) of + ComplexTup -> let T2 r i = coerce c in (r, i) + ComplexVec t -> let T2 r i = Exp (SmartExp (VecUnpack (VecRsucc (VecRsucc (VecRnil t))) c')) + in (r, i) coerce :: EltR a ~ EltR b => Exp a -> Exp b coerce (Exp e) = Exp e diff --git a/src/Data/Array/Accelerate/Pattern.hs b/src/Data/Array/Accelerate/Pattern.hs index 76efb340f..d7c63f0f7 100644 --- a/src/Data/Array/Accelerate/Pattern.hs +++ b/src/Data/Array/Accelerate/Pattern.hs @@ -60,9 +60,18 @@ pattern Pattern :: forall b a context. IsPattern context a b => b -> context a pattern Pattern vars <- (destruct @context -> vars) where Pattern = construct @context -class IsPattern con a t where - construct :: t -> con a - destruct :: con a -> t +class IsPattern con a b where + construct :: b -> con a + destruct :: con a -> b + + +pattern Vector :: forall b a context. IsVector context a b => b -> context a +pattern Vector vars <- (vunpack @context -> vars) + where Vector = vpack @context + +class IsVector context a b where + vpack :: b -> context a + vunpack :: context a -> b -- | Pattern synonyms for indices, which may be more convenient to use than -- 'Data.Array.Accelerate.Lift.lift' and @@ -92,10 +101,6 @@ instance (Elt a, Elt b) => IsPattern Exp (a :. b) (Exp a :. Exp b) where construct (Exp a :. Exp b) = Exp $ SmartExp $ Pair a b destruct (Exp t) = Exp (SmartExp $ Prj PairIdxLeft t) :. Exp (SmartExp $ Prj PairIdxRight t) --- Newtype wrapper to distinguish between T and V patterns --- -newtype VecPattern a = VecPattern a - -- IsPattern instances for up to 16-tuples (Acc and Exp). TH takes care of -- the (unremarkable) boilerplate for us. @@ -173,19 +178,28 @@ runQ $ do _ -> $(tupE [[| Exp $(get (varE _x) i) |] | i <- [(n-1), (n-2) .. 0]]) |] + -- Generate instance declarations for IsVector of the form: + -- instance (Elt v, EltR v ~ Vec 2 a, Elt a) => IsVector Exp v (Exp a, Exp a) mkVecPattern :: Int -> Q [Dec] mkVecPattern n = do a <- newName "a" + v <- newName "v" let - v = foldr appE [| VecRnil (singleType @(EltR $(varT a))) |] (replicate n [| VecRsucc |]) - r = tupT (replicate n [t| Exp $(varT a) |]) - t = tupT (replicate n (varT a)) + -- Last argument to `IsVector`, eg (Exp, a, Exp a) in the example + tup = tupT (replicate n ([t| Exp $(varT a)|])) + -- Representation as a vector, eg (Vec 2 a) + vec = [t| Vec $(litT (numTyLit (fromIntegral n))) $(varT a) |] + -- Constraints for the type class, consisting of Elt constraints on all type variables, + -- and an equality constraint on the representation type of `a` and the vector representation `vec`. + context = [t| (Elt $(varT v), VecElt $(varT a), EltR $(varT v) ~ $vec) |] + -- + vecR = foldr appE [| VecRnil (singleType @ $(varT a)) |] (replicate n [| VecRsucc |]) + tR = tupT (replicate n (varT a)) -- - [d| instance VecElt $(varT a) => IsPattern Exp (Vec $(litT (numTyLit (fromIntegral n))) $(varT a)) (VecPattern $r) where - construct (VecPattern x) = - case construct x :: Exp $t of - Exp x' -> Exp (SmartExp (VecPack $v x')) - destruct (Exp x) = VecPattern (destruct (Exp (SmartExp (VecUnpack $v x)) :: Exp $t)) + [d| instance $context => IsVector Exp $(varT v) $tup where + vpack x = case construct x :: Exp $tR of + Exp x' -> Exp (SmartExp (VecPack $vecR x')) + vunpack (Exp x) = destruct (Exp (SmartExp (VecUnpack $vecR x)) :: Exp $tR) |] -- es <- mapM mkExpPattern [0..16] @@ -250,17 +264,19 @@ runQ $ do ] mkV :: Int -> Q [Dec] - mkV n = do - a <- newName "a" + mkV n = let xs = [ mkName ('x' : show i) | i <- [0 .. n-1] ] - ts = replicate n (varT a) + ts = map varT xs name = mkName ('V':show n) - sig = foldr (\t r -> [t| Exp $t -> $r |]) [t| Exp (Vec $(litT (numTyLit (fromIntegral n))) $(varT a)) |] ts - -- + con = varT (mkName "con") + ty1 = varT (mkName "vec") + ty2 = tupT (map (con `appT`) ts) + sig = foldr (\t r -> [t| $con $t -> $r |]) (appT con ty1) ts + in sequence - [ patSynSigD name [t| VecElt $(varT a) => $sig |] - , patSynD name (prefixPatSyn xs) implBidir [p| Pattern (VecPattern $(tupP (map varP xs))) |] - , pragCompleteD [name] Nothing + [ patSynSigD name [t| IsVector $con $ty1 $ty2 => $sig |] + , patSynD name (prefixPatSyn xs) implBidir [p| Vector $(tupP (map varP xs)) |] + , pragCompleteD [name] (Just ''Exp) ] -- ts <- mapM mkT [2..16] diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 4e6ee83ef..9874a88ca 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -377,8 +377,8 @@ prettyOpenExp ctx env aenv exp = Const tp c -> prettyConst (TupRsingle tp) c Pair{} -> prettyTuple ctx env aenv exp Nil -> "()" - VecPack _ e -> ppF1 "vecPack" (ppE e) - VecUnpack _ e -> ppF1 "vecUnpack" (ppE e) + VecPack _ e -> ppF1 "pack" (ppE e) + VecUnpack _ e -> ppF1 "unpack" (ppE e) Case x xs d -> prettyCase env aenv x xs d Cond p t e -> flatAlt multi single where From eeb3765535f039909fda3e859d200a6560ff3433 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jul 2020 18:24:06 +0200 Subject: [PATCH 295/316] wibble --- src/Data/Array/Accelerate/Type.hs | 59 +++++++++++++++---------------- 1 file changed, 29 insertions(+), 30 deletions(-) diff --git a/src/Data/Array/Accelerate/Type.hs b/src/Data/Array/Accelerate/Type.hs index ac330f50d..960a26767 100644 --- a/src/Data/Array/Accelerate/Type.hs +++ b/src/Data/Array/Accelerate/Type.hs @@ -93,14 +93,13 @@ data SingleDict a where => SingleDict a 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 :: ( Eq a, Ord a, Show a + , Bounded 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 ) + , Floating a, Fractional a, Num a, Real a, RealFrac a, RealFloat a, Storable a ) => FloatingDict a @@ -326,21 +325,21 @@ liftNum (IntegralNumType t) = liftIntegral t liftNum (FloatingNumType t) = liftFloating t 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 ||] -liftIntegral TypeWord{} x = [|| x ||] -liftIntegral TypeWord8{} x = [|| x ||] -liftIntegral TypeWord16{} x = [|| x ||] -liftIntegral TypeWord32{} x = [|| x ||] -liftIntegral TypeWord64{} x = [|| x ||] +liftIntegral TypeInt x = [|| x ||] +liftIntegral TypeInt8 x = [|| x ||] +liftIntegral TypeInt16 x = [|| x ||] +liftIntegral TypeInt32 x = [|| x ||] +liftIntegral TypeInt64 x = [|| x ||] +liftIntegral TypeWord x = [|| x ||] +liftIntegral TypeWord8 x = [|| x ||] +liftIntegral TypeWord16 x = [|| x ||] +liftIntegral TypeWord32 x = [|| x ||] +liftIntegral TypeWord64 x = [|| x ||] liftFloating :: FloatingType t -> t -> Q (TExp t) -liftFloating TypeHalf{} x = [|| x ||] -liftFloating TypeFloat{} x = [|| x ||] -liftFloating TypeDouble{} x = [|| x ||] +liftFloating TypeHalf x = [|| x ||] +liftFloating TypeFloat x = [|| x ||] +liftFloating TypeDouble x = [|| x ||] liftScalarType :: ScalarType t -> Q (TExp (ScalarType t)) @@ -361,21 +360,21 @@ liftBoundedType :: BoundedType t -> Q (TExp (BoundedType t)) liftBoundedType (IntegralBoundedType t) = [|| IntegralBoundedType $$(liftIntegralType t) ||] liftIntegralType :: IntegralType t -> Q (TExp (IntegralType t)) -liftIntegralType TypeInt{} = [|| TypeInt ||] -liftIntegralType TypeInt8{} = [|| TypeInt8 ||] -liftIntegralType TypeInt16{} = [|| TypeInt16 ||] -liftIntegralType TypeInt32{} = [|| TypeInt32 ||] -liftIntegralType TypeInt64{} = [|| TypeInt64 ||] -liftIntegralType TypeWord{} = [|| TypeWord ||] -liftIntegralType TypeWord8{} = [|| TypeWord8 ||] -liftIntegralType TypeWord16{} = [|| TypeWord16 ||] -liftIntegralType TypeWord32{} = [|| TypeWord32 ||] -liftIntegralType TypeWord64{} = [|| TypeWord64 ||] +liftIntegralType TypeInt = [|| TypeInt ||] +liftIntegralType TypeInt8 = [|| TypeInt8 ||] +liftIntegralType TypeInt16 = [|| TypeInt16 ||] +liftIntegralType TypeInt32 = [|| TypeInt32 ||] +liftIntegralType TypeInt64 = [|| TypeInt64 ||] +liftIntegralType TypeWord = [|| TypeWord ||] +liftIntegralType TypeWord8 = [|| TypeWord8 ||] +liftIntegralType TypeWord16 = [|| TypeWord16 ||] +liftIntegralType TypeWord32 = [|| TypeWord32 ||] +liftIntegralType TypeWord64 = [|| TypeWord64 ||] liftFloatingType :: FloatingType t -> Q (TExp (FloatingType t)) -liftFloatingType TypeHalf{} = [|| TypeHalf ||] -liftFloatingType TypeFloat{} = [|| TypeFloat ||] -liftFloatingType TypeDouble{} = [|| TypeDouble ||] +liftFloatingType TypeHalf = [|| TypeHalf ||] +liftFloatingType TypeFloat = [|| TypeFloat ||] +liftFloatingType TypeDouble = [|| TypeDouble ||] -- Type-level bit sizes From 593f5c5db6f46d3307e232e81e04a92a69445cf2 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 16 Jul 2020 19:21:58 +0200 Subject: [PATCH 296/316] wibble --- src/Data/Array/Accelerate/Array/Data.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 97bb6e496..986b637de 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -119,13 +119,13 @@ type family ScalarArrayDataR t where data ScalarArrayDict a where - ScalarArrayDict :: ( GArrayDataR UniqueArray a ~ ScalarArrayData a, ScalarArrayDataR a ~ ScalarArrayDataR b ) + ScalarArrayDict :: ( ArrayData a ~ ScalarArrayData a, ScalarArrayDataR a ~ ScalarArrayDataR b ) => {-# UNPACK #-} !Int -- vector width -> SingleType b -- base type -> ScalarArrayDict a data SingleArrayDict a where - SingleArrayDict :: ( GArrayDataR UniqueArray a ~ ScalarArrayData a, ScalarArrayDataR a ~ a ) + SingleArrayDict :: ( ArrayData a ~ ScalarArrayData a, ScalarArrayDataR a ~ a ) => SingleArrayDict a scalarArrayDict :: ScalarType a -> ScalarArrayDict a From cb2588be2c9036fa4c7b85fe99ca97cdcae78e2f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 10 Aug 2020 16:22:16 +0200 Subject: [PATCH 297/316] update pretty printer --- src/Data/Array/Accelerate/Pretty/Print.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Pretty/Print.hs b/src/Data/Array/Accelerate/Pretty/Print.hs index 9874a88ca..52eee4262 100644 --- a/src/Data/Array/Accelerate/Pretty/Print.hs +++ b/src/Data/Array/Accelerate/Pretty/Print.hs @@ -438,7 +438,7 @@ prettyOpenExp ctx env aenv exp = $ sep [ opName op, x app, y app, z app ] withTypeRep :: ScalarType t -> Adoc -> Adoc - withTypeRep t op = op <> enclose langle rangle (pretty (show t)) + withTypeRep t op = op <+> "@" <> pretty (show t) prettyArrayVar :: forall aenv a. From 65a6c32b0b06ff88c43c8604d0920ccd1fb8b05d Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 10 Aug 2020 17:54:09 +0200 Subject: [PATCH 298/316] fix pattern generation in the presence of -XRebindableSyntax --- src/Data/Array/Accelerate/Pattern/TH.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Pattern/TH.hs b/src/Data/Array/Accelerate/Pattern/TH.hs index 333142dce..7619316ab 100644 --- a/src/Data/Array/Accelerate/Pattern/TH.hs +++ b/src/Data/Array/Accelerate/Pattern/TH.hs @@ -316,9 +316,11 @@ mkConS tn' tvs' prev' next' tag' con' = do e <- newName "_e" x <- newName "_x" (ps,es) <- extract vs [| Prj PairIdxRight $(varE x) |] [] [] + unbind <- isExtEnabled RebindableSyntax let + eqE = if unbind then letE [funD (mkName "==") [clause [] (normalB (varE '(==))) []]] else id lhs = [p| (Exp $(varP e)) |] - body = normalB $ caseE (varE e) + body = normalB $ eqE $ caseE (varE e) [ TH.match (conP 'SmartExp [(conP 'Match [matchP ps, varP x])]) (normalB [| Just $(tupE es) |]) [] , TH.match (conP 'SmartExp [(recP 'Match [])]) (normalB [| Nothing |]) [] , TH.match wildP (normalB [| error $error_msg |]) [] From 81e1dac50f4222bc63d5e9139b7d1a1ff1324e8f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 11 Aug 2020 16:38:52 +0200 Subject: [PATCH 299/316] add DIM3 representation type synonym --- src/Data/Array/Accelerate/Representation/Shape.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Array/Accelerate/Representation/Shape.hs b/src/Data/Array/Accelerate/Representation/Shape.hs index c7e15a418..b2c1b94dd 100644 --- a/src/Data/Array/Accelerate/Representation/Shape.hs +++ b/src/Data/Array/Accelerate/Representation/Shape.hs @@ -41,6 +41,7 @@ showShape shr = foldr (\sh str -> str ++ " :. " ++ show sh) "Z" . shapeToList sh type DIM0 = () type DIM1 = ((), Int) type DIM2 = (((), Int), Int) +type DIM3 = ((((), Int), Int), Int) dim0 :: ShapeR DIM0 dim0 = ShapeRz @@ -51,6 +52,9 @@ dim1 = ShapeRsnoc dim0 dim2 :: ShapeR DIM2 dim2 = ShapeRsnoc dim1 +dim3 :: ShapeR DIM3 +dim3 = ShapeRsnoc dim2 + -- | Number of dimensions of a /shape/ or /index/ (>= 0) -- rank :: ShapeR sh -> Int From 9883779db77d88480dc5adbc9d9b19d839f201cc Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Tue, 11 Aug 2020 18:06:45 +0200 Subject: [PATCH 300/316] =?UTF-8?q?add=20missing=20case=20match=20in=20Fus?= =?UTF-8?q?ion.aletD=E2=80=99?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Array/Accelerate/Trafo/Fusion.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Array/Accelerate/Trafo/Fusion.hs b/src/Data/Array/Accelerate/Trafo/Fusion.hs index 2ada0a3d3..05fc0efde 100644 --- a/src/Data/Array/Accelerate/Trafo/Fusion.hs +++ b/src/Data/Array/Accelerate/Trafo/Fusion.hs @@ -1442,6 +1442,8 @@ aletD' embedAcc elimAcc (LeftHandSideSingle ArrayR{}) (Embed env1 cc1) (Embed en Undef tR -> Undef tR Nil -> Nil Pair e1 e2 -> Pair (cvtE e1) (cvtE e2) + VecPack vR e -> VecPack vR (cvtE e) + VecUnpack vR e -> VecUnpack vR (cvtE e) IndexSlice x ix sh -> IndexSlice x (cvtE ix) (cvtE sh) IndexFull x ix sl -> IndexFull x (cvtE ix) (cvtE sl) ToIndex shR' sh ix -> ToIndex shR' (cvtE sh) (cvtE ix) From d44b51a69c6ea0a487811a475729839c881137f0 Mon Sep 17 00:00:00 2001 From: Robbert van der Helm Date: Wed, 12 Aug 2020 16:55:29 +0200 Subject: [PATCH 301/316] Fix expanding to an empty vector If all elements of the original vector were to expand to 0 elements, then the `scanl1` would fail on a bounds check because it gets passed an empty vector. --- src/Data/Array/Accelerate/Prelude.hs | 46 ++++++++++++++-------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index a88cdb42c..5716a0ae4 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -2514,31 +2514,32 @@ expand :: (Elt a, Elt b) -> Acc (Vector a) -> Acc (Vector b) expand f g xs = - if length xs == 0 + let + szs = map f xs + T2 offset len = scanl' (+) 0 szs + m = the len + in + if length xs == 0 || m == 0 then use $ fromList (Z:.0) [] else let - szs = map f xs - T2 offset len = scanl' (+) 0 szs - - m = the len - n = m + 1 - put ix = Just_ (I1 (offset ! ix)) - - head_flags :: Acc (Vector Int) - head_flags = permute const (fill (I1 n) 0) put (fill (shape szs) 1) - - idxs = map (subtract 1) - $ map snd - $ scanl1 (segmentedL (+)) - $ zip head_flags - $ fill (I1 m) 1 - - iotas = map snd - $ scanl1 (segmentedL const) - $ zip head_flags - $ permute const (fill (I1 n) undef) put - $ enumFromN (shape xs) 0 + n = m + 1 + put ix = Just_ (I1 (offset ! ix)) + + head_flags :: Acc (Vector Int) + head_flags = permute const (fill (I1 n) 0) put (fill (shape szs) 1) + + idxs = map (subtract 1) + $ map snd + $ scanl1 (segmentedL (+)) + $ zip head_flags + $ fill (I1 m) 1 + + iotas = map snd + $ scanl1 (segmentedL const) + $ zip head_flags + $ permute const (fill (I1 n) undef) put + $ enumFromN (shape xs) 0 in zipWith g (gather iotas xs) idxs @@ -2611,4 +2612,3 @@ _2 = lens (\ix -> let _ :. y :. _ = unlift ix :: Exp sh :. Exp Int :. Exp Int _3 :: forall sh. Elt 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)) - From ea73be67853bb01978308e3c1aec14484feff50c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 12 Aug 2020 18:09:44 +0200 Subject: [PATCH 302/316] wibble --- src/Data/Array/Accelerate/Language.hs | 2 +- src/Data/Array/Accelerate/Prelude.hs | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Language.hs b/src/Data/Array/Accelerate/Language.hs index 242f1abed..c05476410 100644 --- a/src/Data/Array/Accelerate/Language.hs +++ b/src/Data/Array/Accelerate/Language.hs @@ -1214,7 +1214,7 @@ foreignExp -> (Exp x -> Exp y) -> Exp x -> Exp y -foreignExp a f (Exp x) = mkExp $ Foreign (eltR @y) a (unExpFunction f) x +foreignExp asm f (Exp x) = mkExp $ Foreign (eltR @y) asm (unExpFunction f) x -- Composition of array computations diff --git a/src/Data/Array/Accelerate/Prelude.hs b/src/Data/Array/Accelerate/Prelude.hs index 5716a0ae4..11545f34c 100644 --- a/src/Data/Array/Accelerate/Prelude.hs +++ b/src/Data/Array/Accelerate/Prelude.hs @@ -2612,3 +2612,4 @@ _2 = lens (\ix -> let _ :. y :. _ = unlift ix :: Exp sh :. Exp Int :. Exp Int _3 :: forall sh. Elt 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)) + From cc4ae666548cb0340e6eb30de41ca6b869e8809b Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 13 Aug 2020 12:22:42 +0200 Subject: [PATCH 303/316] stack: update resolver --- stack-8.10.yaml | 2 +- stack-8.8.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/stack-8.10.yaml b/stack-8.10.yaml index ec88bef2c..836feed5c 100644 --- a/stack-8.10.yaml +++ b/stack-8.10.yaml @@ -2,7 +2,7 @@ # For advanced use and comprehensive documentation of the format, please see: # https://docs.haskellstack.org/en/stable/yaml_configuration/ -resolver: nightly-2020-06-24 +resolver: nightly-2020-08-13 packages: - . diff --git a/stack-8.8.yaml b/stack-8.8.yaml index 270bbce1c..0cebcfaba 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-16.1 +resolver: lts-16.9 packages: - . From c63e746c8bb44d77a69e7ab7890a382bd22d3d5c Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 13 Aug 2020 16:03:12 +0200 Subject: [PATCH 304/316] simpler implementation of bitwise rotate --- src/Data/Array/Accelerate/Data/Bits.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Data/Bits.hs b/src/Data/Array/Accelerate/Data/Bits.hs index 19a2890ce..9696e3c3e 100644 --- a/src/Data/Array/Accelerate/Data/Bits.hs +++ b/src/Data/Array/Accelerate/Data/Bits.hs @@ -32,7 +32,6 @@ 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 ) @@ -714,6 +713,20 @@ shiftRLDefault x i = cond (i >= finiteBitSize x) (constInt 0) $ mkBShiftR x i +rotateDefault :: forall t. (FiniteBits t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t +rotateDefault x i + = cond (i < 0) (mkBRotateR x (-i)) + $ cond (i > 0) (mkBRotateL x i) + $ x + +{-- +-- Rotation can be implemented in terms of two shifts, but care is needed +-- for negative values. This suggested implementation assumes +-- 2's-complement arithmetic. +-- +-- This is disabled because (at least) LLVM-9 generates incorrect code on +-- the Turing architecture for negative shift amounts of 64-bit values. +-- rotateDefault :: forall t. (FiniteBits t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t rotateDefault = case integralType :: IntegralType (EltR t) of @@ -744,6 +757,7 @@ rotateDefault' _ x i x' = i2w x i' = i `mkBAnd` (wsib - 1) wsib = finiteBitSize x +--} rotateLDefault :: (Elt t, IsIntegral (EltR t)) => Exp t -> Exp Int -> Exp t rotateLDefault x i From b54ce53cff506ba9e9edab21f7a37c3dfbd96173 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 20 Aug 2020 12:57:13 +0200 Subject: [PATCH 305/316] reexport Maybe patterns --- src/Data/Array/Accelerate.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 31017450a..321b5786a 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -412,6 +412,7 @@ module Data.Array.Accelerate ( Word, Word8, Word16, Word32, Word64, Half(..), Float, Double, Bool(..), pattern True_, pattern False_, + Maybe(..), pattern Nothing_, pattern Just_, Char, CFloat, CDouble, @@ -421,6 +422,7 @@ module Data.Array.Accelerate ( ) where import Data.Array.Accelerate.Classes +import Data.Array.Accelerate.Data.Maybe import Data.Array.Accelerate.Language import Data.Array.Accelerate.Pattern import Data.Array.Accelerate.Pattern.TH From 9e91fba6b6330f1edfa36252a1f2fb68669b03a8 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Sat, 22 Aug 2020 16:03:26 +0200 Subject: [PATCH 306/316] use pinned byte arrays This could lead to memory fragmentation, but means we can pass the values directly over the FFI --- src/Data/Array/Accelerate/Array/Data.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/Accelerate/Array/Data.hs b/src/Data/Array/Accelerate/Array/Data.hs index 986b637de..ce9d2ae72 100644 --- a/src/Data/Array/Accelerate/Array/Data.hs +++ b/src/Data/Array/Accelerate/Array/Data.hs @@ -211,7 +211,7 @@ readArrayData (TupRsingle t) arr !ix !addr# = unPtr# (unsafeUniqueArrayPtr arr) `plusAddr#` (ix# *# bytes#) in IO $ \s0 -> - case newByteArray# bytes# s0 of { (# s1, mba# #) -> + case newAlignedPinnedByteArray# bytes# 16# s0 of { (# s1, mba# #) -> case copyAddrToByteArray# addr# mba# 0# bytes# s1 of { s2 -> case unsafeFreezeByteArray# mba# s2 of { (# s3, ba# #) -> (# s3, Vec ba# #) From d7caff6f9153b93ca467360f8f3cdc5975685c2f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 24 Aug 2020 11:31:54 +0200 Subject: [PATCH 307/316] stack: update resolver to ghc-8.10.2 --- stack-8.10.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-8.10.yaml b/stack-8.10.yaml index 836feed5c..92e35f367 100644 --- a/stack-8.10.yaml +++ b/stack-8.10.yaml @@ -2,7 +2,7 @@ # For advanced use and comprehensive documentation of the format, please see: # https://docs.haskellstack.org/en/stable/yaml_configuration/ -resolver: nightly-2020-08-13 +resolver: nightly-2020-08-23 packages: - . From 92ae4cda866ea8a47f9fcffac9eb62faba304cbd Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 24 Aug 2020 18:25:36 +0200 Subject: [PATCH 308/316] warning police --- src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs | 1 - src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs | 1 - src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs | 1 - src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs | 1 - 4 files changed, 4 deletions(-) diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs index 7e2e69a69..444687f44 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue137.hs @@ -20,7 +20,6 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue137 ( ) where import Data.Array.Accelerate as A -import Data.Array.Accelerate.Data.Maybe as A import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs index 56f75b144..f14f83520 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue185.hs @@ -23,7 +23,6 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue185 ( ) where import Data.Array.Accelerate as A -import Data.Array.Accelerate.Data.Maybe as A import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty diff --git a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs index 0b1ad4571..556b27ffb 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Issues/Issue93.hs @@ -18,7 +18,6 @@ module Data.Array.Accelerate.Test.NoFib.Issues.Issue93 ( ) where import Data.Array.Accelerate as A -import Data.Array.Accelerate.Data.Maybe as A import Data.Array.Accelerate.Test.NoFib.Base import Test.Tasty diff --git a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs index 7aff75ac3..48b89d1de 100644 --- a/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs +++ b/src/Data/Array/Accelerate/Test/NoFib/Spectral/RadixSort.hs @@ -29,7 +29,6 @@ import qualified Data.Bits as P import Data.Array.Accelerate as A import Data.Array.Accelerate.Data.Bits as A -import Data.Array.Accelerate.Data.Maybe as A import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Test.NoFib.Base import Data.Array.Accelerate.Test.NoFib.Config From 27f63569db181d641ecaf251cf04b1884d7f106f Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Mon, 24 Aug 2020 21:05:44 +0200 Subject: [PATCH 309/316] update CHANGELOG.md --- CHANGELOG.md | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b2946a1ae..888081593 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,7 +16,7 @@ Policy (PVP)](https://pvp.haskell.org) * Improve fusion for `zipWith*` ([#453]) * (internal) Visible type applications are used instead of `Proxy` types - * (internal) `EltRepr` is now a class-associated type of `Elt` + * (internal) `EltR` is now a class-associated type of `Elt` * (internal) `GArrayData` has been simplified * (internal) SIMD representation has been improved and generalised * (internal) Internal refactoring ([#449], [#455], [#457], [#460]) @@ -41,6 +41,17 @@ Special thanks to those who contributed patches as part of this release: * David van Balen (@dpvanbalen) * Jaro Reinders (@noughtmare) * Alex Lang (@alang9) + * Paul Wilson (@status_failed) + * @lennonhill + * Travis Whitaker (@TravisWhitaker) + * Roger Bosman (@rogerbosman) + * Robbert van der Helm (@robbert-vdh) + * Sam (@sam-340453) + * Lars van den Haak (@sakehl) + * Rinat Striungis (@Haskell-mouse) + * Viktor Kronvall (@considerate) + * Tom Smeding (@tomsmeding) + * Ryan Scott (@RyanGlScott) ## [1.2.0.1] - 2018-10-06 From f4ffbf3ff6af8d75097574b37f3ba7c082d19cb6 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 26 Aug 2020 18:01:09 +0200 Subject: [PATCH 310/316] version [de-]bump 1.3.0.0 --- accelerate.cabal | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/accelerate.cabal b/accelerate.cabal index ab11b296b..aa508c053 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -1,5 +1,5 @@ Name: accelerate -Version: 1.4.0.0 +Version: 1.3.0.0 Cabal-version: >= 1.18 Tested-with: GHC >= 8.6 Build-type: Custom @@ -41,16 +41,24 @@ Description: greater. See the following table for supported GPUs: . - * @accelerate-examples@: Computational kernels and applications showcasing - the use of Accelerate. + * @accelerate-examples@: Computational kernels and applications + demonstrating the use of Accelerate. . - * @accelerate-io@: Fast conversions between Accelerate arrays and other - array formats (including vector and repa). + * @accelerate-io*@: Fast conversions between Accelerate arrays and other + array and data formats. . * @accelerate-fft@: Discrete Fourier transforms, with FFI bindings to optimised implementations. + . + * @accelerate-blas@: Numeric linear algebra, with FFI bindings to optimised + implementations. . * @accelerate-bignum@: Fixed-width large integer arithmetic. + . + * @containers-accelerate@: Container types for use with Accelerate. + . + * @hashable-accelerate@: Class for types which can be converted to a hash + value. . * @colour-accelerate@: Colour representations in Accelerate (RGB, sRGB, HSV, and HSL). @@ -76,7 +84,7 @@ Description: . * An implementation of the Canny edge detection algorithm . - * An interactive Mandelbrot set generator + * Interactive Mandelbrot and Julia set generators . * A particle-based simulation of stable fluid flows . @@ -592,7 +600,7 @@ source-repository head source-repository this Type: git - Tag: v1.4.0.0 + Tag: v1.3.0.0 Location: git://github.com/AccelerateHS/accelerate.git -- vim: nospell From 7c31b3ba6275ce2e9a21d9d017cc5af0076497fb Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 26 Aug 2020 18:23:14 +0200 Subject: [PATCH 311/316] update CHANGELOG.md --- CHANGELOG.md | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 888081593..e14f6af75 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,7 +6,16 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/) and the project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) -## [next] +## [1.3.0.0] - 2020-08-26 +### Added + * Instances of `Elt` are now derivable via `Generic` for simple (Haskell'98) + product _and_ sum data types. + * Pattern synonyms for manipulating custom product and sum types can now be + created; see `Pattern`, `mkPattern` + * Added pattern synonyms for accessing tuples and indices, as an alternative + to `lift` and `unlift`. + * Support for pattern matching in the embedded language; see `match` + ### Changed * The `stencil` functions now support fusion. Note however that the source (delayed) array will be evaluated at _every_ access to the stencil pattern; @@ -14,6 +23,7 @@ Policy (PVP)](https://pvp.haskell.org) the source array first, matching the old behaviour. * Removed `Slice` constraint from some indexing operations * Improve fusion for `zipWith*` ([#453]) + * The indexing function to `permute` now returns a `Maybe` type ([#87]) * (internal) Visible type applications are used instead of `Proxy` types * (internal) `EltR` is now a class-associated type of `Elt` @@ -21,12 +31,7 @@ Policy (PVP)](https://pvp.haskell.org) * (internal) SIMD representation has been improved and generalised * (internal) Internal refactoring ([#449], [#455], [#457], [#460]) -### Added - * Instances of `Elt` are now derivable via `Generic` for simple (Haskell'98) - product _and_ sum data types. - * Pattern synonyms for manipulating custom product and sum types can now be - created; see `Pattern`, `mkPattern` - * Support for pattern matching in the embedded language; see `match` + * Probably many others I have forgotten about ### Removed * Drop support for GHC-7.10 .. 8.4. @@ -181,7 +186,7 @@ Special thanks to those who contributed patches as part of this release: * Initial release of the CUDA backend -[next]: https://github.com/AccelerateHS/accelerate/compare/v1.2.0.1...HEAD +[1.3.0.0]: https://github.com/AccelerateHS/accelerate/compare/v1.2.0.1...v1.3.0.0 [1.2.0.1]: https://github.com/AccelerateHS/accelerate/compare/v1.2.0.0...v1.2.0.1 [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 @@ -197,10 +202,12 @@ Special thanks to those who contributed patches as part of this release: [0.9.0.0]: https://github.com/AccelerateHS/accelerate/compare/0_8_1_0...0.9.0.0 [0.7.1.0]: https://github.com/AccelerateHS/accelerate/compare/0_6_0_0...0_7_1_0 +[#87]: https://github.com/AccelerateHS/accelerate/issues/87 [#340]: https://github.com/AccelerateHS/accelerate/issues/340 [#390]: https://github.com/AccelerateHS/accelerate/issues/390 [#453]: https://github.com/AccelerateHS/accelerate/pull/453 [#449]: https://github.com/AccelerateHS/accelerate/pull/449 [#455]: https://github.com/AccelerateHS/accelerate/pull/455 [#457]: https://github.com/AccelerateHS/accelerate/pull/457 +[#460]: https://github.com/AccelerateHS/accelerate/pull/460 From b46cd04e28d2068241ed210e510035eb8b01d396 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 26 Aug 2020 18:23:25 +0200 Subject: [PATCH 312/316] update stack-*.yaml --- stack-8.10.yaml | 2 +- stack-8.8.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/stack-8.10.yaml b/stack-8.10.yaml index 92e35f367..3dbea2336 100644 --- a/stack-8.10.yaml +++ b/stack-8.10.yaml @@ -2,7 +2,7 @@ # For advanced use and comprehensive documentation of the format, please see: # https://docs.haskellstack.org/en/stable/yaml_configuration/ -resolver: nightly-2020-08-23 +resolver: nightly-2020-08-26 packages: - . diff --git a/stack-8.8.yaml b/stack-8.8.yaml index 0cebcfaba..f6b9d41f3 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # vim: nospell -resolver: lts-16.9 +resolver: lts-16.11 packages: - . From c4952f695d8cca33c96ffa88f264ba7b0578ef94 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Wed, 26 Aug 2020 18:23:32 +0200 Subject: [PATCH 313/316] update haddocks --- src/Data/Array/Accelerate.hs | 6 ++++++ src/Data/Array/Accelerate/Classes/Eq.hs | 4 ++++ 2 files changed, 10 insertions(+) diff --git a/src/Data/Array/Accelerate.hs b/src/Data/Array/Accelerate.hs index 321b5786a..397564c80 100644 --- a/src/Data/Array/Accelerate.hs +++ b/src/Data/Array/Accelerate.hs @@ -110,6 +110,12 @@ -- * : -- Fixed-width large integer arithmetic. -- +-- * : +-- Container types for use with Accelerate. +-- +-- * : +-- Class for types which can be converted to a value. +-- -- * : -- Colour representations in Accelerate (RGB, sRGB, HSV, and HSL). -- diff --git a/src/Data/Array/Accelerate/Classes/Eq.hs b/src/Data/Array/Accelerate/Classes/Eq.hs index c3f5c76df..de1e9ccd8 100644 --- a/src/Data/Array/Accelerate/Classes/Eq.hs +++ b/src/Data/Array/Accelerate/Classes/Eq.hs @@ -64,6 +64,8 @@ infixr 3 && -- | Conjunction: True if both arguments are true. This is a strict version of -- '(&&)': it will always evaluate both arguments, even when the first is false. -- +-- @since 1.3.0.0 +-- infixr 3 &&! (&&!) :: Exp Bool -> Exp Bool -> Exp Bool (&&!) = mkLAnd @@ -84,6 +86,8 @@ infixr 2 || -- | Disjunction: True if either argument is true. This is a strict version of -- '(||)': it will always evaluate both arguments, even when the first is true. -- +-- @since 1.3.0.0 +-- infixr 2 ||! (||!) :: Exp Bool -> Exp Bool -> Exp Bool (||!) = mkLOr From 2d442cd8c250aa8fde2505a391c0206f9508e65d Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 27 Aug 2020 17:56:38 +0200 Subject: [PATCH 314/316] build fix for -fekg --- src/Data/Array/Accelerate/Debug/Monitoring.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Array/Accelerate/Debug/Monitoring.hs b/src/Data/Array/Accelerate/Debug/Monitoring.hs index d85631252..e7d0d710c 100644 --- a/src/Data/Array/Accelerate/Debug/Monitoring.hs +++ b/src/Data/Array/Accelerate/Debug/Monitoring.hs @@ -36,6 +36,8 @@ module Data.Array.Accelerate.Debug.Monitoring ( ) where #ifdef ACCELERATE_MONITORING +import Data.Array.Accelerate.Debug.Clock + import System.Metrics import System.Remote.Monitoring From 7c0363fad44e9505f1668140ec828f4f8dacc893 Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Thu, 27 Aug 2020 19:45:20 +0200 Subject: [PATCH 315/316] update category --- accelerate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/accelerate.cabal b/accelerate.cabal index aa508c053..870562135 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -125,7 +125,7 @@ Maintainer: Trevor L. McDonell Homepage: https://github.com/AccelerateHS/accelerate/ Bug-reports: https://github.com/AccelerateHS/accelerate/issues -Category: Compilers/Interpreters, Concurrency, Data, Parallelism +Category: Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism Stability: Experimental Extra-source-files: From 114726f06956a592b39ba5ce67eda5770fbdf4eb Mon Sep 17 00:00:00 2001 From: "Trevor L. McDonell" Date: Fri, 28 Aug 2020 13:09:56 +0200 Subject: [PATCH 316/316] update .cabal --- accelerate.cabal | 78 ++++++++++++++++++++++++------------------------ 1 file changed, 39 insertions(+), 39 deletions(-) diff --git a/accelerate.cabal b/accelerate.cabal index 870562135..8ff0560d2 100644 --- a/accelerate.cabal +++ b/accelerate.cabal @@ -1,12 +1,12 @@ -Name: accelerate -Version: 1.3.0.0 -Cabal-version: >= 1.18 -Tested-with: GHC >= 8.6 -Build-type: Custom +name: accelerate +version: 1.3.0.0 +cabal-version: 1.18 +tested-with: GHC >= 8.6 +build-type: Custom -Synopsis: An embedded language for accelerated array processing +synopsis: An embedded language for accelerated array processing -Description: +description: @Data.Array.Accelerate@ defines an embedded array language for computations for high-performance computing in Haskell. Computations on multi-dimensional, regular arrays are expressed in the form of parameterised collective @@ -118,23 +118,23 @@ Description: . -License: BSD3 -License-file: LICENSE -Author: The Accelerate Team -Maintainer: Trevor L. McDonell -Homepage: https://github.com/AccelerateHS/accelerate/ -Bug-reports: https://github.com/AccelerateHS/accelerate/issues +license: BSD3 +license-file: LICENSE +author: The Accelerate Team +maintainer: Trevor L. McDonell +homepage: https://github.com/AccelerateHS/accelerate/ +bug-reports: https://github.com/AccelerateHS/accelerate/issues -Category: Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism -Stability: Experimental +category: Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism +stability: Experimental -Extra-source-files: +extra-source-files: README.md CHANGELOG.md cbits/*.c cbits/*.h -Extra-doc-files: +extra-doc-files: images/*.png custom-setup @@ -143,9 +143,9 @@ custom-setup , Cabal , cabal-doctest >= 1.0 -Flag debug - Default: False - Description: +flag debug + default: False + description: Enable debug tracing messages. The following options are read from the environment variable @ACCELERATE_FLAGS@, and via the command-line as: . @@ -220,9 +220,9 @@ Flag debug * @dump-sched@: Print information related to execution scheduling. . -Flag ekg - Default: False - Description: +flag ekg + default: False + description: Enable hooks for monitoring the running application using EKG. Implies @debug@ mode. In order to view the metrics, your application will need to call @Data.Array.Accelerate.Debug.beginMonitoring@ before running any @@ -256,26 +256,26 @@ Flag ekg > -with-rtsopts=-T . -Flag bounds-checks - Description: Enable bounds checking - Default: True +flag bounds-checks + description: Enable bounds checking + default: True -Flag unsafe-checks - Description: Enable bounds checking in unsafe operations - Default: False +flag unsafe-checks + description: Enable bounds checking in unsafe operations + default: False -Flag internal-checks - Description: Enable internal consistency checks - Default: False +flag internal-checks + description: Enable internal consistency checks + default: False -- Enabling this drastically increases build times -- See: https://gitlab.haskell.org/ghc/ghc/issues/15751 -Flag nofib - Default: False - Description: Build the nofib test suite (required for backend testing) +flag nofib + default: False + description: Build the nofib test suite (required for backend testing) -Library - Build-depends: +library + build-depends: base >= 4.12 && < 4.15 , ansi-terminal >= 0.6.2 , base-orphans >= 0.3 @@ -305,7 +305,7 @@ Library , unordered-containers >= 0.2 , vector >= 0.10 - Exposed-modules: + exposed-modules: -- The core language and reference implementation Data.Array.Accelerate Data.Array.Accelerate.Interpreter @@ -370,7 +370,7 @@ Library Data.BitSet Data.Primitive.Vec - Other-modules: + other-modules: Data.Array.Accelerate.Analysis.Hash.TH Data.Array.Accelerate.Array.Remote.Nursery Data.Array.Accelerate.Classes