accelerate-blas 0.2.0.1 → 0.3.0.0

raw patch · 32 files changed

+564/−468 lines, 32 filesdep ~acceleratedep ~accelerate-llvmdep ~accelerate-llvm-nativePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: accelerate, accelerate-llvm, accelerate-llvm-native, accelerate-llvm-ptx, base, llvm-hs-pure

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−1
• README.md +20/−11
• accelerate-blas.cabal +19/−19
• bench/Bench/Accelerate.hs +6/−3
• bench/Bench/HMatrix.hs +3/−2
• bench/Bench/Util.hs +2/−2
• bench/BenchHMatrix.hs +2/−2
• bench/BenchNative.hs +2/−2
• bench/BenchPTX.hs +2/−2
• src/Data/Array/Accelerate/Numeric/LinearAlgebra.hs +12/−6
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/BLAS/Level1.hs +8/−7
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/BLAS/Level2.hs +10/−8
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/BLAS/Level3.hs +10/−8
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/LLVM/Native/Base.hs +27/−19
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/LLVM/Native/Level2.hs +49/−29
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/LLVM/Native/Level3.hs +59/−35
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/LLVM/PTX/Base.hs +64/−25
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/LLVM/PTX/Context.hs +2/−2
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/LLVM/PTX/Level2.hs +59/−44
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/LLVM/PTX/Level3.hs +59/−42
• src/Data/Array/Accelerate/Numeric/LinearAlgebra/Type.hs +11/−20
• src/Data/Array/Accelerate/Numeric/Sum.hs +38/−108
• src/Data/Array/Accelerate/Numeric/Sum/Arithmetic.hs +3/−2
• src/Data/Array/Accelerate/Numeric/Sum/LLVM/Native.hs +13/−10
• src/Data/Array/Accelerate/Numeric/Sum/LLVM/PTX.hs +13/−10
• src/Data/Array/Accelerate/Numeric/Sum/LLVM/Prim.hs +46/−32
• test/Test/BLAS.hs +2/−2
• test/Test/BLAS/Level2.hs +3/−3
• test/Test/BLAS/Level3.hs +3/−3
• test/Test/Util.hs +6/−5
• test/TestNative.hs +2/−2
• test/TestPTX.hs +2/−2

@@ -7,9 +7,14 @@ Policy (PVP)](https://pvp.haskell.org)  +## [0.3.0.0] - 2020-08-26+### Changed+  * update for accelerate-1.3+  * support LLVM-9+ ## [0.2.0.0] - 2018-04-03 ### Changed-  * Update for AoS representation of complex numbers+  * update for AoS representation of complex numbers  ### Added   * support for LLVM-6.0@@ -22,6 +27,7 @@   * First version. Released on an unsuspecting world.  +[0.3.0.0]:          https://github.com/tmcdonell/accelerate-blas/compare/0.2.0.0...v0.3.0.0 [0.2.0.0]:          https://github.com/tmcdonell/accelerate-blas/compare/0.1.0.1...0.2.0.0 [0.1.0.1]:          https://github.com/tmcdonell/accelerate-blas/compare/0.1.0.0...0.1.0.1 [0.1.0.0]:          https://github.com/tmcdonell/accelerate-blas/compare/4c89f4e6c62b8de3f37855ab2e4d27046b2495b2...0.1.0.0

@@ -1,25 +1,34 @@+<div align="center">+<img width="450" src="https://github.com/AccelerateHS/accelerate/raw/master/images/accelerate-logo-text-v.png?raw=true" alt="henlo, my name is Theia"/>+ # Numeric linear algebra in Accelerate -[![Build Status](https://travis-ci.org/tmcdonell/accelerate-blas.svg?branch=master)](https://travis-ci.org/tmcdonell/accelerate-blas)+[![GitHub CI](https://github.com/tmcdonell/accelerate-blas/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate-blas/actions)+[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby)+<br>+[![Stackage LTS](https://stackage.org/package/accelerate-blas/badge/lts)](https://stackage.org/lts/package/accelerate-blas)+[![Stackage Nightly](https://stackage.org/package/accelerate-blas/badge/nightly)](https://stackage.org/nightly/package/accelerate-blas)+[![Hackage](https://img.shields.io/hackage/v/accelerate-blas.svg)](https://hackage.haskell.org/package/accelerate-blas) +</div>+ Linear systems, matrix decompositions, and other numerical computations for use in Accelerate. Most operations are implemented efficiently via FFI calls to BLAS and LAPACK. For details on Accelerate, refer to the [main repository][GitHub]. -Please get in touch to let me know which missing operations you would like see-added to the library. Contributions are also welcome!---## FFI bindings--  * **accelerate-llvm-native:** FFI bindings are provided by the [blas-hs] package,-    which has several options for which underlying BLAS library to link against;-    see that package for setup details.+The following build flags control whether optimised implementations are used.+Note that enabling these (which is the default) will require the corresponding+Accelerate backend as a dependency: -  * **accelerate-llvm-ptx:** FFI bindings to the NVIDIA [cuBLAS] library.+  - `llvm-ptx`: For NVIDIA GPUs+  - `llvm-cpu`: For multicore CPUs +Contributions and bug reports are welcome! Please get in touch to let us know+which missing operations you would like to see added to the library. Please feel+free to contact me through [GitHub][GitHub] or [gitter.im][gitter.im].    [GitHub]:     https://github.com/AccelerateHS/accelerate+  [gitter.im]:  https://gitter.im/AccelerateHS/Lobby   [blas-hs]:    http://hackage.haskell.org/package/blas-hs   [cuBLAS]:     http://docs.nvidia.com/cuda/cublas/index.html 

@@ -1,5 +1,5 @@ name:                   accelerate-blas-version:                0.2.0.1+version:                0.3.0.0 synopsis:               Numeric Linear Algebra in Accelerate description:   Linear systems, matrix decompositions, and other numerical computations for@@ -12,8 +12,8 @@ license:                BSD3 license-file:           LICENSE author:                 Trevor L. McDonell-maintainer:             tmcdonell@cse.unsw.edu.au-category:               Math+maintainer:             Trevor L. McDonell <trevor.mcdonell@gmail.com>+category:               Accelerate, Math build-type:             Simple extra-source-files:     CHANGELOG.md cabal-version:          >=1.10@@ -46,8 +46,8 @@     Data.Array.Accelerate.Numeric.Sum.LLVM.PTX    build-depends:-        base                            >= 4.7 && < 4.13-      , accelerate                      >= 1.0 && < 1.3+        base                            >= 4.7+      , accelerate                      >= 1.3    hs-source-dirs:       src@@ -59,10 +59,10 @@   if flag(llvm-cpu)     CPP-options:        -DACCELERATE_LLVM_NATIVE_BACKEND     build-depends:-        accelerate-llvm                 >= 1.1 && < 1.3-      , accelerate-llvm-native          >= 1.1 && < 1.3+        accelerate-llvm                 >= 1.3+      , accelerate-llvm-native          >= 1.3       , blas-hs                         >= 0.1-      , llvm-hs-pure                    >= 4.1 && < 8.1+      , llvm-hs-pure                    >= 4.1      other-modules:       Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.Native.Base@@ -73,14 +73,14 @@   if flag(llvm-ptx)     CPP-options:        -DACCELERATE_LLVM_PTX_BACKEND     build-depends:-        accelerate-llvm                 >= 1.1 && < 1.3-      , accelerate-llvm-ptx             >= 1.1 && < 1.3+        accelerate-llvm                 >= 1.3+      , accelerate-llvm-ptx             >= 1.3       , bytestring                      >= 0.9       , containers                      >= 0.5       , cublas                          >= 0.3       , cuda                            >= 0.8       , file-embed                      >= 0.0.10-      , llvm-hs-pure                    >= 4.1 && < 8.1+      , llvm-hs-pure                    >= 4.1       , mtl                             >= 2.2      other-modules:@@ -102,8 +102,8 @@     buildable: False    build-depends:-        base                    >= 4.7  && < 4.13-      , accelerate              >= 1.2+        base                    >= 4.7 && < 5+      , accelerate       , accelerate-blas       , accelerate-llvm-native       , hedgehog                >= 0.5@@ -132,8 +132,8 @@     buildable: False    build-depends:-        base                    >= 4.7  && < 4.13-      , accelerate              >= 1.2+        base                    >= 4.7 && < 5+      , accelerate       , accelerate-blas       , accelerate-llvm-ptx       , hedgehog                >= 0.5@@ -164,7 +164,7 @@     buildable: False    build-depends:-        base                            >= 4.7 && < 4.13+        base                            >= 4.7 && < 5       , criterion                       >= 1.0       , mwc-random                      >= 0.8       , deepseq                         >= 1.0@@ -192,7 +192,7 @@     buildable: False    build-depends:-        base                            >= 4.7 && < 4.13+        base                            >= 4.7 && < 5       , accelerate       , accelerate-blas       , accelerate-llvm-native@@ -221,7 +221,7 @@     buildable: False    build-depends:-        base                            >= 4.7 && < 4.13+        base                            >= 4.7       , accelerate       , accelerate-blas       , accelerate-llvm-ptx@@ -246,7 +246,7 @@  source-repository this   type:     git-  tag:      v0.2.0.1+  tag:      v0.3.0.0   location: https://github.com/tmcdonell/accelerate-blas  -- vim: nospell

@@ -6,10 +6,10 @@ {-# LANGUAGE RankNTypes          #-} -- | -- Module      : Bench.Accelerate--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -20,7 +20,8 @@ import Bench.Util  import Data.Array.Accelerate                                        ( Elt, Z(..), (:.)(..) )-import Data.Array.Accelerate.Trafo                                  ( Afunction, AfunctionR )+import Data.Array.Accelerate.Trafo                                  ( Afunction )+import Data.Array.Accelerate.Trafo.Sharing                          ( AfunctionR ) import Data.Array.Accelerate.Numeric.LinearAlgebra import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.System.Random.MWC@@ -28,6 +29,8 @@ import Criterion.Main import Data.Proxy import Text.Printf+import Prelude                                                      hiding ( (<>) )+  type RunN = forall f. Afunction f => f -> AfunctionR f 

@@ -4,10 +4,10 @@ {-# LANGUAGE RankNTypes          #-} -- | -- Module      : Bench.HMatrix--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -22,6 +22,7 @@ import Data.Proxy import Foreign.Storable import Numeric.LinearAlgebra                                        hiding ( randomVector )+import Prelude                                                      hiding ( (<>) ) import System.Random.MWC import Text.Printf 

@@ -5,10 +5,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module      : Bench.Util--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --

@@ -1,9 +1,9 @@ -- | -- Module      : BenchHMatrix--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --

@@ -1,9 +1,9 @@ -- | -- Module      : BenchNative--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --

@@ -1,9 +1,9 @@ -- | -- Module      : BenchPTX--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --

@@ -1,13 +1,12 @@ {-# LANGUAGE ConstraintKinds   #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ViewPatterns      #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -29,7 +28,7 @@   (<>),    -- * Diagonal-  identity, diagonal,+  identity, diagonal, trace,  ) where @@ -166,7 +165,14 @@ diagonal :: Num e => Acc (Vector e) -> Acc (Matrix e) diagonal v =   let n     = length v-      zeros = fill (index2 n n) 0+      zeros = fill (I2 n n) 0   in-  permute const zeros (\(unindex1 -> i) -> index2 i i) v+  permute const zeros (\(I1 i) -> Just_ (I2 i i)) v++-- | The sum of the diagonal elements of a (square) matrix+--+trace :: Num e => Acc (Matrix e) -> Acc (Scalar e)+trace m =+  let Z :. h :. w = unlift (shape m)+  in  sum (backpermute (index1 (min h w)) (\(I1 i) -> I2 i i) m) 

@@ -2,12 +2,13 @@ {-# LANGUAGE GADTs               #-} {-# LANGUAGE NoImplicitPrelude   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.BLAS.Level1--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -42,7 +43,7 @@ -- sdot :: forall e. Numeric e => Exp e -> Acc (Vector e) -> Acc (Vector e) -> Acc (Scalar e) sdot z xs ys =-  case numericR :: NumericR e of+  case numericR @e of     NumericRfloat32   -> map toFloating $ dsdot (toFloating z) (map toFloating xs) (map toFloating ys)     NumericRfloat64   -> dsdot z xs ys     NumericRcomplex32 -> map d2f $ zsdot (f2d z) (map f2d xs) (map f2d ys)@@ -86,7 +87,7 @@      -> Acc (Vector (Complex e))      -> Acc (Scalar (Complex e)) dotc xs ys =-  case numericR :: NumericR (Complex e) of+  case numericR @(Complex e) of     NumericRcomplex32 -> dotu (map conjugate xs) ys     NumericRcomplex64 -> dotu (map conjugate xs) ys @@ -98,7 +99,7 @@ -- asum :: forall e. Numeric e => Acc (Vector e) -> Acc (Scalar (NumericBaseT e)) asum =-  case numericR :: NumericR e of+  case numericR @e of     NumericRfloat32   -> sum . map abs     NumericRfloat64   -> sum . map abs     NumericRcomplex32 -> sum . map mag@@ -113,7 +114,7 @@ -- amax :: forall e. Numeric e => Acc (Vector e) -> Acc (Scalar Int) amax =-  case numericR :: NumericR e of+  case numericR @e of     NumericRfloat32   -> map (indexHead . fst) . fold1 cmp . indexed . map abs     NumericRfloat64   -> map (indexHead . fst) . fold1 cmp . indexed . map abs     NumericRcomplex32 -> map (indexHead . fst) . fold1 cmp . indexed . map mag@@ -128,7 +129,7 @@ -- amin :: forall e. Numeric e => Acc (Vector e) -> Acc (Scalar Int) amin =-  case numericR :: NumericR e of+  case numericR @e of     NumericRfloat32   -> map (indexHead . fst) . fold1 cmp . indexed . map abs     NumericRfloat64   -> map (indexHead . fst) . fold1 cmp . indexed . map abs     NumericRcomplex32 -> map (indexHead . fst) . fold1 cmp . indexed . map mag

@@ -5,12 +5,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators       #-} {-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.BLAS.Level2--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -28,8 +29,7 @@ ) where  import Data.Array.Accelerate                                        as A-import Data.Array.Accelerate.Smart                                  as A-import Data.Array.Accelerate.Data.Complex                           as A+import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Numeric.LinearAlgebra.Type  #ifdef ACCELERATE_LLVM_NATIVE_BACKEND@@ -64,13 +64,15 @@   where     go = #ifdef ACCELERATE_LLVM_NATIVE_BACKEND-      foreignAcc (CPU.gemv opA) $+      foreignAcc (CPU.gemv nR opA) $ #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND-      foreignAcc (PTX.gemv opA) $+      foreignAcc (PTX.gemv nR opA) $ #endif-      (\(unatup3 -> (_, arr, brr)) -> mXv arr brr)+      (\(T3 _ arr brr) -> mXv arr brr) +    nR = numericR @e+     -- General matrix-vector multiply in pure Accelerate. This is probably not     -- efficient.     --@@ -85,7 +87,7 @@         arr' = case opA of                   N -> arr                   T -> transpose arr-                  H -> case numericR :: NumericR e of+                  H -> case nR of                          NumericRcomplex32 -> map conjugate (transpose arr)                          NumericRcomplex64 -> map conjugate (transpose arr)                          _                 -> transpose arr

@@ -5,12 +5,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators       #-} {-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.BLAS.Level3--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -28,7 +29,6 @@ ) where  import Data.Array.Accelerate                                        as A-import Data.Array.Accelerate.Smart                                  as A import Data.Array.Accelerate.Data.Complex                           as A import Data.Array.Accelerate.Numeric.LinearAlgebra.Type @@ -65,13 +65,15 @@   where     go = #ifdef ACCELERATE_LLVM_NATIVE_BACKEND-      foreignAcc (CPU.gemm opA opB) $+      foreignAcc (CPU.gemm nR opA opB) $ #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND-      foreignAcc (PTX.gemm opA opB) $+      foreignAcc (PTX.gemm nR opA opB) $ #endif-      (\(unatup3 -> (_, arr, brr)) -> mXm arr brr)+      (\(T3 _ arr brr) -> mXm arr brr) +    nR = numericR @e+     -- General dense matrix-matrix multiply written in pure Accelerate. This is     -- not efficient due to the memory access patterns. We could probably     -- improve this a little bit with a divide-and-conquer algorithm, for@@ -92,7 +94,7 @@         arr' = case opA of                  N -> arr                  T -> transpose arr-                 H -> case numericR :: NumericR e of+                 H -> case nR of                         NumericRcomplex32 -> map conjugate (transpose arr)                         NumericRcomplex64 -> map conjugate (transpose arr)                         _                 -> transpose arr@@ -102,7 +104,7 @@         brr' = case opB of                  N -> transpose brr                  T -> brr-                 H -> case numericR :: NumericR e of+                 H -> case nR of                         NumericRcomplex32 -> map conjugate brr                         NumericRcomplex64 -> map conjugate brr                         _                 -> brr

@@ -1,13 +1,11 @@-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE GADTs        #-}+{-# LANGUAGE TypeFamilies #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.Native.Base--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -15,34 +13,44 @@ module Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.Native.Base   where -import Data.Array.Accelerate.Array.Sugar                            ( Array(..), EltRepr )+import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Array.Data import Data.Array.Accelerate.Array.Unique+import Data.Primitive.Vec+ import Data.Array.Accelerate.Numeric.LinearAlgebra.Type+import Foreign.Ptr                                                  (Ptr)  import qualified Blas.Primitive.Types                               as C  +type family ArrayPtrs e :: *+type instance ArrayPtrs Float         = Ptr Float+type instance ArrayPtrs Double        = Ptr Double+type instance ArrayPtrs (Vec2 Float)  = Ptr Float+type instance ArrayPtrs (Vec2 Double) = Ptr Double+ encodeTranspose :: Transpose -> C.Transpose encodeTranspose N = C.NoTrans encodeTranspose T = C.Trans encodeTranspose H = C.ConjTrans -+{-# INLINE withArray #-} withArray-    :: forall sh e b. Numeric e-    => Array sh e-    -> (ArrayPtrs (EltRepr e) -> IO b)+    :: NumericR s e+    -> Array sh e+    -> (ArrayPtrs e -> IO b)     -> IO b-withArray (Array _ adata) = withArrayData (numericR::NumericR e) adata+withArray nR (Array _ ad) k = withArrayData nR ad k +{-# INLINE withArrayData #-} withArrayData-    :: NumericR e-    -> ArrayData (EltRepr e)-    -> (ArrayPtrs (EltRepr e) -> IO b)+    :: NumericR s e+    -> ArrayData e+    -> (ArrayPtrs e -> IO b)     -> IO b-withArrayData NumericRfloat32   (AD_Float  ua)         f = withUniqueArrayPtr ua f-withArrayData NumericRfloat64   (AD_Double ua)         f = withUniqueArrayPtr ua f-withArrayData NumericRcomplex32 (AD_V2 (AD_Float  ua)) f = withUniqueArrayPtr ua f-withArrayData NumericRcomplex64 (AD_V2 (AD_Double ua)) f = withUniqueArrayPtr ua f+withArrayData NumericRfloat32   = withUniqueArrayPtr+withArrayData NumericRfloat64   = withUniqueArrayPtr+withArrayData NumericRcomplex32 = withUniqueArrayPtr+withArrayData NumericRcomplex64 = withUniqueArrayPtr 

@@ -1,11 +1,14 @@ {-# LANGUAGE GADTs               #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.Native.Level2--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -13,7 +16,11 @@ module Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.Native.Level2   where -import Data.Array.Accelerate                                        as A+import Data.Complex+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Sugar.Elt+ import Data.Array.Accelerate.LLVM.Native.Foreign import Data.Array.Accelerate.Numeric.LinearAlgebra.Type import Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.Native.Base@@ -23,32 +30,45 @@ import qualified Blas.Primitive.Unsafe                              as C  -gemv :: forall e. Numeric e-     => Transpose-     -> ForeignAcc ((Scalar e, Matrix e, Vector e) -> Vector e)-gemv opA = ForeignAcc "native.gemv" gemv'-  where-    gemv' (alpha, matA, vecx) = do-      let-          Z :. rowsA :. colsA = arrayShape matA+gemv :: NumericR s e+     -> Transpose+     -> ForeignAcc ((((((), Scalar e), Matrix e), Vector e)) -> Vector e)+gemv nR opA = ForeignAcc "native.gemv" (gemv' nR opA) -          sizeY   = case opA of-                      N -> rowsA-                      _ -> colsA+gemv' :: NumericR s e+      -> Transpose+      -> ((((), Scalar e), Matrix e), Vector e)+      -> Par Native (Future (Vector e))+gemv' nR opA ((((), alpha), matA), vecx) = do+  let+      (((), rowsA), colsA) = shape matA -          opA'    = encodeTranspose opA-          alpha'  = indexArray alpha Z-      ---      vecy  <- allocateRemote (Z :. sizeY) :: LLVM Native (Vector e)-      ()    <- liftIO $ do-        withArray matA   $ \ptr_A -> do-         withArray vecx  $ \ptr_x -> do-          withArray vecy $ \ptr_y -> do-            case numericR :: NumericR e of-              NumericRfloat32   -> C.sgemv C.RowMajor opA' rowsA colsA alpha' ptr_A colsA ptr_x 1 0 ptr_y 1-              NumericRfloat64   -> C.dgemv C.RowMajor opA' rowsA colsA alpha' ptr_A colsA ptr_x 1 0 ptr_y 1-              NumericRcomplex32 -> C.cgemv C.RowMajor opA' rowsA colsA alpha' (castPtr ptr_A) colsA (castPtr ptr_x) 1 0 (castPtr ptr_y) 1-              NumericRcomplex64 -> C.zgemv C.RowMajor opA' rowsA colsA alpha' (castPtr ptr_A) colsA (castPtr ptr_x) 1 0 (castPtr ptr_y) 1-        ---      return vecy+      sizeY   = case opA of+                  N -> rowsA+                  _ -> colsA++      opA'    = encodeTranspose opA+      alpha'  = indexArray (ArrayR dim0 eR) alpha ()++      aR      = ArrayR dim1 eR+      eR      = case nR of+                  NumericRfloat32   -> eltR @Float+                  NumericRfloat64   -> eltR @Double+                  NumericRcomplex32 -> eltR @(Complex Float)+                  NumericRcomplex64 -> eltR @(Complex Double)+  --+  future <- new+  vecy   <- allocateRemote aR ((), sizeY)+  ()     <- liftIO $ do+    withArray nR matA   $ \ptr_A -> do+     withArray nR vecx  $ \ptr_x -> do+      withArray nR vecy $ \ptr_y -> do+        case nR of+          NumericRfloat32   -> C.sgemv C.RowMajor opA' rowsA colsA alpha' ptr_A colsA ptr_x 1 0 ptr_y 1+          NumericRfloat64   -> C.dgemv C.RowMajor opA' rowsA colsA alpha' ptr_A colsA ptr_x 1 0 ptr_y 1+          NumericRcomplex32 -> C.cgemv C.RowMajor opA' rowsA colsA (toElt alpha') (castPtr ptr_A) colsA (castPtr ptr_x) 1 0 (castPtr ptr_y) 1+          NumericRcomplex64 -> C.zgemv C.RowMajor opA' rowsA colsA (toElt alpha') (castPtr ptr_A) colsA (castPtr ptr_x) 1 0 (castPtr ptr_y) 1+  --+  put future vecy+  return future 

@@ -1,11 +1,15 @@ {-# LANGUAGE GADTs               #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.Native.Level3--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -13,7 +17,11 @@ module Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.Native.Level3   where -import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Data.Complex+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Sugar.Elt+ import Data.Array.Accelerate.LLVM.Native.Foreign import Data.Array.Accelerate.Numeric.LinearAlgebra.Type import Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.Native.Base@@ -27,41 +35,57 @@ -- -- https://www.christophlassner.de/using-blas-from-c-with-row-major-data.html ---gemm :: forall e. Numeric e-     => Transpose+gemm :: NumericR s e      -> Transpose-     -> ForeignAcc ((Scalar e, Matrix e, Matrix e) -> Matrix e)-gemm opA opB = ForeignAcc "native.gemm" gemm'+     -> Transpose+     -> ForeignAcc (((((), Scalar e), Matrix e), Matrix e) -> Matrix e)+gemm nR opA opB = ForeignAcc "native.gemm" (gemm' nR opA opB)   where-    gemm' (alpha, matA, matB) = do-      let-          Z :. rowsA :. colsA = arrayShape matA-          Z :. rowsB :. colsB = arrayShape matB -          (m,k)   = case opA of-                      N -> (rowsA, colsA)-                      _ -> (colsA, rowsA)-          n       = case opB of-                      N -> colsB-                      _ -> rowsB+gemm' :: NumericR s e+      -> Transpose+      -> Transpose+      -> ((((), Scalar e), Matrix e), Matrix e)+      -> Par Native (Future (Matrix e))+gemm' nR opA opB ((((), alpha), matA), matB) = do+  let+      (((), rowsA), colsA) = shape matA+      (((), rowsB), colsB) = shape matB -          lda     = colsA-          ldb     = colsB+      (m,k)   = case opA of+                  N -> (rowsA, colsA)+                  _ -> (colsA, rowsA)+      n       = case opB of+                  N -> colsB+                  _ -> rowsB -          opA'    = encodeTranspose opA-          opB'    = encodeTranspose opB-          alpha'  = indexArray alpha Z-      ---      matC  <- allocateRemote (Z :. m :. n) :: LLVM Native (Matrix e)-      ()    <- liftIO $ do-        withArray matA   $ \ptr_A -> do-         withArray matB  $ \ptr_B -> do-          withArray matC $ \ptr_C -> do-            case numericR :: NumericR e of-              NumericRfloat32   -> C.sgemm C.RowMajor opA' opB' m n k alpha' ptr_A lda ptr_B ldb 0 ptr_C n-              NumericRfloat64   -> C.dgemm C.RowMajor opA' opB' m n k alpha' ptr_A lda ptr_B ldb 0 ptr_C n-              NumericRcomplex32 -> C.cgemm C.RowMajor opA' opB' m n k alpha' (castPtr ptr_A) lda (castPtr ptr_B) ldb 0 (castPtr ptr_C) n-              NumericRcomplex64 -> C.zgemm C.RowMajor opA' opB' m n k alpha' (castPtr ptr_A) lda (castPtr ptr_B) ldb 0 (castPtr ptr_C) n-      ---      return matC+      lda     = colsA+      ldb     = colsB++      opA'    = encodeTranspose opA+      opB'    = encodeTranspose opB+      alpha'  = indexArray (ArrayR dim0 eR) alpha ()++      aR      = ArrayR dim2 eR+      eR      = case nR of+                  NumericRfloat32   -> eltR @Float+                  NumericRfloat64   -> eltR @Double+                  NumericRcomplex32 -> eltR @(Complex Float)+                  NumericRcomplex64 -> eltR @(Complex Double)++  --+  future <- new+  matC   <- allocateRemote aR (((), m), n)+  ()     <- liftIO $ do+    withArray nR matA   $ \ptr_A -> do+     withArray nR matB  $ \ptr_B -> do+      withArray nR matC $ \ptr_C -> do+        case nR of+          NumericRfloat32   -> C.sgemm C.RowMajor opA' opB' m n k alpha' ptr_A lda ptr_B ldb 0 ptr_C n+          NumericRfloat64   -> C.dgemm C.RowMajor opA' opB' m n k alpha' ptr_A lda ptr_B ldb 0 ptr_C n+          NumericRcomplex32 -> C.cgemm C.RowMajor opA' opB' m n k (toElt alpha') (castPtr ptr_A) lda (castPtr ptr_B) ldb 0 (castPtr ptr_C) n+          NumericRcomplex64 -> C.zgemm C.RowMajor opA' opB' m n k (toElt alpha') (castPtr ptr_A) lda (castPtr ptr_B) ldb 0 (castPtr ptr_C) n+  --+  put future matC+  return future 

@@ -1,11 +1,15 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE MagicHash           #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE UnboxedTuples       #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Base--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -14,22 +18,27 @@   where  import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Sugar                            ( Array(..), EltRepr )+import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Lifetime import Data.Array.Accelerate.Numeric.LinearAlgebra.Type+import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Type+import Data.Primitive.Vec  import Data.Array.Accelerate.LLVM.PTX.Foreign  import Foreign.CUDA.Ptr                                             ( DevicePtr ) import qualified Foreign.CUDA.BLAS                                  as C +import GHC.Base+import GHC.Ptr + type family DevicePtrs e :: *-type instance DevicePtrs Float       = DevicePtr Float-type instance DevicePtrs Double      = DevicePtr Double-type instance DevicePtrs (V2 Float)  = DevicePtr Float-type instance DevicePtrs (V2 Double) = DevicePtr Double+type instance DevicePtrs Float         = DevicePtr Float+type instance DevicePtrs Double        = DevicePtr Double+type instance DevicePtrs (Vec2 Float)  = DevicePtr Float+type instance DevicePtrs (Vec2 Double) = DevicePtr Double   encodeTranspose :: Transpose -> C.Operation@@ -38,42 +47,72 @@ encodeTranspose H = C.C  +{-# INLINE withV2 #-}+withV2+    :: NumericR s (Vec2 a)+    -> Vec2 a+    -> (Ptr (Complex a) -> IO b)+    -> IO b+withV2 nR (Vec ba#) k =+  let !(I# bytes#) = case nR of+                       NumericRcomplex32 -> 8+                       NumericRcomplex64 -> 16+  in+  case isByteArrayPinned# ba# of+   1# -> IO $ \s0 ->+     case k (Ptr (byteArrayContents# ba#)) of { IO k#       ->+     case k# s0                            of { (# s1, r #) ->+     case touch# ba# s1                    of { s2          ->+       (# s2, r #) }}}+  --+   _  -> IO $ \s0 ->+     case newAlignedPinnedByteArray# bytes# 16# s0                        of { (# s1, mba# #) ->+     case copyAddrToByteArray# (byteArrayContents# ba#) mba# 0# bytes# s1 of { s2             ->+     case unsafeFreezeByteArray# mba# s2                                  of { (# s3, ba'# #) ->+     case k (Ptr (byteArrayContents# ba'#))                               of { IO k#          ->+     case k# s3                                                           of { (# s4, r #)    ->+     case touch# ba'# s4                                                  of { s5             ->+       (# s5, r #) }}}}}}++{-# INLINE withArray #-} withArray-    :: forall sh e b. Numeric e-    => Array sh e+    :: NumericR s e+    -> Array sh e     -> Stream-    -> (DevicePtrs (EltRepr e) -> LLVM PTX b)+    -> (DevicePtrs e -> LLVM PTX b)     -> LLVM PTX b-withArray (Array _ adata) s k = withArrayData (numericR::NumericR e) adata s k+withArray eR (Array _ adata) s k =+  withArrayData eR adata s k +{-# INLINE withArrayData #-} withArrayData-    :: NumericR e-    -> ArrayData (EltRepr e)+    :: NumericR s e+    -> ArrayData e     -> Stream-    -> (DevicePtrs (EltRepr e) -> LLVM PTX b)+    -> (DevicePtrs e -> LLVM PTX b)     -> LLVM PTX b withArrayData NumericRfloat32 ad s k =-  withDevicePtr ad $ \p -> do+  withDevicePtr (singleType @Float) ad $ \p -> do     r <- k p-    e <- checkpoint s+    e <- waypoint s     return (Just e,r) withArrayData NumericRfloat64 ad s k =-  withDevicePtr ad $ \p -> do+  withDevicePtr (singleType @Double) ad $ \p -> do     r <- k p-    e <- checkpoint s+    e <- waypoint s     return (Just e, r)-withArrayData NumericRcomplex32 (AD_V2 ad) s k =-  withDevicePtr ad $ \p -> do+withArrayData NumericRcomplex32 ad s k =+  withDevicePtr (singleType @Float) ad $ \p -> do     r <- k p-    e <- checkpoint s+    e <- waypoint s     return (Just e,r)-withArrayData NumericRcomplex64 (AD_V2 ad) s k =-  withDevicePtr ad $ \p -> do+withArrayData NumericRcomplex64 ad s k =+  withDevicePtr (singleType @Double) ad $ \p -> do     r <- k p-    e <- checkpoint s+    e <- waypoint s     return (Just e, r) -+{-# INLINE withLifetime' #-} withLifetime' :: Lifetime a -> (a -> LLVM PTX b) -> LLVM PTX b withLifetime' l k = do   r <- k (unsafeGetValue l)

@@ -1,10 +1,10 @@ {-# LANGUAGE MagicHash #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Context--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --

@@ -1,11 +1,12 @@ {-# LANGUAGE GADTs               #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Level2--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -13,8 +14,11 @@ module Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Level2   where -import Data.Array.Accelerate                                        as A-import Data.Array.Accelerate.Array.Sugar                            ( Array(..) )+import Data.Complex+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Sugar.Elt+ import Data.Array.Accelerate.LLVM.PTX.Foreign import Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Base import Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Context@@ -25,7 +29,9 @@ import qualified Foreign.CUDA.Ptr                                   as CUDA import qualified Foreign.CUDA.BLAS                                  as BLAS +import Control.Monad.Reader + -- NOTE: cuBLAS requires matrices to be stored in column-major order -- (Fortran-style), but Accelerate uses C-style arrays in row-major order. --@@ -34,43 +40,42 @@ -- is no conjugate-no-transpose operation, we implement that via 'gemm', which -- I assume is more efficient than ?geam followed by ?gemv. ---gemv :: Numeric e-     => Transpose-     -> ForeignAcc ((Scalar e, Matrix e, Vector e) -> Vector e)-gemv opA = ForeignAcc "ptx.gemv" (gemv' numericR opA)+gemv :: NumericR s e+     -> Transpose+     -> ForeignAcc ((((((), Scalar e), Matrix e), Vector e)) -> Vector e)+gemv eR opA = ForeignAcc "ptx.gemv" (gemv' eR opA) -gemv' :: Numeric e-      => NumericR e+gemv' :: NumericR s e       -> Transpose-      -> Stream-      -> (Scalar e, Matrix e, Vector e)-      -> LLVM PTX (Vector e)-gemv' NumericRcomplex32 H = as_gemm H-gemv' NumericRcomplex64 H = as_gemm H-gemv' _                 t = as_gemv t+      -> ((((), Scalar e), Matrix e), Vector e)+      -> Par PTX (Future (Vector e))+gemv' NumericRcomplex32 H = as_gemm NumericRcomplex32 H+gemv' NumericRcomplex64 H = as_gemm NumericRcomplex64 H+gemv' nR                t = as_gemv nR t   as_gemm-    :: Numeric e-    => Transpose-    -> Stream-    -> (Scalar e, Matrix e, Vector e)-    -> LLVM PTX (Vector e)-as_gemm opA stream (alpha, matA, Array sh adata) = do+    :: NumericR s e+    -> Transpose+    -> ((((), Scalar e), Matrix e), Vector e)+    -> Par PTX (Future (Vector e))+as_gemm nR opA ((((), alpha), matA), Array sh adata) = do   let matB = Array (sh,1) adata   ---  Array (sh',_) vecy <- gemm' opA N stream (alpha, matA, matB)-  return (Array sh' vecy)+  future <- new+  result <- gemm' nR opA N ((((), alpha), matA), matB)+  fork $ do Array (sh',_) vecy <- get result+            put future (Array sh' vecy)+  return future  as_gemv-    :: forall e. Numeric e-    => Transpose-    -> Stream-    -> (Scalar e, Matrix e, Vector e)-    -> LLVM PTX (Vector e)-as_gemv opA stream (alpha, matA, vecx) = do+    :: NumericR s e+    -> Transpose+    -> ((((), Scalar e), Matrix e), Vector e)+    -> Par PTX (Future (Vector e))+as_gemv nR opA ((((), alpha), matA), vecx) = do   let-      Z :. rowsA :. colsA = arrayShape matA+      (((), rowsA), colsA) = shape matA        sizeY   = case opA of                   N -> rowsA@@ -80,15 +85,24 @@               $ case opA of                   N -> T                   _ -> N++      aR      = ArrayR dim1 eR+      eR      = case nR of+                  NumericRfloat32   -> eltR @Float+                  NumericRfloat64   -> eltR @Double+                  NumericRcomplex32 -> eltR @(Complex Float)+                  NumericRcomplex64 -> eltR @(Complex Double)   ---  vecy    <- allocateRemote (Z :. sizeY) :: LLVM PTX (Vector e)-  alpha'  <- indexRemote alpha 0-  ()      <- do-    withArray matA stream   $ \ptr_A -> do-     withArray vecx stream  $ \ptr_x -> do-      withArray vecy stream $ \ptr_y -> do-       withBLAS             $ \hdl   -> do-         case numericR :: NumericR e of+  future  <- new+  stream  <- asks ptxStream+  vecy    <- allocateRemote aR ((), sizeY)+  alpha'  <- indexRemote eR alpha 0+  ()      <- liftPar $ do+    withArray nR matA stream   $ \ptr_A -> do+     withArray nR vecx stream  $ \ptr_x -> do+      withArray nR vecy stream $ \ptr_y -> do+       withBLAS                $ \hdl   -> do+         case nR of            NumericRfloat32 -> liftIO $             with alpha' $ \ptr_alpha ->              with 0     $ \ptr_beta  ->@@ -100,14 +114,15 @@                BLAS.dgemv hdl opA' colsA rowsA ptr_alpha ptr_A colsA ptr_x 1 ptr_beta ptr_y 1             NumericRcomplex32 -> liftIO $-            with alpha' $ \ptr_alpha ->-             with 0     $ \ptr_beta  ->+            withV2 nR alpha' $ \ptr_alpha ->+             with 0          $ \ptr_beta  ->                BLAS.cgemv hdl opA' colsA rowsA ptr_alpha (CUDA.castDevPtr ptr_A) colsA (CUDA.castDevPtr ptr_x) 1 ptr_beta (CUDA.castDevPtr ptr_y)  1             NumericRcomplex64 -> liftIO $-            with alpha' $ \ptr_alpha ->-             with 0     $ \ptr_beta  ->+            withV2 nR alpha' $ \ptr_alpha ->+             with 0          $ \ptr_beta  ->                BLAS.zgemv hdl opA' colsA rowsA ptr_alpha (CUDA.castDevPtr ptr_A) colsA (CUDA.castDevPtr ptr_x) 1 ptr_beta (CUDA.castDevPtr ptr_y)  1   ---  return vecy+  put future vecy+  return future 

@@ -1,11 +1,12 @@ {-# LANGUAGE GADTs               #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Level3--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -13,7 +14,11 @@ module Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Level3   where -import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Data.Complex+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Sugar.Elt+ import Data.Array.Accelerate.LLVM.PTX.Foreign import Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Base import Data.Array.Accelerate.Numeric.LinearAlgebra.LLVM.PTX.Context@@ -23,7 +28,9 @@ import qualified Foreign.CUDA.Ptr                                   as CUDA import qualified Foreign.CUDA.BLAS                                  as BLAS +import Control.Monad.Reader + -- NOTE: cuBLAS requires that matrices are stored in column-major order -- (Fortran-style), but Accelerate uses a C-style convention where matrices are -- stored in row-major order.@@ -31,23 +38,21 @@ -- At least for matrix-matrix multiply, we can get around this problem by making -- use of the equivalence \( B^T \cdot A^T = (A \cdot B)^T \). ---gemm :: Numeric e-     => Transpose+gemm :: NumericR s e      -> Transpose-     -> ForeignAcc ((Scalar e, Matrix e, Matrix e) -> Matrix e)-gemm opA opB = ForeignAcc "ptx.gemm" (gemm' opA opB)+     -> Transpose+     -> ForeignAcc (((((), Scalar e), Matrix e), Matrix e) -> Matrix e)+gemm nR opA opB = ForeignAcc "ptx.gemm" (gemm' nR opA opB) -gemm'-    :: forall e. Numeric e-    => Transpose-    -> Transpose-    -> Stream-    -> (Scalar e, Matrix e, Matrix e)-    -> LLVM PTX (Matrix e)-gemm' opA opB stream (alpha, matA, matB) = do+gemm' :: NumericR s e+      -> Transpose+      -> Transpose+      -> ((((), Scalar e), Matrix e), Matrix e)+      -> Par PTX (Future (Matrix e))+gemm' nR opA opB ((((), alpha), matA), matB) = do   let-      Z :. rowsA :. colsA = arrayShape matA-      Z :. rowsB :. colsB = arrayShape matB+      (((), rowsA), colsA) = shape matA+      (((), rowsB), colsB) = shape matB        (m,k)   = case opA of                   N -> (rowsA, colsA)@@ -61,33 +66,45 @@        opA'    = encodeTranspose opA       opB'    = encodeTranspose opB-  ---  matC   <- allocateRemote (Z :. m :. n) :: LLVM PTX (Matrix e)-  alpha' <- indexRemote alpha 0-  ()     <- withArray matA stream   $ \ptr_A -> do-             withArray matB stream  $ \ptr_B -> do-              withArray matC stream $ \ptr_C -> do-                withBLAS            $ \hdl   -> do-                  case numericR :: NumericR e of-                    NumericRfloat32 -> liftIO $-                      with alpha' $ \ptr_alpha ->-                       with 0     $ \ptr_beta  ->-                        BLAS.sgemm hdl opB' opA' n m k ptr_alpha ptr_B ldb ptr_A lda ptr_beta ptr_C n -                    NumericRfloat64 -> liftIO $-                      with alpha' $ \ptr_alpha ->-                       with 0     $ \ptr_beta  ->-                        BLAS.dgemm hdl opB' opA' n m k ptr_alpha ptr_B ldb ptr_A lda ptr_beta ptr_C n+      aR      = ArrayR dim2 eR+      eR      = case nR of+                  NumericRfloat32   -> eltR @Float+                  NumericRfloat64   -> eltR @Double+                  NumericRcomplex32 -> eltR @(Complex Float)+                  NumericRcomplex64 -> eltR @(Complex Double) -                    NumericRcomplex32 -> liftIO $-                      with alpha' $ \ptr_alpha ->-                       with 0     $ \ptr_beta  ->-                        BLAS.cgemm hdl opB' opA' n m k ptr_alpha (CUDA.castDevPtr ptr_B) ldb (CUDA.castDevPtr ptr_A) lda ptr_beta (CUDA.castDevPtr ptr_C) n+  --+  future <- new+  stream <- asks ptxStream+  matC   <- allocateRemote aR (((), m), n)+  alpha' <- indexRemote eR alpha 0+  ()     <- liftPar $+    withArray nR matA stream   $ \ptr_A -> do+     withArray nR matB stream  $ \ptr_B -> do+      withArray nR matC stream $ \ptr_C -> do+        withBLAS               $ \hdl   -> do+          case nR of+            NumericRfloat32 -> liftIO $+              with alpha' $ \ptr_alpha ->+               with 0     $ \ptr_beta  ->+                BLAS.sgemm hdl opB' opA' n m k ptr_alpha ptr_B ldb ptr_A lda ptr_beta ptr_C n -                    NumericRcomplex64 -> liftIO $-                      with alpha' $ \ptr_alpha ->-                       with 0     $ \ptr_beta  ->-                        BLAS.zgemm hdl opB' opA' n m k ptr_alpha (CUDA.castDevPtr ptr_B) ldb (CUDA.castDevPtr ptr_A) lda ptr_beta (CUDA.castDevPtr ptr_C) n+            NumericRfloat64 -> liftIO $+              with alpha' $ \ptr_alpha ->+               with 0     $ \ptr_beta  ->+                BLAS.dgemm hdl opB' opA' n m k ptr_alpha ptr_B ldb ptr_A lda ptr_beta ptr_C n -  return matC+            NumericRcomplex32 -> liftIO $+              withV2 nR alpha' $ \ptr_alpha ->+               with 0          $ \ptr_beta  ->+                BLAS.cgemm hdl opB' opA' n m k ptr_alpha (CUDA.castDevPtr ptr_B) ldb (CUDA.castDevPtr ptr_A) lda ptr_beta (CUDA.castDevPtr ptr_C) n++            NumericRcomplex64 -> liftIO $+              withV2 nR alpha' $ \ptr_alpha ->+               with 0          $ \ptr_beta  ->+                BLAS.zgemm hdl opB' opA' n m k ptr_alpha (CUDA.castDevPtr ptr_B) ldb (CUDA.castDevPtr ptr_A) lda ptr_beta (CUDA.castDevPtr ptr_C) n+  --+  put future matC+  return future 

@@ -1,30 +1,27 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE ConstraintKinds   #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs             #-} {-# LANGUAGE TypeFamilies      #-} -- | -- Module      : Data.Array.Accelerate.Numeric.LinearAlgebra.Type--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --  module Data.Array.Accelerate.Numeric.LinearAlgebra.Type ( -#if MIN_VERSION_accelerate(1,2,0)-  Matrix,-#endif   module Data.Array.Accelerate.Numeric.LinearAlgebra.Type,  ) where  import Data.Array.Accelerate                                        as A import Data.Array.Accelerate.Data.Complex                           as A+import Data.Array.Accelerate.Sugar.Elt+import Data.Primitive.Vec  import qualified Prelude                                            as P @@ -32,14 +29,14 @@ -- For explicit dictionary reification, to recover the type the operation should -- be performed at. ---data NumericR a where-  NumericRfloat32   :: NumericR Float-  NumericRfloat64   :: NumericR Double-  NumericRcomplex32 :: NumericR (Complex Float)-  NumericRcomplex64 :: NumericR (Complex Double)+data NumericR s r where+  NumericRfloat32   :: NumericR Float Float+  NumericRfloat64   :: NumericR Double Double+  NumericRcomplex32 :: NumericR (Complex Float) (Vec2 Float)+  NumericRcomplex64 :: NumericR (Complex Double) (Vec2 Double) -class (Elt a, Num a) => Numeric a where-  numericR :: NumericR a+class Num a => Numeric a where+  numericR :: NumericR a (EltR a)  instance Numeric Float where   numericR = NumericRfloat32@@ -64,12 +61,6 @@   NumericBaseT (Complex Float)  = Float   NumericBaseT (Complex Double) = Double --#if !MIN_VERSION_accelerate(1,2,0)--- | Matrices as dense two-dimensional arrays in row-major ordering----type Matrix e = Array DIM2 e-#endif  -- | Orientation of the underlying data. --

@@ -1,20 +1,23 @@ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms       #-} {-# LANGUAGE RebindableSyntax      #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} {-# LANGUAGE ViewPatterns          #-} -- | -- Module      : Data.Array.Accelerate.Numeric.Sum--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -43,29 +46,25 @@   sum,    -- * Kahan-Babuška-Neumaier summation-  KBN(..),+  KBN(..), pattern KBN_,   kbn,    -- * Order-2 Kahan-Babuška summation-  KB2(..),+  KB2(..), pattern KB2_,   kb2,    -- * Kahan summation-  Kahan(..),+  Kahan(..), pattern Kahan_,   kahan,  ) where  import Data.Array.Accelerate                                        as A hiding ( sum, fromInteger ) import Data.Array.Accelerate.Type                                   as A-import Data.Array.Accelerate.Smart                                  as A ( Exp(..), PreExp(..) )-import Data.Array.Accelerate.Product                                as A-import Data.Array.Accelerate.Array.Sugar                            as A import Data.Array.Accelerate.Numeric.Sum.Arithmetic                 as A  import Data.Proxy-import Data.Typeable-import Prelude                                                      ( Show, fromInteger )+import Prelude                                                      ( fromInteger )   -- | Sum an array using a particular compensation scheme.@@ -104,15 +103,21 @@ -- costly than plain Kahan summation, but is /always/ at least as accurate. -- data KBN a = KBN a a-  deriving (Show, Typeable)+  deriving (Show, Generic) +pattern KBN_ :: Elt a => Exp a -> Exp a -> Exp (KBN a)+pattern KBN_ s c = Pattern (c, s)+{-# COMPLETE KBN_ #-}++instance Elt a => Elt (KBN a)+ -- | Return the result of a Kahan-Babuška-Neumaier sum. -- kbn :: Proxy KBN kbn = Proxy  kbnAdd :: (Num a, Ord a, IsFloating a) => Exp (KBN a) -> Exp (KBN a) -> Exp (KBN a)-kbnAdd (unlift -> KBN s1 c1) (unlift -> KBN s2 c2) = lift (KBN s' c')+kbnAdd (KBN_ s1 c1) (KBN_ s2 c2) = KBN_ s' c'   where     s' = s1 `fadd` s2     c' = c1 `fadd` c2 `fadd` if abs s1 >= abs s2@@ -137,40 +142,12 @@   into _ x  = lift (KBN x 0)   from _ x  = let KBN s c = unlift x in s + c -instance Summation KBN CFloat where-  zero      = constant (KBN 0 0)-  add       = kbnAdd-  into _ x  = lift (KBN x 0)-  from _ x  = let KBN s c = unlift x in s + c--instance Summation KBN CDouble where-  zero      = constant (KBN 0 0)-  add       = kbnAdd-  into _ x  = lift (KBN x 0)-  from _ x  = let KBN s c = unlift x in s + c--type instance EltRepr (KBN a) = (((), EltRepr a), EltRepr a)--instance Elt a => Elt (KBN a) where-  eltType _ = TypeRunit `TypeRpair` eltType (undefined::a)-                        `TypeRpair` eltType (undefined::a)-  toElt (((),a),b)  = KBN (toElt a) (toElt b)-  fromElt (KBN a b) = (((), fromElt a), fromElt b)--instance Elt a => IsProduct Elt (KBN a) where-  type ProdRepr (KBN a) = (((), a), a)-  toProd _ (((),a),b)  = KBN a b-  fromProd _ (KBN a b) = (((),a),b)-  prod _ _             = ProdRsnoc $ ProdRsnoc ProdRunit- instance (Lift Exp a, Elt (Plain a)) => Lift Exp (KBN a) where   type Plain (KBN a) = KBN (Plain a)-  lift (KBN a b)     = Exp $ Tuple $ NilTup `SnocTup` lift a-                                               `SnocTup` lift b+  lift (KBN a b)     = KBN_ (lift a) (lift b)  instance Elt a => Unlift Exp (KBN (Exp a)) where-  unlift t = KBN (Exp $ SuccTupIdx ZeroTupIdx `Prj` t)-                 (Exp $ ZeroTupIdx `Prj` t)+  unlift (KBN_ a b) = KBN a b   -- | Second-order Kahan-Babuška summation.  This is more computationally costly@@ -181,8 +158,14 @@ -- compensation term, hence the use of \"second order\" in the name. -- data KB2 a = KB2 a a a-  deriving (Show, Typeable)+  deriving (Show, Generic) +pattern KB2_ :: Elt a => Exp a -> Exp a -> Exp a -> Exp (KB2 a)+pattern KB2_ s c cc = Pattern (s, c, cc)+{-# COMPLETE KB2_ #-}++instance Elt a => Elt (KB2 a)+ -- | Return the result of a second-order Kahan-Babuška sum. -- kb2 :: Proxy KB2@@ -219,58 +202,33 @@   into _ x  = lift (KB2 x 0 0)   from _ x  = let KB2 s c cc = unlift x in s + c + cc -instance Summation KB2 CFloat where-  zero      = constant (KB2 0 0 0)-  add       = kb2Add-  into _ x  = lift (KB2 x 0 0)-  from _ x  = let KB2 s c cc = unlift x in s + c + cc--instance Summation KB2 CDouble where-  zero      = constant (KB2 0 0 0)-  add       = kb2Add-  into _ x  = lift (KB2 x 0 0)-  from _ x  = let KB2 s c cc = unlift x in s + c + cc--type instance EltRepr (KB2 a) = ((((), EltRepr a), EltRepr a), EltRepr a)--instance Elt a => Elt (KB2 a) where-  eltType _ = TypeRunit `TypeRpair` eltType (undefined::a)-                        `TypeRpair` eltType (undefined::a)-                        `TypeRpair` eltType (undefined::a)-  toElt ((((),a),b),c) = KB2 (toElt a) (toElt b) (toElt c)-  fromElt (KB2 a b c)  = ((((), fromElt a), fromElt b), fromElt c)--instance Elt a => IsProduct Elt (KB2 a) where-  type ProdRepr (KB2 a)   = ((((), a), a), a)-  toProd _ ((((),a),b),c) = KB2 a b c-  fromProd _ (KB2 a b c)  = ((((),a),b),c)-  prod _ _                = ProdRsnoc $ ProdRsnoc $ ProdRsnoc ProdRunit- instance (Lift Exp a, Elt (Plain a)) => Lift Exp (KB2 a) where   type Plain (KB2 a) = KB2 (Plain a)-  lift (KB2 a b c)   = Exp $ Tuple $ NilTup `SnocTup` lift a-                                            `SnocTup` lift b-                                            `SnocTup` lift c+  lift (KB2 a b c)   = KB2_ (lift a) (lift b) (lift c)  instance Elt a => Unlift Exp (KB2 (Exp a)) where-  unlift t = KB2 (Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` t)-                 (Exp $ SuccTupIdx ZeroTupIdx `Prj` t)-                 (Exp $ ZeroTupIdx `Prj` t)+  unlift (KB2_ a b c) = KB2 a b c   -- | Kahan summation. This is the least accurate of the compensated summation -- methods. This summation method is included only for completeness. -- data Kahan a = Kahan a a-  deriving (Show, Typeable)+  deriving (Show, Generic) +pattern Kahan_ :: Elt a => Exp a -> Exp a -> Exp (Kahan a)+pattern Kahan_ s c = Pattern (s, c)+{-# COMPLETE Kahan_ #-}++instance Elt a => Elt (Kahan a)+ -- | Return the result of a Kahan sum. -- kahan :: Proxy Kahan kahan = Proxy  kahanAdd :: (Num a, IsFloating a) => Exp (Kahan a) -> Exp (Kahan a) -> Exp (Kahan a)-kahanAdd (unlift -> Kahan s1 c1 :: Kahan (Exp a)) (unlift -> Kahan s2 c2) = lift (Kahan s' c')+kahanAdd (Kahan_ s1 c1) (Kahan_ s2 c2) = Kahan_ s' c'   where     s'  = s1 `fadd` y     c'  = (s' `fsub` s1) `fsub` y@@ -294,38 +252,10 @@   into _ x  = lift (Kahan x 0)   from _ x  = let Kahan s _ = unlift x in s -instance Summation Kahan CFloat where-  zero      = constant (Kahan 0 0)-  add       = kahanAdd-  into _ x  = lift (Kahan x 0)-  from _ x  = let Kahan s _ = unlift x in s--instance Summation Kahan CDouble where-  zero      = constant (Kahan 0 0)-  add       = kahanAdd-  into _ x  = lift (Kahan x 0)-  from _ x  = let Kahan s _ = unlift x in s--type instance EltRepr (Kahan a) = (((), EltRepr a), EltRepr a)--instance Elt a => Elt (Kahan a) where-  eltType _ = TypeRunit `TypeRpair` eltType (undefined::a)-                        `TypeRpair` eltType (undefined::a)-  toElt (((),a),b)    = Kahan (toElt a) (toElt b)-  fromElt (Kahan a b) = (((), fromElt a), fromElt b)--instance Elt a => IsProduct Elt (Kahan a) where-  type ProdRepr (Kahan a) = (((), a), a)-  toProd _ (((),a),b)     = Kahan a b-  fromProd _ (Kahan a b)  = (((),a),b)-  prod _ _                = ProdRsnoc $ ProdRsnoc ProdRunit- instance (Lift Exp a, Elt (Plain a)) => Lift Exp (Kahan a) where   type Plain (Kahan a) = Kahan (Plain a)-  lift (Kahan a b)     = Exp $ Tuple $ NilTup `SnocTup` lift a-                                              `SnocTup` lift b+  lift (Kahan a b)     = Kahan_ (lift a) (lift b)  instance Elt a => Unlift Exp (Kahan (Exp a)) where-  unlift t = Kahan (Exp $ SuccTupIdx ZeroTupIdx `Prj` t)-                   (Exp $ ZeroTupIdx `Prj` t)+  unlift (Kahan_ a b) = Kahan a b 

@@ -3,10 +3,10 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | -- Module      : Data.Array.Accelerate.Numeric.Sum.Arithmetic--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -18,6 +18,7 @@ ) where  import Data.Array.Accelerate+import Data.Array.Accelerate.Type  import qualified Data.Array.Accelerate.Numeric.Sum.LLVM.Native      as Native import qualified Data.Array.Accelerate.Numeric.Sum.LLVM.PTX         as PTX

@@ -1,10 +1,12 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.Numeric.Sum.LLVM.Native--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -16,6 +18,7 @@ ) where  import Data.Array.Accelerate                                        as A+import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Type  #ifdef ACCELERATE_LLVM_NATIVE_BACKEND@@ -27,7 +30,7 @@ #ifdef ACCELERATE_LLVM_NATIVE_BACKEND wrap2 :: (Elt a, Elt b, Elt c)       => String                                       -- name of the operation-      -> IRFun1 Native () ((a, b) -> c)               -- foreign implementation+      -> IRFun1 Native () (EltR (a, b) -> EltR c)     -- foreign implementation       -> (Exp a -> Exp b -> Exp c)                    -- fallback implementation       -> Exp a       -> Exp b@@ -35,23 +38,23 @@ wrap2 str f g = A.curry (foreignExp (ForeignExp str f) (A.uncurry g)) #endif -fadd :: (IsFloating a, Elt a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a+fadd :: forall a. (Elt a, IsFloating a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a #ifdef ACCELERATE_LLVM_NATIVE_BACKEND-fadd = wrap2 "fadd" (Prim.fadd floatingType)+fadd = wrap2 "fadd" (Prim.fadd (floatingType @a)) #else fadd = id #endif -fsub :: (IsFloating a, Elt a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a+fsub :: forall a. (Elt a, IsFloating a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a #ifdef ACCELERATE_LLVM_NATIVE_BACKEND-fsub = wrap2 "fsub" (Prim.fsub floatingType)+fsub = wrap2 "fsub" (Prim.fsub (floatingType @a)) #else fsub = id #endif -fmul :: (IsFloating a, Elt a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a+fmul :: forall a. (Elt a, IsFloating a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a #ifdef ACCELERATE_LLVM_NATIVE_BACKEND-fmul = wrap2 "fmul" (Prim.fmul floatingType)+fmul = wrap2 "fmul" (Prim.fmul (floatingType @a)) #else fmul = id #endif

@@ -1,10 +1,12 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.Numeric.Sum.LLVM.PTX--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -17,6 +19,7 @@  import Data.Array.Accelerate                                        as A import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Sugar.Elt  #ifdef ACCELERATE_LLVM_PTX_BACKEND import Data.Array.Accelerate.LLVM.CodeGen.Sugar@@ -27,7 +30,7 @@ #ifdef ACCELERATE_LLVM_PTX_BACKEND wrap2 :: (Elt a, Elt b, Elt c)       => String                                       -- name of the operation-      -> IRFun1 PTX () ((a, b) -> c)                  -- foreign implementation+      -> IRFun1 PTX () (EltR (a, b) -> EltR c)        -- foreign implementation       -> (Exp a -> Exp b -> Exp c)                    -- fallback implementation       -> Exp a       -> Exp b@@ -35,23 +38,23 @@ wrap2 str f g = A.curry (foreignExp (ForeignExp str f) (A.uncurry g)) #endif -fadd :: (IsFloating a, Elt a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a+fadd :: forall a. (Elt a, IsFloating a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a #ifdef ACCELERATE_LLVM_PTX_BACKEND-fadd = wrap2 "fadd" (Prim.fadd floatingType)+fadd = wrap2 "fadd" (Prim.fadd (floatingType @a)) #else fadd = id #endif -fsub :: (IsFloating a, Elt a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a+fsub :: forall a. (Elt a, IsFloating a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a #ifdef ACCELERATE_LLVM_PTX_BACKEND-fsub = wrap2 "fsub" (Prim.fsub floatingType)+fsub = wrap2 "fsub" (Prim.fsub (floatingType @a)) #else fsub = id #endif -fmul :: (IsFloating a, Elt a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a+fmul :: forall a. (Elt a, IsFloating a) => (Exp a -> Exp a -> Exp a) -> Exp a -> Exp a -> Exp a #ifdef ACCELERATE_LLVM_PTX_BACKEND-fmul = wrap2 "fmul" (Prim.fmul floatingType)+fmul = wrap2 "fmul" (Prim.fmul (floatingType @a)) #else fmul = id #endif

@@ -1,13 +1,13 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE GADTs           #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns    #-}+{-# LANGUAGE CPP          #-}+{-# LANGUAGE GADTs        #-}+{-# LANGUAGE LambdaCase   #-}+{-# LANGUAGE ViewPatterns #-} -- | -- Module      : Data.Array.Accelerate.Numeric.Sum.LLVM.Prim--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -18,40 +18,59 @@  ) where -import Data.Array.Accelerate.Type import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Type+import Data.Array.Accelerate.Sugar.Elt -import Data.Array.Accelerate.LLVM.CodeGen.Downcast                  ( downcast )-import Data.Array.Accelerate.LLVM.CodeGen.IR                        ( IR(..), Operands(..), IROP(..) )+import Data.Array.Accelerate.LLVM.CodeGen.IR                        ( Operands(..), IROP(..) ) import Data.Array.Accelerate.LLVM.CodeGen.Monad                     ( CodeGen, freshName, instr_ ) import Data.Array.Accelerate.LLVM.CodeGen.Sugar                     ( IROpenFun1(..) )-import qualified Data.Array.Accelerate.LLVM.CodeGen.Arithmetic      as A++import LLVM.AST.Type.Downcast                                       ( downcast ) import qualified LLVM.AST.Type.Name                                 as A import qualified LLVM.AST.Type.Operand                              as A import qualified LLVM.AST.Type.Representation                       as A  import LLVM.AST.Instruction-import LLVM.AST.Name-import LLVM.AST.Operand-import LLVM.AST.Type+import LLVM.AST.Name                                                ( Name(..) )+import LLVM.AST.Operand                                             ( Operand(..) )+import LLVM.AST.Type                                                ( Type(..), FloatingPointType(..) ) +import Prelude                                                      hiding (uncurry) ++uncurry :: (Operands a -> Operands b -> c) -> Operands (((), a), b) -> c+uncurry f (OP_Unit `OP_Pair` x `OP_Pair` y) = f x y+ -- | As (+), but don't allow potentially unsafe floating-point optimisations. ---fadd :: FloatingType a -> IROpenFun1 arch env aenv ((a,a) -> a)-fadd t = IRFun1 $ A.uncurry (binop FAdd t)+fadd :: FloatingType a -> IROpenFun1 arch env aenv ((((), EltR a), EltR a) -> EltR a)+fadd = \case+  TypeHalf   -> IRFun1 $ uncurry (binop FAdd TypeHalf)    -- the pattern match yields a ~ EltR a+  TypeFloat  -> IRFun1 $ uncurry (binop FAdd TypeFloat)+  TypeDouble -> IRFun1 $ uncurry (binop FAdd TypeDouble)  -- | As (-), but don't allow potentially unsafe floating-point optimisations. ---fsub :: FloatingType a -> IROpenFun1 arch env aenv ((a,a) -> a)-fsub t = IRFun1 $ A.uncurry (binop FSub t)+fsub :: FloatingType a -> IROpenFun1 arch env aenv ((((), EltR a), EltR a) -> EltR a)+fsub = \case+  TypeHalf   -> IRFun1 $ uncurry (binop FSub TypeHalf)+  TypeFloat  -> IRFun1 $ uncurry (binop FSub TypeFloat)+  TypeDouble -> IRFun1 $ uncurry (binop FSub TypeDouble)  -- | As (*), but don't allow potentially unsafe floating-point optimisations. ---fmul :: FloatingType a -> IROpenFun1 arch env aenv ((a,a) -> a)-fmul t = IRFun1 $ A.uncurry (binop FMul t)+fmul :: FloatingType a -> IROpenFun1 arch env aenv ((((), EltR a), EltR a) -> EltR a)+fmul = \case+  TypeHalf   -> IRFun1 $ uncurry (binop FMul TypeHalf)+  TypeFloat  -> IRFun1 $ uncurry (binop FMul TypeFloat)+  TypeDouble -> IRFun1 $ uncurry (binop FMul TypeDouble) -binop :: (FastMathFlags -> Operand -> Operand -> InstructionMetadata -> Instruction) -> FloatingType a -> IR a -> IR a -> CodeGen (IR a)+binop :: (FastMathFlags -> Operand -> Operand -> InstructionMetadata -> Instruction)+      -> FloatingType a+      -> Operands a+      -> Operands a+      -> CodeGen arch (Operands a) binop f t (op t -> x) (op t -> y) = do   r <- instr (downcast t) (f fmf (downcast x) (downcast y) md)   return (upcast t r)@@ -64,25 +83,20 @@ md = []  fmf :: FastMathFlags-#if MIN_VERSION_llvm_hs_pure(6,0,0) fmf = noFastMathFlags-#else-fmf = NoFastMathFlags-#endif -fresh :: CodeGen Name+fresh :: CodeGen arch Name fresh = downcast <$> freshName -instr :: Type -> Instruction -> CodeGen Operand+instr :: Type -> Instruction -> CodeGen arch Operand instr ty ins = do   name <- fresh   instr_ (name := ins)   return (LocalReference ty name) -upcast :: FloatingType t -> Operand -> IR t-upcast TypeFloat{}   (LocalReference (FloatingPointType FloatFP)  (UnName x)) = IR $ OP_Float   (A.LocalReference A.type' (A.UnName x))-upcast TypeDouble{}  (LocalReference (FloatingPointType DoubleFP) (UnName x)) = IR $ OP_Double  (A.LocalReference A.type' (A.UnName x))-upcast TypeCFloat{}  (LocalReference (FloatingPointType FloatFP)  (UnName x)) = IR $ OP_CFloat  (A.LocalReference A.type' (A.UnName x))-upcast TypeCDouble{} (LocalReference (FloatingPointType DoubleFP) (UnName x)) = IR $ OP_CDouble (A.LocalReference A.type' (A.UnName x))-upcast _ _ = $internalError "upcast" "expected local reference"+upcast :: FloatingType t -> Operand -> Operands t+upcast TypeHalf{}    (LocalReference (FloatingPointType HalfFP)   (UnName x)) = OP_Half    (A.LocalReference A.type' (A.UnName x))+upcast TypeFloat{}   (LocalReference (FloatingPointType FloatFP)  (UnName x)) = OP_Float   (A.LocalReference A.type' (A.UnName x))+upcast TypeDouble{}  (LocalReference (FloatingPointType DoubleFP) (UnName x)) = OP_Double  (A.LocalReference A.type' (A.UnName x))+upcast _ _ = internalError "upcast" "expected local reference" 

@@ -6,10 +6,10 @@ {-# LANGUAGE ViewPatterns        #-} -- | -- Module      : Test.BLAS--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --

@@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module      : Test.BLAS.Level2--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -29,7 +29,7 @@   test_gemv-    :: (Numeric e, Similar e)+    :: (Show e, Numeric e, Similar e)     => Run     -> Range Int     -> Gen e

@@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module      : Test.BLAS.Level3--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --@@ -29,7 +29,7 @@   test_gemm-    :: (Numeric e, Similar e)+    :: (Show e, Numeric e, Similar e)     => Run     -> Range Int     -> Gen e

@@ -6,19 +6,20 @@ {-# LANGUAGE ViewPatterns        #-} -- | -- Module      : Test.Util--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --  module Test.Util where -import Data.Array.Accelerate                                        ( Acc, Arrays, Array, Shape, Elt, fromList )-import Data.Array.Accelerate.Array.Sugar                            ( size )-import Data.Array.Accelerate.Trafo                                  ( Afunction, AfunctionR )+import Data.Array.Accelerate                                        ( Acc, Arrays, Array, Elt, fromList )+import Data.Array.Accelerate.Trafo                                  ( Afunction )+import Data.Array.Accelerate.Trafo.Sharing                          ( AfunctionR )+import Data.Array.Accelerate.Sugar.Shape import Data.Array.Accelerate.Data.Complex  import Hedgehog

@@ -1,9 +1,9 @@ -- | -- Module      : TestNative--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --

@@ -1,9 +1,9 @@ -- | -- Module      : TestPTX--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] Trevor L. McDonell -- License     : BSD3 ----- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com> -- Stability   : experimental -- Portability : non-portable (GHC extensions) --