accelerate-llvm-native 1.2.0.1 → 1.3.0.0

raw patch · 46 files changed

+3250/−3273 lines, 46 filesdep +deepseqdep −Cabaldep −timedep ~acceleratedep ~accelerate-llvmdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependencies removed: Cabal, time

Dependency ranges changed: accelerate, accelerate-llvm, base, bytestring, llvm-hs, llvm-hs-pure

API changes (from Hackage documentation)

Files

• CHANGELOG.md +38/−29
• LICENSE +1/−1
• README.md +31/−22
• accelerate-llvm-native.cabal +24/−48
• src/Data/Array/Accelerate/LLVM/Native.hs +105/−119
• src/Data/Array/Accelerate/LLVM/Native/Array/Data.hs +32/−62
• src/Data/Array/Accelerate/LLVM/Native/CodeGen.hs +14/−16
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/Base.hs +20/−18
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/Fold.hs +135/−156
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/FoldSeg.hs +66/−103
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/Generate.hs +16/−17
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/Loop.hs +131/−17
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/Map.hs +25/−19
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/Permute.hs +117/−111
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/Scan.hs +397/−516
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/Stencil.hs +217/−0
• src/Data/Array/Accelerate/LLVM/Native/CodeGen/Transform.hs +63/−0
• src/Data/Array/Accelerate/LLVM/Native/Compile.hs +19/−18
• src/Data/Array/Accelerate/LLVM/Native/Compile/Cache.hs +2/−2
• src/Data/Array/Accelerate/LLVM/Native/Compile/Optimise.hs +2/−3
• src/Data/Array/Accelerate/LLVM/Native/Debug.hs +2/−3
• src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple.hs +0/−65
• src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/Build.hs +0/−467
• src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC.hs +0/−458
• src/Data/Array/Accelerate/LLVM/Native/Distribution/Simple/GHC/Internal.hs +0/−126
• src/Data/Array/Accelerate/LLVM/Native/Embed.hs +31/−11
• src/Data/Array/Accelerate/LLVM/Native/Execute.hs +1016/−515
• src/Data/Array/Accelerate/LLVM/Native/Execute/Async.hs +138/−26
• src/Data/Array/Accelerate/LLVM/Native/Execute/Divide.hs +178/−0
• src/Data/Array/Accelerate/LLVM/Native/Execute/Environment.hs +5/−6
• src/Data/Array/Accelerate/LLVM/Native/Execute/LBS.hs +0/−34
• src/Data/Array/Accelerate/LLVM/Native/Execute/Marshal.hs +13/−82
• src/Data/Array/Accelerate/LLVM/Native/Execute/Scheduler.hs +258/−0
• src/Data/Array/Accelerate/LLVM/Native/Foreign.hs +16/−12
• src/Data/Array/Accelerate/LLVM/Native/Link.hs +3/−3
• src/Data/Array/Accelerate/LLVM/Native/Link/COFF.hs +2/−2
• src/Data/Array/Accelerate/LLVM/Native/Link/Cache.hs +2/−2
• src/Data/Array/Accelerate/LLVM/Native/Link/ELF.chs +62/−75
• src/Data/Array/Accelerate/LLVM/Native/Link/MachO.chs +12/−23
• src/Data/Array/Accelerate/LLVM/Native/Link/Object.hs +2/−2
• src/Data/Array/Accelerate/LLVM/Native/Plugin.hs +19/−22
• src/Data/Array/Accelerate/LLVM/Native/Plugin/Annotation.hs +2/−2
• src/Data/Array/Accelerate/LLVM/Native/Plugin/BuildInfo.hs +5/−12
• src/Data/Array/Accelerate/LLVM/Native/State.hs +18/−33
• src/Data/Array/Accelerate/LLVM/Native/Target.hs +9/−13
• test/nofib/Main.hs +2/−2

@@ -6,69 +6,78 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) -## [1.2.0.1] - 2019-04-29-### Added- * support for GHC-8.6- * support for LLVM-7- * support for LLVM-8+## [1.3.0.0] - 2018-08-27+### Changed+  * Switch the thread scheduler to static, rather than dynamic, work stealing+  * Thread scheduler is no longer block-synchronous+  * Code generation improvements, in particular for >=2-dimensional operations +### Fixed+  * Stability improvements+  * Race condition in thread scheduler ([accelerate-llvm#49])+  ### Contributors  Special thanks to those who contributed patches as part of this release: - * Trevor L. McDonell (@tmcdonell)- * Viktor Kronvall (@considerate)+  * Trevor L. McDonell (@tmcdonell)+  * Josh Meredith (@JoshMeredith)+  * Ivo Gabe de Wolff (@ivogabe)+  * Lars van den Haak (@sakehl)+  * Joshua Meredith (@JoshMeredith)+   ## [1.2.0.0] - 2018-04-03 ### Fixed- * LLVM native throws "SIGSEGV: invalid address" due to fused FP operation ([#409])+  * LLVM native throws "SIGSEGV: invalid address" due to fused FP operation ([#409])  ### Added- * support for half-precision floats- * support for struct-of-array-of-struct representations- * support for LLVM-6.0- * support for GHC-8.4+  * support for half-precision floats+  * support for struct-of-array-of-struct representations+  * support for LLVM-6.0+  * support for GHC-8.4  ### Contributors  Special thanks to those who contributed patches as part of this release: - * Trevor L. McDonell (@tmcdonell)- * @samft- * Ryan Scott (@ryanglscott)- * Jesse Sigal (@jasigal)- * Moritz Kiefer (@cocreature)+  * Trevor L. McDonell (@tmcdonell)+  * @samft+  * Ryan Scott (@ryanglscott)+  * Jesse Sigal (@jasigal)+  * Moritz Kiefer (@cocreature)   ## [1.1.0.1] - 2017-10-04 ### Fixed- * fix for `runQ*` generating multiple declarations with the same name+  * fix for `runQ*` generating multiple declarations with the same name   ## [1.1.0.0] - 2017-09-21 ### Added- * support for GHC-8.2- * caching of compilation results ([accelerate-llvm#17])- * new runtime linker; this fixes the annoying "forkOS_entry: interrupted" error. Note that currently this only supports x86_64 macOS and linux- * support for ahead-of-time compilation (`runQ` and `runQAsync`)+  * support for GHC-8.2+  * caching of compilation results ([accelerate-llvm#17])+  * new runtime linker; this fixes the annoying "forkOS_entry: interrupted" error. Note that currently this only supports x86_64 macOS and linux+  * support for ahead-of-time compilation (`runQ` and `runQAsync`)  ### Changed- * generalise `run1*` to polyvariadic `runN*`- * programs run using all cores by default; the environment variable-   `ACCELERATE_LLVM_NATIVE_THREADS` is used to set the number of worker threads-   rather than `+RTS -N`+  * generalise `run1*` to polyvariadic `runN*`+  * programs run using all cores by default; the environment variable+    `ACCELERATE_LLVM_NATIVE_THREADS` is used to set the number of worker threads+    rather than `+RTS -N`   ## [1.0.0.0] - 2017-03-31- * initial release+  * initial release  -[1.2.0.1]:              https://github.com/AccelerateHS/accelerate-llvm/compare/v1.2.0.0...v1.2.0.1-[1.2.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-native...v1.2.0.0+[1.3.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.2.0.0...v1.3.0.0+[1.2.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.1-native...1.2.0.0 [1.1.0.1]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.1.0.0...1.1.0.1-native [1.1.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.1.0.0 [1.0.0.0]:              https://github.com/AccelerateHS/accelerate-llvm/compare/be7f91295f77434b2103c70aa1cabb6a4f2b09a8...1.0.0.0  [#409]:                 https://github.com/AccelerateHS/accelerate/issues/409 [accelerate-llvm#17]:   https://github.com/AccelerateHS/accelerate-llvm/issues/17+[accelerate-llvm#49]:   https://github.com/AccelerateHS/accelerate-llvm/pull/49 

@@ -1,4 +1,4 @@-Copyright (c) [2014..2017] The Accelerate Team.  All rights reserved.+Copyright (c) [2014..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:

@@ -1,14 +1,20 @@-An LLVM backend for the Accelerate Array Language-=================================================+<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"/> -[![Travis](https://img.shields.io/travis/AccelerateHS/accelerate-llvm/master.svg?label=linux)](https://travis-ci.org/AccelerateHS/accelerate-llvm)-[![AppVeyor](https://img.shields.io/appveyor/ci/tmcdonell/accelerate-llvm/master.svg?label=windows)](https://ci.appveyor.com/project/tmcdonell/accelerate-llvm)+# LLVM backends for the Accelerate array language++[![GitHub CI](https://github.com/tmcdonell/accelerate-llvm/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate-llvm/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-llvm/badge/lts)](https://stackage.org/lts/package/accelerate-llvm) [![Stackage Nightly](https://stackage.org/package/accelerate-llvm/badge/nightly)](https://stackage.org/nightly/package/accelerate-llvm) [![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm)+<br> [![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) [![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm) +</div>+ This package compiles Accelerate code to LLVM IR, and executes that code on multicore CPUs as well as NVIDIA GPUs. This avoids the need to go through `nvcc` or `clang`. For details on Accelerate, refer to the [main repository][GitHub].@@ -67,7 +73,7 @@ Example using [Homebrew](http://brew.sh) on macOS:  ```sh-$ brew install llvm-hs/llvm/llvm-8+$ brew install llvm-hs/llvm/llvm-9 ```  ## Debian/Ubuntu@@ -78,17 +84,17 @@ then:  ```sh-$ apt-get install llvm-8-dev+$ apt-get install llvm-9-dev ```  ## Building from source  If your OS does not have an appropriate LLVM distribution available, you can also build from source. Detailed build instructions are available on the [LLVM.org website](http://releases.llvm.org/6.0.0/docs/CMake.html). Note that you will require at least [CMake 3.4.3](http://www.cmake.org/cmake/resources/software.html) and a recent C++ compiler; at least Clang 3.1, GCC 4.8, or Visual Studio 2015 (update 3). -  1. Download and unpack the [LLVM-8.0 source code](http://releases.llvm.org/8.0.0/llvm-8.0.0.src.tar.xz). We'll refer to+  1. Download and unpack the [LLVM-9 source code](https://github.com/llvm/llvm-project/releases/download/llvmorg-9.0.1/llvm-9.0.1.src.tar.xz). We'll refer to      the path that the source tree was unpacked to as `LLVM_SRC`. Only the main      LLVM source tree is required, but you can optionally add other components-     such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#8.0.0)+     such as the Clang compiler or Polly loop optimiser. See the [LLVM releases](http://releases.llvm.org/download.html#9.0.1)      page for the complete list.    2. Create a temporary build directory and `cd` into it, for example:@@ -116,7 +122,7 @@      to [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection):      ```sh      cd $INSTALL_PREFIX/lib-     ln -s libLLVM.dylib libLLVM-8.0.dylib+     ln -s libLLVM.dylib libLLVM-9.dylib      install_name_tool -id $PWD/libLTO.dylib libLTO.dylib      install_name_tool -id $PWD/libLLVM.dylib libLLVM.dylib      install_name_tool -change '@rpath/libLLVM.dylib' $PWD/libLLVM.dylib libLTO.dylib@@ -131,13 +137,13 @@ For example, installation using [`stack`](http://docs.haskellstack.org/en/stable/README.html) just requires you to point it to the appropriate configuration file: ```sh-$ ln -s stack-8.6.yaml stack.yaml+$ ln -s stack-8.8.yaml stack.yaml $ stack setup $ stack install ```  Note that the version of [`llvm-hs`](https://hackage.haskell.org/package/llvm-hs)-used must match the installed version of LLVM, which is currently 8.0.+used must match the installed version of LLVM, which is currently 9.0.   ## libNVVM@@ -153,20 +159,23 @@ is also based on LLVM, and typically lags LLVM by several releases, you must install `accelerate-llvm` with a "compatible" version of LLVM, which will depend on the version of the CUDA toolkit you have installed. The following table shows-some combinations:+combinations which have been tested: -|               | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | LLVM-5.0 | LLVM-6.0 | LLVM-7.0 | LLVM-8.0 |-|:-------------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|:--------:|-| **CUDA-7.0**  |     ⭕    |     ❌    |          |          |          |          |          |          |          |          |-| **CUDA-7.5**  |          |     ⭕    |     ⭕    |     ❌    |          |          |          |          |          |          |-| **CUDA-8.0**  |          |          |     ⭕    |     ⭕    |     ❌    |     ❌    |          |          |          |          |-| **CUDA-9.0**  |          |          |          |          |          |     ❌    |     ❌    |          |          |          |-| **CUDA-9.1**  |          |          |          |          |          |          |          |          |          |          |-| **CUDA-9.2**  |          |          |          |          |          |          |          |          |          |          |-| **CUDA-10.0** |          |          |          |          |          |          |          |          |          |          |-| **CUDA-10.1** |          |          |          |          |          |          |          |          |          |          |+|               | LLVM-3.3 | LLVM-3.4 | LLVM-3.5 | LLVM-3.8 | LLVM-3.9 | LLVM-4.0 | LLVM-5.0 | LLVM-6.0 | LLVM-7 | LLVM-8 | LLVM-9 |+| ------------- | :------: | :------: | :------: | :------: | :------: | :------: | :------: | :------: | :----: | :----: | :----: |+| **CUDA-7.0**  | ⭕       | ❌       |          |          |          |          |          |          |        |        |        |+| **CUDA-7.5**  |          | ⭕       | ⭕       | ❌       |          |          |          |          |        |        |        |+| **CUDA-8.0**  |          |          | ⭕       | ⭕       | ❌       | ❌       |          |          |        |        |        |+| **CUDA-9.0**  |          |          |          |          |          | ❌       | ❌       |          |        |        |        |+| **CUDA-9.1**  |          |          |          |          |          |          |          |          |        |        |        |+| **CUDA-9.2**  |          |          |          |          |          |          |          |          |        |        |        |+| **CUDA-10.0** |          |          |          |          |          |          |          |          |        |        |        |+| **CUDA-10.1** |          |          |          |          |          |          |          |          |        |        |        |  Where ⭕ = Works, and ❌ = Does not work.++The above table is incomplete! If you try a particular combination and find that+it does or does not work, please let us know!  Note that the above restrictions on CUDA and LLVM version exist _only_ if you want to use the NVVM component. Otherwise, you should be free to use any

@@ -1,7 +1,7 @@ name:                   accelerate-llvm-native-version:                1.2.0.1+version:                1.3.0.0 cabal-version:          >= 1.10-tested-with:            GHC >= 8.0+tested-with:            GHC >= 8.6 build-type:             Simple  synopsis:               Accelerate backend for multicore CPUs@@ -26,7 +26,7 @@     .     Example using Homebrew on macOS:     .-    > brew install llvm-hs/llvm/llvm-8+    > brew install llvm-hs/llvm/llvm-9     .     /Debian & Ubuntu/     .@@ -35,40 +35,24 @@     instructions for adding the correct package database for your OS version,     and then:     .-    > apt-get install llvm-8-dev+    > apt-get install llvm-9-dev     .     /Building from source/     .     If your OS does not have an appropriate LLVM distribution available, you can     also build from source. Detailed build instructions are available on-    <http://releases.llvm.org/8.0.0/docs/CMake.html LLVM.org>. Make sure to+    <http://releases.llvm.org/9.0.0/docs/CMake.html LLVM.org>. Make sure to     include the cmake build options     @-DLLVM_BUILD_LLVM_DYLIB=ON -DLLVM_LINK_LLVM_DYLIB=ON@ so that the @libLLVM@     shared library will be built.     .-    [/Installing accelerate-llvm/]-    .-    To use @accelerate-llvm@ it is important that the @llvm-hs@ package is-    installed against the @libLLVM@ shared library, rather than statically-    linked, so that we can use LLVM from GHCi and Template Haskell. This is the-    default configuration, but you can also enforce this explicitly by adding-    the following to your @stack.yaml@ file:-    .-    > flags:-    >   llvm-hs:-    >     shared-llvm: true-    .-    Or by specifying the @shared-llvm@ flag to cabal:-    .-    > cabal install llvm-hs -fshared-llvm-    .  license:                BSD3 license-file:           LICENSE author:                 Trevor L. McDonell-maintainer:             Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+maintainer:             Trevor L. McDonell <trevor.mcdonell@gmail.com> bug-reports:            https://github.com/AccelerateHS/accelerate/issues-category:               Compilers/Interpreters, Concurrency, Data, Parallelism+category:               Accelerate, Compilers/Interpreters, Concurrency, Data, Parallelism  extra-source-files:     CHANGELOG.md@@ -83,7 +67,6 @@     Data.Array.Accelerate.LLVM.Native     Data.Array.Accelerate.LLVM.Native.Plugin     Data.Array.Accelerate.LLVM.Native.Foreign-    Data.Array.Accelerate.LLVM.Native.Distribution.Simple    other-modules:     Data.Array.Accelerate.LLVM.Native.Array.Data@@ -100,6 +83,8 @@     Data.Array.Accelerate.LLVM.Native.CodeGen.Map     Data.Array.Accelerate.LLVM.Native.CodeGen.Permute     Data.Array.Accelerate.LLVM.Native.CodeGen.Scan+    Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil+    Data.Array.Accelerate.LLVM.Native.CodeGen.Transform      Data.Array.Accelerate.LLVM.Native.Compile     Data.Array.Accelerate.LLVM.Native.Compile.Cache@@ -113,40 +98,37 @@      Data.Array.Accelerate.LLVM.Native.Execute     Data.Array.Accelerate.LLVM.Native.Execute.Async+    Data.Array.Accelerate.LLVM.Native.Execute.Divide     Data.Array.Accelerate.LLVM.Native.Execute.Environment-    Data.Array.Accelerate.LLVM.Native.Execute.LBS     Data.Array.Accelerate.LLVM.Native.Execute.Marshal+    Data.Array.Accelerate.LLVM.Native.Execute.Scheduler      Data.Array.Accelerate.LLVM.Native.Plugin.Annotation     Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo -    Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build-    Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC-    Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal-     Paths_accelerate_llvm_native    build-depends:-          base                          >= 4.7 && < 4.13-        , accelerate                    == 1.2.*-        , accelerate-llvm               == 1.2.*+          base                          >= 4.10 && < 5+        , accelerate                    == 1.3.*+        , accelerate-llvm               == 1.3.*         , bytestring                    >= 0.10.4-        , Cabal                         >= 2.0         , cereal                        >= 0.4         , containers                    >= 0.5 && < 0.7+        , deepseq                       >= 1.4         , directory                     >= 1.0         , dlist                         >= 0.6         , filepath                      >= 1.0         , ghc         , hashable                      >= 1.0         , libffi                        >= 0.1-        , llvm-hs                       >= 4.1 && < 8.1-        , llvm-hs-pure                  >= 4.1 && < 8.1+        , llvm-hs                       >= 4.1 && < 9.1+        , llvm-hs-pure                  >= 4.1 && < 9.1         , lockfree-queue                >= 0.2         , mtl                           >= 2.2.1         , template-haskell-        , time                          >= 1.4         , unique+        , vector                        >= 0.11    hs-source-dirs:         src@@ -172,11 +154,8 @@       Data.Array.Accelerate.LLVM.Native.Link.MachO      build-depends:-          bytestring                    >= 0.10-        , cereal                        >= 0.4-        , ghc-prim+          ghc-prim         , unix                          >= 2.7-        , vector                        >= 0.11      build-tools:           c2hs                          >= 0.25@@ -186,11 +165,8 @@       Data.Array.Accelerate.LLVM.Native.Link.ELF      build-depends:-          bytestring                    >= 0.10-        , cereal                        >= 0.4-        , ghc-prim+          ghc-prim         , unix                          >= 2.7-        , vector                        >= 0.11      build-tools:           c2hs                          >= 0.25@@ -199,8 +175,7 @@     other-modules:       Data.Array.Accelerate.LLVM.Native.Link.COFF -    build-depends:-          bytestring                    >= 0.10+    -- build-depends:   test-suite nofib-llvm-native@@ -209,7 +184,7 @@   main-is:              Main.hs    build-depends:-          base                          >= 4.7+          base                          >= 4.10         , accelerate         , accelerate-llvm-native @@ -223,6 +198,7 @@         -rtsopts         -with-rtsopts=-A128M         -with-rtsopts=-n4M+        -with-rtsopts=-N   source-repository head@@ -231,7 +207,7 @@  source-repository this   type:                 git-  tag:                  v1.2.0.1+  tag:                  v1.3.0.0   location:             https://github.com/AccelerateHS/accelerate-llvm.git  -- vim: nospell

@@ -1,16 +1,19 @@ {-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE CPP                  #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE GADTs                #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeApplications     #-} {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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) --@@ -49,34 +52,32 @@   runQAsync, runQAsyncWith,    -- * Execution targets-  Native, Strategy,-  createTarget, balancedParIO, unbalancedParIO,+  Native,+  createTarget,  ) where --- accelerate-import Data.Array.Accelerate.Array.Sugar                            ( Arrays )-import Data.Array.Accelerate.AST                                    ( PreOpenAfun(..) )-import Data.Array.Accelerate.Async+import Data.Array.Accelerate.AST                                    ( PreOpenAfun(..), arraysR, liftALeftHandSide )+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.Async                                  ( Async, async, wait, poll, cancel )+import Data.Array.Accelerate.Representation.Array                   ( liftArraysR ) import Data.Array.Accelerate.Smart                                  ( Acc )+import Data.Array.Accelerate.Sugar.Array                            ( Arrays, toArr, fromArr, ArraysR ) import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Trafo.Sharing                          ( Afunction(..), AfunctionRepr(..), afunctionRepr )+import qualified Data.Array.Accelerate.Sugar.Array                  as Sugar -import Data.Array.Accelerate.LLVM.Execute.Async                     ( AsyncR(..) )-import Data.Array.Accelerate.LLVM.Execute.Environment               ( AvalR(..) ) import Data.Array.Accelerate.LLVM.Native.Array.Data                 ( useRemoteAsync ) import Data.Array.Accelerate.LLVM.Native.Compile                    ( CompiledOpenAfun, compileAcc, compileAfun ) import Data.Array.Accelerate.LLVM.Native.Embed                      ( embedOpenAcc ) import Data.Array.Accelerate.LLVM.Native.Execute                    ( executeAcc, executeOpenAcc )-import Data.Array.Accelerate.LLVM.Native.Execute.Environment        ( Aval )+import Data.Array.Accelerate.LLVM.Native.Execute.Async              ( Par, evalPar, getArrays )+import Data.Array.Accelerate.LLVM.Native.Execute.Environment        ( Val, ValR(..), push ) import Data.Array.Accelerate.LLVM.Native.Link                       ( ExecOpenAfun, linkAcc, linkAfun ) import Data.Array.Accelerate.LLVM.Native.State import Data.Array.Accelerate.LLVM.Native.Target-import Data.Array.Accelerate.LLVM.State                             ( LLVM ) import Data.Array.Accelerate.LLVM.Native.Debug                      as Debug-import qualified Data.Array.Accelerate.LLVM.Native.Execute.Async    as E --- standard library-import Data.Typeable import Control.Monad.Trans import System.IO.Unsafe import Text.Printf@@ -97,8 +98,7 @@ -- | As 'run', but execute using the specified target (thread gang). -- runWith :: Arrays a => Native -> Acc a -> a-runWith target a = unsafePerformIO (run' target a)-+runWith target a = unsafePerformIO (runWithIO target a)  -- | As 'run', but allow the computation to run asynchronously and return -- immediately without waiting for the result. The status of the computation can@@ -110,19 +110,19 @@ -- | As 'runAsync', but execute using the specified target (thread gang). -- runAsyncWith :: Arrays a => Native -> Acc a -> IO (Async a)-runAsyncWith target a = async (run' target a)+runAsyncWith target a = async (runWithIO target a) -run' :: Arrays a => Native -> Acc a -> IO a-run' target a = execute+runWithIO :: Arrays a => Native -> Acc a -> IO a+runWithIO target a = execute   where-    !acc        = convertAccWith (config target) a-    execute     = do+    !acc    = convertAcc a+    execute = do       dumpGraph acc       evalNative target $ do         build <- phase "compile" elapsedS (compileAcc acc) >>= dumpStats         exec  <- phase "link"    elapsedS (linkAcc build)-        res   <- phase "execute" elapsedP (executeAcc exec)-        return res+        res   <- phase "execute" elapsedP (evalPar (executeAcc exec >>= getArrays (arraysR exec)))+        return $ toArr res   -- | This is 'runN', specialised to an array program of one argument.@@ -182,27 +182,32 @@  -- | As 'runN', but execute using the specified target (thread gang). ---runNWith :: Afunction f => Native -> f -> AfunctionR f-runNWith target f = exec+runNWith :: forall f. Afunction f => Native -> f -> AfunctionR f+runNWith target f = go (afunctionRepr @f) afun (return Empty)   where-    !acc  = convertAfunWith (config target) f+    !acc  = convertAfun f     !afun = unsafePerformIO $ do               dumpGraph acc               evalNative target $ do                 build <- phase "compile" elapsedS (compileAfun acc) >>= dumpStats                 link  <- phase "link"    elapsedS (linkAfun build)                 return link-    !exec = go afun (return Aempty) -    go :: ExecOpenAfun Native aenv t -> LLVM Native (Aval aenv) -> t-    go (Alam l) k = \arrs ->-      let k' = do aenv       <- k-                  AsyncR _ a <- E.async (useRemoteAsync arrs)-                  return (aenv `Apush` a)-      in go l k'-    go (Abody b) k = unsafePerformIO . phase "execute" elapsedP . evalNative target $ do-      aenv   <- k-      E.get =<< E.async (executeOpenAcc b aenv)+    go :: AfunctionRepr t (AfunctionR t) (ArraysFunctionR t)+       -> ExecOpenAfun Native aenv (ArraysFunctionR t)+       -> Par Native (Val aenv)+       -> AfunctionR t+    go (AfunctionReprLam repr) (Alam lhs l) k = \(arrs :: a) ->+      let k' = do aenv  <- k+                  a     <- useRemoteAsync (Sugar.arraysR @a) $ fromArr arrs+                  return (aenv `push` (lhs, a))+      in go repr l k'+    go AfunctionReprBody (Abody b) k = unsafePerformIO . phase "execute" elapsedP . evalNative target . evalPar $ do+      aenv <- k+      res  <- executeOpenAcc b aenv+      arrs <- getArrays (arraysR b) res+      return $ toArr arrs+    go _ _ _ = error "The moon is hanging upside down"   -- | As 'run1', but execute asynchronously.@@ -218,41 +223,44 @@  -- | As 'runN', but execute asynchronously. ---runNAsync :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => f -> r+runNAsync :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => f -> r runNAsync = runNAsyncWith defaultTarget  -- | As 'runNWith', but execute asynchronously. ---runNAsyncWith :: (Afunction f, RunAsync r, AfunctionR f ~ RunAsyncR r) => Native -> f -> r-runNAsyncWith target f = runAsync' target afun (return Aempty)+runNAsyncWith :: (Afunction f, RunAsync r, ArraysFunctionR f ~ RunAsyncR r) => Native -> f -> r+runNAsyncWith target f = exec   where-    !acc  = convertAfunWith (config target) f+    !acc  = convertAfun f     !afun = unsafePerformIO $ do               dumpGraph acc               evalNative target $ do                 build <- phase "compile" elapsedS (compileAfun acc) >>= dumpStats                 link  <- phase "link"    elapsedS (linkAfun build)                 return link+    !exec = runAsync' target afun (return Empty)  class RunAsync f where   type RunAsyncR f-  runAsync' :: Native -> ExecOpenAfun Native aenv (RunAsyncR f) -> LLVM Native (Aval aenv) -> f+  runAsync' :: Native -> ExecOpenAfun Native aenv (RunAsyncR f) -> Par Native (Val aenv) -> f -instance RunAsync b => RunAsync (a -> b) where-  type RunAsyncR (a -> b) = a -> RunAsyncR b+instance (Arrays a, RunAsync b) => RunAsync (a -> b) where+  type RunAsyncR (a -> b) = ArraysR a -> RunAsyncR b   runAsync' _      Abody{}  _ _    = error "runAsync: function oversaturated"-  runAsync' target (Alam l) k arrs =-    let k' = do aenv       <- k-                AsyncR _ a <- E.async (useRemoteAsync arrs)-                return (aenv `Apush` a)+  runAsync' target (Alam lhs l) k arrs =+    let k' = do aenv  <- k+                a     <- useRemoteAsync (Sugar.arraysR @a) $ fromArr arrs+                return (aenv `push` (lhs, a))     in runAsync' target l k' -instance RunAsync (IO (Async b)) where-  type RunAsyncR  (IO (Async b)) = b+instance Arrays b => RunAsync (IO (Async b)) where+  type RunAsyncR  (IO (Async b)) = ArraysR b   runAsync' _      Alam{}    _ = error "runAsync: function not fully applied"-  runAsync' target (Abody b) k = async . phase "execute" elapsedP . evalNative target $ do-    aenv   <- k-    E.get =<< E.async (executeOpenAcc b aenv)+  runAsync' target (Abody b) k = async . phase "execute" elapsedP . evalNative target . evalPar $ do+    aenv  <- k+    ans   <- executeOpenAcc b aenv+    arrs  <- getArrays (arraysR b) ans+    return $ toArr arrs   -- | Stream a lazily read list of input arrays through the given program,@@ -299,38 +307,17 @@ -- Note that at the splice point the usage of @f@ must monomorphic; i.e. the -- types @a@, @b@ and @c@ must be at some known concrete type. ----- In order to link the final program together, the included GHC plugin must be--- used when compiling and linking the program. Add the following option to the--- .cabal file of your project:------ > ghc-options: -fplugin=Data.Array.Accelerate.LLVM.Native.Plugin------ Similarly, the plugin must also run when loading modules in @ghci@.------ Additionally, when building a _library_ with Cabal which utilises 'runQ', you--- will need to use the following custom build @Setup.hs@ to ensure that the--- library is linked together properly:------ > import Data.Array.Accelerate.LLVM.Native.Distribution.Simple--- > main = defaultMain------ And in the .cabal file:------ > build-type: Custom--- > custom-setup--- >   setup-depends:--- >       base--- >     , Cabal--- >     , accelerate-llvm-native------ The custom @Setup.hs@ is only required when building a library with Cabal.--- Building executables with cabal requires only the GHC plugin.--- -- See the <https://github.com/tmcdonell/lulesh-accelerate lulesh-accelerate> -- project for an example. -- -- [/Note:/] --+-- It is recommended to use GHC-8.6 or later. Earlier GHC versions can+-- successfully build executables utilising 'runQ', but fail to correctly link+-- libraries containing this function.+--+-- [/Note:/]+-- -- Due to <https://ghc.haskell.org/trac/ghc/ticket/13587 GHC#13587>, this -- currently must be as an /untyped/ splice. --@@ -382,59 +369,58 @@   TH.lamE [TH.varP target] (runQ' [| async |] (TH.varE target) f)  -runQ' :: Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ+runQ' :: forall f. Afunction f => TH.ExpQ -> TH.ExpQ -> f -> TH.ExpQ runQ' using target f = do-  -- Reification of the program for segmented folds depends on whether we are-  -- executing in parallel or sequentially, where the parallel case requires-  -- some extra work to convert the segments descriptor into a segment offset-  -- array. Also do this conversion, so that the program can be run both in-  -- parallel as well as sequentially (albeit with some additional work that-  -- could have been avoided).-  ---  -- TLM: We could also just reify the program twice and select at runtime which-  --      version to execute.-  ---  afun  <- let acc = convertAfunWith (phases { convertOffsetOfSegment = True }) f-           in  TH.runIO $ do+#if MIN_VERSION_template_haskell(2,13,0)+  -- The plugin ensures that objects are loaded correctly into GHCi+  TH.addCorePlugin "Data.Array.Accelerate.LLVM.Native.Plugin"+#endif++  afun  <- let acc = convertAfun f+            in TH.runIO $ do                  dumpGraph acc-                 evalNative (defaultTarget { segmentOffset = True }) $-                   phase "compile" elapsedS (compileAfun acc) >>= dumpStats+                 evalNative defaultTarget $+                  phase "compile" elapsedS (compileAfun acc) >>= dumpStats -  -- generate a lambda function with the correct number of arguments and apply-  -- directly to the body expression.+  -- generate a lambda function with the correct number of arguments and+  -- apply directly to the body expression.+  --+  -- XXX: remove use of 'getArrays', 'toArr', and 'fromArr' in the embedded+  -- code; we should be able to generate all bindings directly and assemble+  -- the pieces directly.+  --   let-      go :: Typeable aenv => CompiledOpenAfun Native aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ-      go (Alam lam) xs as stmts = do+      go :: CompiledOpenAfun Native aenv t -> [TH.PatQ] -> [TH.ExpQ] -> [TH.StmtQ] -> TH.ExpQ+      go (Alam lhs l) xs as stmts = do         x <- TH.newName "x" -- lambda bound variable         a <- TH.newName "a" -- local array name-        s <- TH.bindS (TH.conP 'AsyncR [TH.wildP, TH.varP a]) [| E.async (useRemoteAsync $(TH.varE x)) |]-        go lam (TH.varP x : xs) (TH.varE a : as) (return s : stmts)+        s <- TH.bindS (TH.varP a) [| useRemoteAsync $(TH.unTypeQ $ liftArraysR (lhsToTupR lhs)) (fromArr $(TH.varE x)) |]+        go l (TH.varP x : xs) ([| ($(TH.unTypeQ $ liftALeftHandSide lhs), $(TH.varE a)) |] : as) (return s : stmts) -      go (Abody body) xs as stmts =-        let aenv = foldr (\a gamma -> [| $gamma `Apush` $a |] ) [| Aempty |] as-            eval = TH.noBindS [| E.get =<< E.async (executeOpenAcc $(TH.unTypeQ (embedOpenAcc (defaultTarget { segmentOffset = True }) body)) $aenv) |]-        in-        TH.lamE (reverse xs) [| $using . phase "execute" elapsedP . evalNative ($target { segmentOffset = True }) $-                                  $(TH.doE (reverse (eval : stmts))) |]+      go (Abody b) xs as stmts = do+        r <- TH.newName "r" -- result+        s <- TH.newName "s"+        let+            aenv  = foldr (\a gamma -> [| $gamma `push` $a |]) [| Empty |] as+            body  = embedOpenAcc defaultTarget b+        --+        TH.lamE (reverse xs)+                [| $using . phase "execute" elapsedP . evalNative $target . evalPar $+                      $(TH.doE ( reverse stmts +++                               [ TH.bindS (TH.varP r) [| executeOpenAcc $(TH.unTypeQ body) $aenv |]+                               , TH.bindS (TH.varP s) [| getArrays $(TH.unTypeQ (liftArraysR (arraysR b))) $(TH.varE r) |]+                               , TH.noBindS [| return $ toArr $(TH.varE s) |]+                               ]))+                 |]   --   go afun [] [] []  --- How the Accelerate program should be evaluated.------ TODO: make sharing/fusion runtime configurable via debug flags or otherwise.----config :: Native -> Phase-config target = phases-  { convertOffsetOfSegment = segmentOffset target-  }-- -- Debugging -- =========  dumpStats :: MonadIO m => a -> m a-dumpStats x = dumpSimplStats >> return x+dumpStats x = liftIO dumpSimplStats >> return x  phase :: MonadIO m => String -> (Double -> Double -> String) -> m a -> m a phase n fmt go = timed dump_phases (\wall cpu -> printf "phase %s: %s" n (fmt wall cpu)) go

@@ -1,13 +1,14 @@+{-# LANGUAGE BangPatterns        #-} {-# LANGUAGE GADTs               #-}+{-# LANGUAGE MagicHash           #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.Array.Data--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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,89 +16,58 @@ module Data.Array.Accelerate.LLVM.Native.Array.Data (    module Data.Array.Accelerate.LLVM.Array.Data,-   cloneArray,  ) where --- accelerate-import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Elt+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type  import Data.Array.Accelerate.LLVM.State import Data.Array.Accelerate.LLVM.Array.Data+import Data.Array.Accelerate.LLVM.Native.Execute.Async              ()  -- Async Native import Data.Array.Accelerate.LLVM.Native.Target-import Data.Array.Accelerate.LLVM.Native.Execute.Async () --- standard library import Control.Monad.Trans-import Data.Word-import Foreign.C import Foreign.Ptr-import Foreign.Storable   -- | Data instance for arrays in the native backend. We assume a shared-memory -- machine, and just manipulate the underlying Haskell array directly. ---instance Remote Native+instance Remote Native where+  {-# INLINE allocateRemote #-}+  allocateRemote repr = liftIO . allocateArray repr   -- | Copy an array into a newly allocated array. This uses 'memcpy'. ---cloneArray :: (Shape sh, Elt e) => Array sh e -> LLVM Native (Array sh e)-cloneArray arr@(Array _ src) = liftIO $ do-  out@(Array _ dst)    <- allocateArray sh-  copyR arrayElt src dst+cloneArray :: ArrayR (Array sh e) -> Array sh e -> LLVM Native (Array sh e)+cloneArray repr (Array sh src) = liftIO $ do+  out@(Array _ dst) <- allocateArray repr sh+  copyR (arrayRtype repr) src dst   return out   where-    sh                  = shape arr-    n                   = size sh+    n = size (arrayRshape repr) sh -    copyR :: ArrayEltR e -> ArrayData e -> ArrayData e -> IO ()-    copyR ArrayEltRunit             _   _   = return ()-    copyR (ArrayEltRpair aeR1 aeR2) ad1 ad2 = copyR aeR1 (fstArrayData ad1) (fstArrayData ad2) >>-                                              copyR aeR2 (sndArrayData ad1) (sndArrayData ad2)-    ---    copyR (ArrayEltRvec2 aeR)  (AD_V2 ad1)  (AD_V2 ad2)   = copyR aeR ad1 ad2-    copyR (ArrayEltRvec3 aeR)  (AD_V3 ad1)  (AD_V3 ad3)   = copyR aeR ad1 ad3-    copyR (ArrayEltRvec4 aeR)  (AD_V4 ad1)  (AD_V4 ad4)   = copyR aeR ad1 ad4-    copyR (ArrayEltRvec8 aeR)  (AD_V8 ad1)  (AD_V8 ad8)   = copyR aeR ad1 ad8-    copyR (ArrayEltRvec16 aeR) (AD_V16 ad1) (AD_V16 ad16) = copyR aeR ad1 ad16-    ---    copyR ArrayEltRint              ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRint8             ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRint16            ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRint32            ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRint64            ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRword             ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRword8            ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRword16           ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRword32           ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRword64           ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRhalf             ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRfloat            ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRdouble           ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRbool             ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRchar             ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcshort           ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcushort          ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcint             ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcuint            ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRclong            ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRculong           ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcllong           ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcullong          ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcfloat           ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcdouble          ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcchar            ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcschar           ad1 ad2 = copyPrim ad1 ad2-    copyR ArrayEltRcuchar           ad1 ad2 = copyPrim ad1 ad2+    copyR :: TypeR e -> ArrayData e -> ArrayData e -> IO ()+    copyR TupRunit          !_          !_          = return ()+    copyR (TupRsingle t)    !ad1        !ad2        = copyPrim t ad1 ad2+    copyR (TupRpair !t !t') (ad1, ad1') (ad2, ad2') = do+      copyR t  ad1  ad2+      copyR t' ad1' ad2' -    copyPrim :: forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a) => ArrayData e -> ArrayData e -> IO ()-    copyPrim a1 a2 = do-      let p1 = ptrsOfArrayData a1-          p2 = ptrsOfArrayData a2-      memcpy (castPtr p2) (castPtr p1) (n * sizeOf (undefined :: a))+    copyPrim :: ScalarType e -> ArrayData e -> ArrayData e -> IO ()+    copyPrim !tp !a1 !a2+      | ScalarArrayDict{} <- scalarArrayDict tp = do+      let p1 = unsafeUniqueArrayPtr a1+          p2 = unsafeUniqueArrayPtr a2+      memcpy (castPtr p2) (castPtr p1) (n * bytesElt (TupRsingle tp))   -- Standard C functions

@@ -1,11 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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) --@@ -26,21 +25,20 @@ import Data.Array.Accelerate.LLVM.Native.CodeGen.Map import Data.Array.Accelerate.LLVM.Native.CodeGen.Permute import Data.Array.Accelerate.LLVM.Native.CodeGen.Scan+import Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil+import Data.Array.Accelerate.LLVM.Native.CodeGen.Transform import Data.Array.Accelerate.LLVM.Native.Target   instance Skeleton Native where-  map _         = mkMap-  generate _    = mkGenerate-  fold _        = mkFold-  fold1 _       = mkFold1-  foldSeg _     = mkFoldSeg-  fold1Seg _    = mkFold1Seg-  scanl _       = mkScanl-  scanl1 _      = mkScanl1-  scanl' _      = mkScanl'-  scanr _       = mkScanr-  scanr1 _      = mkScanr1-  scanr' _      = mkScanr'-  permute _     = mkPermute+  map         = mkMap+  generate    = mkGenerate+  transform   = mkTransform+  fold        = mkFold+  foldSeg     = mkFoldSeg+  scan        = mkScan+  scan'       = mkScan'+  permute     = mkPermute+  stencil1    = mkStencil1+  stencil2    = mkStencil2 

@@ -1,13 +1,14 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE TypeOperators       #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Base--- Copyright   : [2015..2017] Trevor L. McDonell+-- Copyright   : [2015..2020] The Accelerate Team -- 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,20 +16,23 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Base   where -import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.CodeGen.Base-import Data.Array.Accelerate.LLVM.CodeGen.Downcast import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Module import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type +import LLVM.AST.Type.Downcast import LLVM.AST.Type.Name import qualified LLVM.AST.Global                                    as LLVM import qualified LLVM.AST.Type                                      as LLVM +import Control.Monad import Data.Monoid import Data.String import Text.Printf@@ -38,23 +42,21 @@ -- | Generate function parameters that will specify the first and last (linear) -- index of the array this thread should evaluate. ---gangParam :: (IR Int, IR Int, [LLVM.Parameter])-gangParam =-  let t         = scalarType-      start     = "ix.start"-      end       = "ix.end"+gangParam :: ShapeR sh -> (Operands sh, Operands sh, [LLVM.Parameter])+gangParam shr =+  let start = "ix.start"+      end   = "ix.end"+      tp    = shapeType shr   in-  (local t start, local t end, [ scalarParameter t start, scalarParameter t end ] )+  (local tp start, local tp end, parameter tp start ++ parameter tp end)  --- | The thread ID of a gang worker+-- | The worker ID of the calling thread ---gangId :: (IR Int, [LLVM.Parameter])+gangId :: (Operands Int, [LLVM.Parameter]) gangId =-  let t         = scalarType-      tid       = "ix.tid"-  in-  (local t tid, [ scalarParameter t tid ] )+  let tid = "ix.tid"+  in (local (TupRsingle scalarTypeInt) tid, [ scalarParameter scalarType tid ] )   -- Global function definitions@@ -69,7 +71,7 @@  -- | Create a single kernel program ---makeOpenAcc :: UID -> Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (IROpenAcc Native aenv a)+makeOpenAcc :: UID -> Label -> [LLVM.Parameter] -> CodeGen Native () -> CodeGen Native (IROpenAcc Native aenv a) makeOpenAcc uid name param kernel = do   body  <- makeKernel (name <> fromString (printf "_%s" (show uid))) param kernel   return $ IROpenAcc [body]@@ -77,7 +79,7 @@ -- | Create a complete kernel function by running the code generation process -- specified in the final parameter. ---makeKernel :: Label -> [LLVM.Parameter] -> CodeGen () -> CodeGen (Kernel Native aenv a)+makeKernel :: Label -> [LLVM.Parameter] -> CodeGen Native () -> CodeGen Native (Kernel Native aenv a) makeKernel name param kernel = do   _    <- kernel   code <- createBlocks

@@ -2,13 +2,14 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeOperators       #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Fold--- Copyright   : [2014..2017] Trevor L. McDonell+-- Copyright   : [2014..2020] The Accelerate Team -- 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,17 +17,17 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Fold   where --- accelerate-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type -import Data.Array.Accelerate.LLVM.Analysis.Match import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Constant import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar@@ -41,45 +42,28 @@ import Prelude                                                      as P hiding ( length )  --- Reduce a (possibly empty) array along the innermost dimension. The reduction+-- Reduce an array along the innermost dimension. The reduction -- function must be associative to allow for an efficient parallel--- implementation. The initial element does not need to be a neutral element of--- the operator.+-- implementation. When an initial value is given, the input can be+-- empty. The initial element does not need to be a neutral element of+-- the operator. When no initial value is given, the array must be+-- non-empty -- mkFold-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRExp     Native aenv e-    -> IRDelayed Native aenv (Array (sh :. Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkFold uid aenv f z acc-  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)-  = (+++) <$> mkFoldAll  uid aenv f (Just z) acc-          <*> mkFoldFill uid aenv z--  | otherwise-  = (+++) <$> mkFoldDim  uid aenv f (Just z) acc-          <*> mkFoldFill uid aenv z----- Reduce a non-empty array along the innermost dimension. The reduction--- function must be associative to allow for efficient parallel implementation.----mkFold1-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRDelayed Native aenv (Array (sh :. Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkFold1 uid aenv f acc-  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)-  = mkFoldAll uid aenv f Nothing acc--  | otherwise-  = mkFoldDim uid aenv f Nothing acc+    :: UID+    -> Gamma             aenv+    -> ArrayR (Array sh e)+    -> IRFun2       Native aenv (e -> e -> e)+    -> Maybe (IRExp Native aenv e)+    -> MIRDelayed   Native aenv (Array (sh, Int) e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array sh e))+mkFold uid aenv aR f z arr =+  (+++) <$> case aR of+              ArrayR ShapeRz eR -> mkFoldAll uid aenv eR f z arr+              _                 -> mkFoldDim uid aenv aR f z arr+        <*> case z of+              Just z' -> mkFoldFill uid aenv aR z'+              Nothing -> return (IROpenAcc [])   -- Reduce a multidimensional (>1) array along the innermost dimension.@@ -88,33 +72,33 @@ -- of an innermost-dimension index) is computed by a single thread. -- mkFoldDim-  :: forall aenv sh e. (Shape sh, Elt e)-  =>          UID-  ->          Gamma            aenv-  ->          IRFun2    Native aenv (e -> e -> e)-  -> Maybe   (IRExp     Native aenv e)-  ->          IRDelayed Native aenv (Array (sh :. Int) e)-  -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkFoldDim uid aenv combine mseed IRDelayed{..} =+  :: UID+  -> Gamma aenv+  -> ArrayR (Array sh e)+  -> IRFun2     Native aenv (e -> e -> e)+  -> MIRExp     Native aenv e+  -> MIRDelayed Native aenv (Array (sh, Int) e)+  -> CodeGen    Native      (IROpenAcc Native aenv (Array sh e))+mkFoldDim uid aenv aR@(ArrayR shR eR) combine mseed mdelayed =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array sh e))-      paramEnv                  = envParam aenv-      ---      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)-      stride                    = local           scalarType ("ix.stride" :: Name Int)+      (start, end, paramGang) = gangParam shR+      (arrOut, paramOut)      = mutableArray aR "out"+      (arrIn,  paramIn)       = delayedArray    "in"  mdelayed+      paramEnv                = envParam aenv+      zero                    = liftInt 0   in-  makeOpenAcc uid "fold" (paramGang ++ paramStride : paramOut ++ paramEnv) $ do+  makeOpenAcc uid "fold" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do -    imapFromTo start end $ \seg -> do-      from <- mul numType seg  stride-      to   <- add numType from stride-      ---      r    <- case mseed of-                Just seed -> do z <- seed-                                reduceFromTo  from to (app2 combine) z (app1 delayedLinearIndex)-                Nothing   ->    reduce1FromTo from to (app2 combine)   (app1 delayedLinearIndex)-      writeArray arrOut seg r+    sz <- indexHead <$> delayedExtent arrIn++    imapNestFromTo shR start end (irArrayShape arrOut) $ \ix i -> do+      r <- case mseed of+             Just seed -> do z <- seed+                             reduceFromTo  eR zero sz (app2 combine) z (app1 (delayedIndex arrIn) . indexCons ix)+             Nothing   ->    reduce1FromTo eR zero sz (app2 combine)   (app1 (delayedIndex arrIn) . indexCons ix)++      writeArray TypeInt arrOut i r+     return_  @@ -142,43 +126,44 @@ -- is an exclusive reduction, the seed element is included at this point. -- mkFoldAll-    :: forall aenv e. Elt e-    =>          UID-    ->          Gamma            aenv                           -- ^ array environment-    ->          IRFun2    Native aenv (e -> e -> e)             -- ^ combination function-    -> Maybe   (IRExp     Native aenv e)                        -- ^ seed element, if this is an exclusive reduction-    ->          IRDelayed Native aenv (Vector e)                -- ^ input data-    -> CodeGen (IROpenAcc Native aenv (Scalar e))-mkFoldAll uid aenv combine mseed arr =-  foldr1 (+++) <$> sequence [ mkFoldAllS  uid aenv combine mseed arr-                            , mkFoldAllP1 uid aenv combine       arr-                            , mkFoldAllP2 uid aenv combine mseed+    :: UID+    -> Gamma aenv                                   -- ^ array environment+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)         -- ^ combination function+    -> MIRExp     Native aenv e                     -- ^ seed element, if this is an exclusive reduction+    -> MIRDelayed Native aenv (Vector e)            -- ^ input data+    -> CodeGen    Native      (IROpenAcc Native aenv (Scalar e))+mkFoldAll uid aenv eR combine mseed mdelayed =+  foldr1 (+++) <$> sequence [ mkFoldAllS  uid aenv eR combine mseed mdelayed+                            , mkFoldAllP1 uid aenv eR combine       mdelayed+                            , mkFoldAllP2 uid aenv eR combine mseed                             ]   -- Sequential reduction of an entire array to a single element -- mkFoldAllS-    :: forall aenv e. Elt e-    =>          UID-    ->          Gamma            aenv                           -- ^ array environment-    ->          IRFun2    Native aenv (e -> e -> e)             -- ^ combination function-    -> Maybe   (IRExp     Native aenv e)                        -- ^ seed element, if this is an exclusive reduction-    ->          IRDelayed Native aenv (Vector e)                -- ^ input data-    -> CodeGen (IROpenAcc Native aenv (Scalar e))-mkFoldAllS uid aenv combine mseed IRDelayed{..} =+    :: UID+    -> Gamma aenv                                   -- ^ array environment+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)         -- ^ combination function+    -> MIRExp     Native aenv e                     -- ^ seed element, if this is an exclusive reduction+    -> MIRDelayed Native aenv (Vector e)            -- ^ input data+    -> CodeGen    Native      (IROpenAcc Native aenv (Scalar e))+mkFoldAllS uid aenv eR combine mseed mdelayed  =   let-      (start, end, paramGang)   = gangParam-      paramEnv                  = envParam aenv-      (arrOut,  paramOut)       = mutableArray ("out" :: Name (Scalar e))-      zero                      = lift 0 :: IR Int+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim0 eR) "out"+      (arrIn,  paramIn)       = delayedArray                  "in" mdelayed+      paramEnv                = envParam aenv+      zero                    = liftInt 0   in-  makeOpenAcc uid "foldAllS" (paramGang ++ paramOut ++ paramEnv) $ do+  makeOpenAcc uid "foldAllS" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do     r <- case mseed of            Just seed -> do z <- seed-                           reduceFromTo  start end (app2 combine) z (app1 delayedLinearIndex)-           Nothing   ->    reduce1FromTo start end (app2 combine)   (app1 delayedLinearIndex)-    writeArray arrOut zero r+                           reduceFromTo  eR (indexHead start) (indexHead end) (app2 combine) z (app1 (delayedLinearIndex arrIn))+           Nothing   ->    reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine)   (app1 (delayedLinearIndex arrIn))+    writeArray TypeInt arrOut zero r     return_  -- Parallel reduction of an entire array to a single element, step 1.@@ -187,36 +172,30 @@ -- any fused functions on the way. -- mkFoldAllP1-    :: forall aenv e. Elt e-    =>          UID-    ->          Gamma            aenv                           -- ^ array environment-    ->          IRFun2    Native aenv (e -> e -> e)             -- ^ combination function-    ->          IRDelayed Native aenv (Vector e)                -- ^ input data-    -> CodeGen (IROpenAcc Native aenv (Scalar e))-mkFoldAllP1 uid aenv combine IRDelayed{..} =+    :: UID+    -> Gamma             aenv                       -- ^ array environment+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)         -- ^ combination function+    -> MIRDelayed Native aenv (Vector e)            -- ^ input data+    -> CodeGen    Native      (IROpenAcc Native aenv (Scalar e))+mkFoldAllP1 uid aenv eR combine mdelayed =   let-      (start, end, paramGang)   = gangParam-      paramEnv                  = envParam aenv-      (arrTmp,  paramTmp)       = mutableArray ("tmp" :: Name (Vector e))-      length                    = local           scalarType ("ix.length" :: Name Int)-      stride                    = local           scalarType ("ix.stride" :: Name Int)-      paramLength               = scalarParameter scalarType ("ix.length" :: Name Int)-      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)+      (start, end, paramGang) = gangParam    dim1+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrIn,  paramIn)       = delayedArray                  "in" mdelayed+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"+      paramEnv                = envParam aenv   in-  makeOpenAcc uid "foldAllP1" (paramGang ++ paramLength : paramStride : paramTmp ++ paramEnv) $ do+  makeOpenAcc uid "foldAllP1" (paramGang ++ paramPiece ++ paramTmp ++ paramIn ++ paramEnv) $ do      -- A thread reduces a sequential (non-empty) stripe of the input and stores-    -- that value into a temporary array at a specific index. The size of the-    -- stripe is fixed, but work stealing occurs between stripe indices. This-    -- method thus supports non-commutative operators because the order of-    -- operations remains left-to-right.+    -- that value into a temporary array at a specific index. This method thus+    -- supports non-commutative operators because the order of operations+    -- remains left-to-right.     ---    imapFromTo start end $ \i -> do-      inf <- A.mul numType    i   stride-      a   <- A.add numType    inf stride-      sup <- A.min singleType a   length-      r   <- reduce1FromTo inf sup (app2 combine) (app1 delayedLinearIndex)-      writeArray arrTmp i r+    r <- reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine) (app1 (delayedLinearIndex arrIn))+    writeArray TypeInt arrTmp piece r      return_ @@ -230,26 +209,26 @@ -- large, continuing reducing it in parallel. -- mkFoldAllP2-    :: forall aenv e. Elt e-    =>          UID-    ->          Gamma            aenv                           -- ^ array environment-    ->          IRFun2    Native aenv (e -> e -> e)             -- ^ combination function-    -> Maybe   (IRExp     Native aenv e)                        -- ^ seed element, if this is an exclusive reduction-    -> CodeGen (IROpenAcc Native aenv (Scalar e))-mkFoldAllP2 uid aenv combine mseed =+    :: UID+    -> Gamma          aenv                          -- ^ array environment+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)            -- ^ combination function+    -> MIRExp  Native aenv e                        -- ^ seed element, if this is an exclusive reduction+    -> CodeGen Native      (IROpenAcc Native aenv (Scalar e))+mkFoldAllP2 uid aenv eR combine mseed =   let-      (start, end, paramGang)   = gangParam-      paramEnv                  = envParam aenv-      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Scalar e))-      zero                      = lift 0 :: IR Int+      (start, end, paramGang) = gangParam    dim1+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrOut, paramOut)      = mutableArray (ArrayR dim0 eR) "out"+      paramEnv                = envParam aenv+      zero                    = liftInt 0   in   makeOpenAcc uid "foldAllP2" (paramGang ++ paramTmp ++ paramOut ++ paramEnv) $ do     r <- case mseed of            Just seed -> do z <- seed-                           reduceFromTo  start end (app2 combine) z (readArray arrTmp)-           Nothing   ->    reduce1FromTo start end (app2 combine)   (readArray arrTmp)-    writeArray arrOut zero r+                           reduceFromTo  eR (indexHead start) (indexHead end) (app2 combine) z (readArray TypeInt arrTmp)+           Nothing   ->    reduce1FromTo eR (indexHead start) (indexHead end) (app2 combine)   (readArray TypeInt arrTmp)+    writeArray TypeInt arrOut zero r     return_  @@ -257,13 +236,13 @@ -- dimensions with the initial element -- mkFoldFill-    :: (Shape sh, Elt e)-    => UID+    :: UID     -> Gamma aenv-    -> IRExp Native aenv e-    -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkFoldFill uid aenv seed =-  mkGenerate uid aenv (IRFun1 (const seed))+    -> ArrayR (Array sh e)+    -> IRExp   Native aenv e+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkFoldFill uid aenv aR seed =+  mkGenerate uid aenv aR (IRFun1 (const seed))  -- Reduction loops -- ---------------@@ -271,15 +250,15 @@ -- Reduction of a (possibly empty) index space. -- reduceFromTo-    :: Elt a-    => IR Int                                   -- ^ starting index-    -> IR Int                                   -- ^ final index (exclusive)-    -> (IR a -> IR a -> CodeGen (IR a))         -- ^ combination function-    -> IR a                                     -- ^ initial value-    -> (IR Int -> CodeGen (IR a))               -- ^ function to retrieve element at index-    -> CodeGen (IR a)-reduceFromTo m n f z get =-  iterFromTo m n z $ \i acc -> do+    :: TypeR e+    -> Operands Int                                              -- ^ starting index+    -> Operands Int                                              -- ^ final index (exclusive)+    -> (Operands e -> Operands e -> CodeGen Native (Operands e)) -- ^ combination function+    -> Operands e                                                -- ^ initial value+    -> (Operands Int -> CodeGen Native (Operands e))             -- ^ function to retrieve element at index+    -> CodeGen Native (Operands e)+reduceFromTo eR m n f z get =+  iterFromTo eR m n z $ \i acc -> do     x <- get i     y <- f acc x     return y@@ -288,14 +267,14 @@ -- contain at least one element. -- reduce1FromTo-    :: Elt a-    => IR Int                                   -- ^ starting index-    -> IR Int                                   -- ^ final index-    -> (IR a -> IR a -> CodeGen (IR a))         -- ^ combination function-    -> (IR Int -> CodeGen (IR a))               -- ^ function to retrieve element at index-    -> CodeGen (IR a)-reduce1FromTo m n f get = do+    :: TypeR e+    -> Operands Int                                              -- ^ starting index+    -> Operands Int                                              -- ^ final index+    -> (Operands e -> Operands e -> CodeGen Native (Operands e)) -- ^ combination function+    -> (Operands Int -> CodeGen Native (Operands e))             -- ^ function to retrieve element at index+    -> CodeGen Native (Operands e)+reduce1FromTo eR m n f get = do   z  <- get m   m1 <- add numType m (ir numType (num numType 1))-  reduceFromTo m1 n f z get+  reduceFromTo eR m1 n f z get 

@@ -1,14 +1,15 @@ {-# LANGUAGE GADTs               #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeOperators       #-} {-# LANGUAGE ViewPatterns        #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg--- Copyright   : [2014..2017] Trevor L. McDonell+-- Copyright   : [2014..2020] The Accelerate Team -- 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,17 +17,14 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.FoldSeg   where --- accelerate-import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.Type  import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Environment-import Data.Array.Accelerate.LLVM.CodeGen.IR-import Data.Array.Accelerate.LLVM.CodeGen.Exp                       ( indexHead )-import Data.Array.Accelerate.LLVM.CodeGen.Loop+import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache@@ -36,86 +34,54 @@ import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop import Data.Array.Accelerate.LLVM.Native.Target                     ( Native ) -import Control.Applicative import Control.Monad import Prelude                                                      as P ---- Segmented reduction along the innermost dimension of an array. Performs one--- reduction per segment of the source array.----mkFoldSeg-    :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRExp     Native aenv e-    -> IRDelayed Native aenv (Array (sh :. Int) e)-    -> IRDelayed Native aenv (Segments i)-    -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e))-mkFoldSeg uid aenv combine seed arr seg =-  (+++) <$> mkFoldSegS uid aenv combine (Just seed) arr seg-        <*> mkFoldSegP uid aenv combine (Just seed) arr seg----- Segmented reduction along the innermost dimension of an array, where /all/--- segments are non-empty.----mkFold1Seg-    :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRDelayed Native aenv (Array (sh :. Int) e)-    -> IRDelayed Native aenv (Segments i)-    -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e))-mkFold1Seg uid aenv combine arr seg =-  (+++) <$> mkFoldSegS uid aenv combine Nothing arr seg-        <*> mkFoldSegP uid aenv combine Nothing arr seg--+{-- -- Segmented reduction where a single processor reduces the entire array. The -- segments array contains the length of each segment. -- mkFoldSegS     :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)-    =>          UID-    ->          Gamma            aenv-    ->          IRFun2    Native aenv (e -> e -> e)-    -> Maybe   (IRExp     Native aenv e)-    ->          IRDelayed Native aenv (Array (sh :. Int) e)-    ->          IRDelayed Native aenv (Segments i)-    -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e))-mkFoldSegS uid aenv combine mseed arr seg =+    => UID+    -> Gamma             aenv+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Array (sh :. Int) e)+    -> MIRDelayed Native aenv (Segments i)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh :. Int) e))+mkFoldSegS uid aenv combine mseed marr mseg =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array (sh :. Int) e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam @DIM1+      (arrOut, paramOut)      = mutableArray @(sh:.Int) "out"+      (arrIn,  paramIn)       = delayedArray @(sh:.Int) "in"  marr+      (arrSeg, paramSeg)      = delayedArray @DIM1      "seg" mseg+      paramEnv                = envParam aenv   in-  makeOpenAcc uid "foldSegS" (paramGang ++ paramOut ++ paramEnv) $ do+  makeOpenAcc uid "foldSegS" (paramGang ++ paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do      -- Number of segments, useful only if reducing DIM2 and higher-    ss <- indexHead <$> delayedExtent seg+    ss <- indexHead <$> delayedExtent arrSeg -    let test si = A.lt singleType (A.fst si) end-        initial = A.pair start (lift 0)+    let test si = A.lt singleType (A.fst si) (indexHead end)+        initial = A.pair (indexHead start) (lift 0) -        body :: IR (Int,Int) -> CodeGen (IR (Int,Int))+        body :: IR (Int,Int) -> CodeGen Native (IR (Int,Int))         body (A.unpair -> (s,inf)) = do           -- We can avoid an extra division if this is a DIM1 array. Higher           -- dimensional reductions need to wrap around the segment array at           -- each new lower-dimensional index.-          s'  <- case rank (undefined::sh) of+          s'  <- case rank @sh of                    0 -> return s                    _ -> A.rem integralType s ss -          len <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) s'+          len <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex arrSeg) s'           sup <- A.add numType inf len            r   <- case mseed of                    Just seed -> do z <- seed-                                   reduceFromTo  inf sup (app2 combine) z (app1 (delayedLinearIndex arr))-                   Nothing   ->    reduce1FromTo inf sup (app2 combine)   (app1 (delayedLinearIndex arr))+                                   reduceFromTo  inf sup (app2 combine) z (app1 (delayedLinearIndex arrIn))+                   Nothing   ->    reduce1FromTo inf sup (app2 combine)   (app1 (delayedLinearIndex arrIn))           writeArray arrOut s r            t <- A.add numType s (lift 1)@@ -123,59 +89,56 @@      void $ while test body initial     return_+--}  +-- Segmented reduction along the innermost dimension of an array. Performs one+-- reduction per segment of the source array. When no seed is given, assumes+-- that /all/ segments are non-empty.+-- -- This implementation assumes that the segments array represents the offset -- indices to the source array, rather than the lengths of each segment. The -- segment-offset approach is required for parallel implementations. ---mkFoldSegP-    :: forall aenv sh i e. (Shape sh, IsIntegral i, Elt i, Elt e)-    =>          UID-    ->          Gamma            aenv-    ->          IRFun2    Native aenv (e -> e -> e)-    -> Maybe   (IRExp     Native aenv e)-    ->          IRDelayed Native aenv (Array (sh :. Int) e)-    ->          IRDelayed Native aenv (Segments i)-    -> CodeGen (IROpenAcc Native aenv (Array (sh :. Int) e))-mkFoldSegP uid aenv combine mseed arr seg =+mkFoldSeg+    :: UID+    -> Gamma             aenv+    -> ArrayR (Array (sh, Int) e)+    -> IntegralType i+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Array (sh, Int) e)+    -> MIRDelayed Native aenv (Segments i)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh, Int) e))+mkFoldSeg uid aenv aR@(ArrayR shR eR) int combine mseed marr mseg =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array (sh :. Int) e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam shR+      (arrOut, paramOut)      = mutableArray aR "out"+      (arrIn,  paramIn)       = delayedArray    "in"  marr+      (arrSeg, paramSeg)      = delayedArray    "seg" mseg+      paramEnv                = envParam aenv   in-  makeOpenAcc uid "foldSegP" (paramGang ++ paramOut ++ paramEnv) $ do--    -- Number of segments and size of the innermost dimension. These are-    -- required if we are reducing a DIM2 or higher array, to properly compute-    -- the start and end indices of the portion of the array to reduce. Note-    -- that this is a segment-offset array computed by 'scanl (+) 0' of the-    -- segment length array, so its size has increased by one.-    sz <- indexHead <$> delayedExtent arr-    ss <- do n <- indexHead <$> delayedExtent seg-             A.sub numType n (lift 1)--    imapFromTo start end $ \s -> do+  makeOpenAcc uid "foldSegP" (paramGang ++ paramOut ++ paramIn ++ paramSeg ++ paramEnv) $ do -      i   <- case rank (undefined::sh) of-               0 -> return s-               _ -> A.rem integralType s ss-      j   <- A.add numType i (lift 1)-      u   <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) i-      v   <- A.fromIntegral integralType numType =<< app1 (delayedLinearIndex seg) j+    imapNestFromTo shR start end (irArrayShape arrOut) $ \ix ii -> do -      (inf,sup) <- A.unpair <$> case rank (undefined::sh) of-                     0 -> return (A.pair u v)-                     _ -> do q <- A.quot integralType s ss-                             a <- A.mul numType q sz-                             A.pair <$> A.add numType u a <*> A.add numType v a+      -- Determine the start and end indices of the innermost portion of+      -- the array to reduce. This is a segment-offset array computed by+      -- 'scanl (+) 0' of the segment length array.+      --+      let iz = indexTail ix+          i  = indexHead ix+      --+      j <- A.add numType i (liftInt 1)+      u <- A.fromIntegral int numType =<< app1 (delayedLinearIndex arrSeg) i+      v <- A.fromIntegral int numType =<< app1 (delayedLinearIndex arrSeg) j -      r   <- case mseed of-               Just seed -> do z <- seed-                               reduceFromTo  inf sup (app2 combine) z (app1 (delayedLinearIndex arr))-               Nothing   ->    reduce1FromTo inf sup (app2 combine)   (app1 (delayedLinearIndex arr))+      r <- case mseed of+             Just seed -> do z <- seed+                             reduceFromTo  eR u v (app2 combine) z (app1 (delayedIndex arrIn) . indexCons iz)+             Nothing   ->    reduce1FromTo eR u v (app2 combine)   (app1 (delayedIndex arrIn) . indexCons iz) -      writeArray arrOut s r+      writeArray TypeInt arrOut ii r      return_ 

@@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Generate--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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,13 +14,12 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Generate   where --- accelerate-import Data.Array.Accelerate.Array.Sugar                        ( Array, Shape, Elt )+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Type  import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Environment-import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache@@ -34,23 +33,23 @@ -- processes multiple adjacent elements. -- mkGenerate-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID+    :: UID     -> Gamma aenv-    -> IRFun1 Native aenv (sh -> e)-    -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkGenerate uid aenv apply =+    -> ArrayR (Array sh e)+    -> IRFun1  Native aenv (sh -> e)+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkGenerate uid aenv repr apply =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array sh e))+      (start, end, paramGang)   = gangParam (arrayRshape repr)+      (arrOut, paramOut)        = mutableArray repr "out"       paramEnv                  = envParam aenv+      shOut                     = irArrayShape arrOut   in   makeOpenAcc uid "generate" (paramGang ++ paramOut ++ paramEnv) $ do -    imapFromTo start end $ \i -> do-      ix <- indexOfInt (irArrayShape arrOut) i  -- convert to multidimensional index-      r  <- app1 apply ix                       -- apply generator function-      writeArray arrOut i r                     -- store result+    imapNestFromTo (arrayRshape repr) start end shOut $ \ix i -> do+      r <- app1 apply ix                        -- apply generator function+      writeArray TypeInt arrOut i r             -- store result      return_ 

@@ -1,9 +1,13 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.LLVM.CodeGen.Native.Loop--- Copyright   : [2014..2017] Trevor L. McDonell+-- Copyright   : [2014..2020] The Accelerate Team -- 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) --@@ -12,35 +16,145 @@   where  -- accelerate-import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Representation.Shape  import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad-import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop        as Loop+import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop            as Loop +import Data.Array.Accelerate.LLVM.Native.Target                     ( Native ) + -- | A standard 'for' loop, that steps from the start to end index executing the -- given function at each index. -- imapFromTo-    :: IR Int                                   -- ^ starting index (inclusive)-    -> IR Int                                   -- ^ final index (exclusive)-    -> (IR Int -> CodeGen ())                   -- ^ apply at each index-    -> CodeGen ()+    :: Operands Int                                   -- ^ starting index (inclusive)+    -> Operands Int                                   -- ^ final index (exclusive)+    -> (Operands Int -> CodeGen Native ())            -- ^ apply at each index+    -> CodeGen Native () imapFromTo start end body =-  Loop.imapFromStepTo start (lift 1) end body+  Loop.imapFromStepTo start (liftInt 1) end body ++-- | Generate a series of nested 'for' loops which iterate between the start and+-- end indices of a given hyper-rectangle. LLVM is very good at vectorising+-- these kinds of nested loops, but not so good at vectorising the flattened+-- representation utilising to/from index.+--+imapNestFromTo+    :: ShapeR sh+    -> Operands sh                                          -- ^ initial index (inclusive)+    -> Operands sh                                          -- ^ final index (exclusive)+    -> Operands sh                                          -- ^ total array extent+    -> (Operands sh -> Operands Int -> CodeGen Native ())   -- ^ apply at each index+    -> CodeGen Native ()+imapNestFromTo shr start end extent body =+  go shr start end body'+  where+    body' ix = body ix =<< intOfIndex shr extent ix++    go :: ShapeR t -> Operands t -> Operands t -> (Operands t -> CodeGen Native ()) -> CodeGen Native ()+    go ShapeRz OP_Unit OP_Unit k+      = k OP_Unit++    go (ShapeRsnoc shr') (OP_Pair ssh ssz) (OP_Pair esh esz) k+      = go shr' ssh esh+      $ \sz      -> imapFromTo ssz esz+      $ \i       -> k (OP_Pair sz i)+++{--+-- TLM: this version (seems to) compute the corresponding linear index as it+--      goes. We need to compare it against the above implementation to see if+--      there are any advantages.+--+imapNestFromTo'+    :: forall sh. Shape sh+    => Operands sh+    -> Operands sh+    -> Operands sh+    -> (Operands sh -> Operands Int -> CodeGen Native ())+    -> CodeGen Native ()+imapNestFromTo' start end extent body = do+  startl <- intOfIndex extent start+  void $ go (eltType @sh) start end extent (int 1) startl body'+  where+    body' :: Operands (EltRepr sh) -> Operands Int -> CodeGen Native (Operands Int)+    body' ix l = body ix l >> add numType (int 1) l++    go :: TupleType t+       -> Operands t+       -> Operands t+       -> Operands t+       -> Operands Int+       -> Operands Int+       -> (Operands t -> Operands Int -> CodeGen Native (Operands Int))+       -> CodeGen Native (Operands Int)+    go TypeRunit OP_Unit OP_Unit OP_Unit _delta l k+      = k OP_Unit l++    go (TypeRpair tsh tsz) (OP_Pair ssh ssz) (OP_Pair esh esz) (OP_Pair exh exz) delta l k+      | TypeRscalar t <- tsz+      , Just Refl     <- matchScalarType t (scalarType :: ScalarType Int)+      = do+          delta' <- mul numType delta exz+          go tsh ssh esh exh delta' l $ \sz ll -> do+            Loop.iterFromStepTo ssz (int 1) esz ll $ \i l' ->+              k (OP_Pair sz i) l'+            add numType ll delta'++    go _ _ _ _ _ _ _+      = $internalError "imapNestFromTo'" "expected shape with Int components"+--}++{--+-- | Generate a series of nested 'for' loops which iterate between the start and+-- end indices of a given hyper-rectangle. LLVM is very good at vectorising+-- these kinds of nested loops, but not so good at vectorising the flattened+-- representation utilising to/from index.+--+imapNestFromStepTo+    :: forall sh. Shape sh+    => Operands sh                                    -- ^ initial index (inclusive)+    -> Operands sh                                    -- ^ steps+    -> Operands sh                                    -- ^ final index (exclusive)+    -> Operands sh                                    -- ^ total array extent+    -> (Operands sh -> Operands Int -> CodeGen Native ())   -- ^ apply at each index+    -> CodeGen Native ()+imapNestFromStepTo start steps end extent body =+  go (eltType @sh) start steps end (body' . IR)+  where+    body' ix = body ix =<< intOfIndex extent ix++    go :: TupleType t -> Operands t -> Operands t -> Operands t -> (Operands t -> CodeGen Native ()) -> CodeGen Native ()+    go TypeRunit OP_Unit OP_Unit OP_Unit k+      = k OP_Unit++    go (TypeRpair tsh tsz) (OP_Pair ssh ssz) (OP_Pair sts stz) (OP_Pair esh esz) k+      | TypeRscalar t <- tsz+      , Just Refl     <- matchScalarType t (scalarType :: ScalarType Int)+      = go tsh ssh sts esh+      $ \sz      -> Loop.imapFromStepTo ssz stz esz+      $ \i       -> k (OP_Pair sz i)++    go _ _ _ _ _+      = $internalError "imapNestFromTo" "expected shape with Int components"+--}+ -- | Iterate with an accumulator between the start and end index, executing the -- given function at each. -- iterFromTo-    :: Elt a-    => IR Int                                   -- ^ starting index (inclusive)-    -> IR Int                                   -- ^ final index (exclusive)-    -> IR a                                     -- ^ initial value-    -> (IR Int -> IR a -> CodeGen (IR a))       -- ^ apply at each index-    -> CodeGen (IR a)-iterFromTo start end seed body =-  Loop.iterFromStepTo start (lift 1) end seed body+    :: TypeR a+    -> Operands Int                                       -- ^ starting index (inclusive)+    -> Operands Int                                       -- ^ final index (exclusive)+    -> Operands a                                         -- ^ initial value+    -> (Operands Int -> Operands a -> CodeGen Native (Operands a))    -- ^ apply at each index+    -> CodeGen Native (Operands a)+iterFromTo tp start end seed body =+  Loop.iterFromStepTo tp start (liftInt 1) end seed body 

@@ -2,13 +2,13 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Map--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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,12 +16,15 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Map   where --- accelerate-import Data.Array.Accelerate.Array.Sugar                        ( Array, Elt )+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type  import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache@@ -70,27 +73,30 @@ -- declare float @apply(float) -- - -- Apply the given unary function to each element of an array. ---mkMap :: forall aenv sh a b. Elt b-      => UID-      -> Gamma            aenv-      -> IRFun1    Native aenv (a -> b)-      -> IRDelayed Native aenv (Array sh a)-      -> CodeGen (IROpenAcc Native aenv (Array sh b))-mkMap uid aenv apply IRDelayed{..} =+-- The map operation can always treat an array of any dimension in its flat+-- underlying representation, which simplifies code generation.+--+mkMap :: UID+      -> Gamma aenv+      -> ArrayR (Array sh a)+      -> TypeR b+      -> IRFun1  Native aenv (a -> b)+      -> CodeGen Native      (IROpenAcc Native aenv (Array sh b))+mkMap uid aenv (ArrayR shR aR) bR apply =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array sh b))+      (start, end, paramGang)   = gangParam dim1+      (arrIn,  paramIn)         = mutableArray (ArrayR shR aR) "in"+      (arrOut, paramOut)        = mutableArray (ArrayR shR bR) "out"       paramEnv                  = envParam aenv   in-  makeOpenAcc uid "map" (paramGang ++ paramOut ++ paramEnv) $ do+  makeOpenAcc uid "map" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do -    imapFromTo start end $ \i -> do-      xs <- app1 delayedLinearIndex i+    imapFromTo (indexHead start) (indexHead end) $ \i -> do+      xs <- readArray TypeInt arrIn i       ys <- app1 apply xs-      writeArray arrOut i ys+      writeArray TypeInt arrOut i ys      return_ 

@@ -1,14 +1,15 @@+{-# LANGUAGE CPP                 #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Permute--- Copyright   : [2016..2017] Trevor L. McDonell+-- Copyright   : [2016..2020] The Accelerate Team -- 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,10 +17,11 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Permute   where --- accelerate-import Data.Array.Accelerate.Array.Sugar                            ( Array, Vector, Shape, Elt, eltType )+import Data.Array.Accelerate.AST                                    ( PrimMaybe ) import Data.Array.Accelerate.Error-import qualified Data.Array.Accelerate.Array.Sugar                  as S+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type  import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A import Data.Array.Accelerate.LLVM.CodeGen.Array@@ -47,7 +49,6 @@  import Control.Applicative import Control.Monad                                                ( void )-import Data.Typeable import Prelude  @@ -60,16 +61,18 @@ -- that are mapped to the magic index 'ignore' are dropped. -- mkPermute-    :: (Shape sh, Shape sh', Elt e)+    :: HasCallStack     => UID-    -> Gamma aenv+    -> Gamma               aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'     -> IRPermuteFun Native aenv (e -> e -> e)-    -> IRFun1       Native aenv (sh -> sh')-    -> IRDelayed    Native aenv (Array sh e)-    -> CodeGen (IROpenAcc Native aenv (Array sh' e))-mkPermute uid aenv combine project arr =-  (+++) <$> mkPermuteS uid aenv combine project arr-        <*> mkPermuteP uid aenv combine project arr+    -> IRFun1       Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed   Native aenv (Array sh e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array sh' e))+mkPermute uid aenv repr shr combine project arr =+  (+++) <$> mkPermuteS uid aenv repr shr combine project arr+        <*> mkPermuteP uid aenv repr shr combine project arr   -- Forward permutation which does not require locking the output array. This@@ -81,37 +84,39 @@ -- co-domain). -- mkPermuteS-    :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)-    => UID-    -> Gamma aenv+    :: UID+    -> Gamma               aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'     -> IRPermuteFun Native aenv (e -> e -> e)-    -> IRFun1       Native aenv (sh -> sh')-    -> IRDelayed    Native aenv (Array sh e)-    -> CodeGen (IROpenAcc Native aenv (Array sh' e))-mkPermuteS uid aenv IRPermuteFun{..} project IRDelayed{..} =+    -> IRFun1       Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed   Native aenv (Array sh e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array sh' e))+mkPermuteS uid aenv repr shr IRPermuteFun{..} project marr =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array sh' e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    (arrayRshape repr)+      (arrOut, paramOut)      = mutableArray (reprOut repr shr) "out"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv   in-  makeOpenAcc uid "permuteS" (paramGang ++ paramOut ++ paramEnv) $ do+  makeOpenAcc uid "permuteS" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do -    sh <- delayedExtent+    sh <- delayedExtent arrIn -    imapFromTo start end $ \i -> do+    imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do -      ix  <- indexOfInt sh i       ix' <- app1 project ix -      unless (ignore ix') $ do-        j <- intOfIndex (irArrayShape arrOut) ix'+      when (isJust ix') $ do+        i <- fromJust ix'+        j <- intOfIndex shr (irArrayShape arrOut) i          -- project element onto the destination array and update-        x <- app1 delayedLinearIndex i-        y <- readArray arrOut j+        x <- app1 (delayedIndex arrIn) ix+        y <- readArray TypeInt arrOut j         r <- app2 combine x y -        writeArray arrOut j r+        writeArray TypeInt arrOut j r      return_ @@ -127,71 +132,79 @@ -- a queue or some such. -- mkPermuteP-    :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)+    :: HasCallStack     => UID-    -> Gamma aenv+    -> Gamma               aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'     -> IRPermuteFun Native aenv (e -> e -> e)-    -> IRFun1       Native aenv (sh -> sh')-    -> IRDelayed    Native aenv (Array sh e)-    -> CodeGen (IROpenAcc Native aenv (Array sh' e))-mkPermuteP uid aenv IRPermuteFun{..} project arr =+    -> IRFun1       Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed   Native aenv (Array sh e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array sh' e))+mkPermuteP uid aenv repr shr IRPermuteFun{..} project arr =   case atomicRMW of-    Nothing       -> mkPermuteP_mutex uid aenv combine project arr-    Just (rmw, f) -> mkPermuteP_rmw   uid aenv rmw f   project arr+    Nothing       -> mkPermuteP_mutex uid aenv repr shr combine project arr+    Just (rmw, f) -> mkPermuteP_rmw   uid aenv repr shr rmw f   project arr   -- Parallel forward permutation function which uses atomic instructions to -- implement lock-free array updates. -- mkPermuteP_rmw-    :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)+    :: HasCallStack     => UID     -> Gamma aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'     -> RMWOperation-    -> IRFun1    Native aenv (e -> e)-    -> IRFun1    Native aenv (sh -> sh')-    -> IRDelayed Native aenv (Array sh e)-    -> CodeGen (IROpenAcc Native aenv (Array sh' e))-mkPermuteP_rmw uid aenv rmw update project IRDelayed{..} =+    -> IRFun1     Native aenv (e -> e)+    -> IRFun1     Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed Native aenv (Array sh e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array sh' e))+mkPermuteP_rmw uid aenv repr shr rmw update project marr =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array sh' e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    (arrayRshape repr)+      (arrOut, paramOut)      = mutableArray (reprOut repr shr) "out"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv   in-  makeOpenAcc uid "permuteP_rmw" (paramGang ++ paramOut ++ paramEnv) $ do+  makeOpenAcc uid "permuteP_rmw" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do -    sh <- delayedExtent+    sh <- delayedExtent arrIn -    imapFromTo start end $ \i -> do+    imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do -      ix  <- indexOfInt sh i       ix' <- app1 project ix -      unless (ignore ix') $ do-        j <- intOfIndex (irArrayShape arrOut) ix'-        x <- app1 delayedLinearIndex i+      when (isJust ix') $ do+        i <- fromJust ix'+        j <- intOfIndex shr (irArrayShape arrOut) i+        x <- app1 (delayedIndex arrIn) ix         r <- app1 update x          case rmw of           Exchange-            -> writeArray arrOut j r+            -> writeArray TypeInt arrOut j r           ---          _ | TypeRscalar (SingleScalarType s)  <- eltType (undefined::e)-            , Just adata                        <- gcast (irArrayData arrOut)-            , Just r'                           <- gcast r+          _ | TupRsingle (SingleScalarType s)   <- arrayRtype repr+            , adata                             <- irArrayData arrOut             -> do                   addr <- instr' $ GetElementPtr (asPtr defaultAddrSpace (op s adata)) [op integralType j]                   --                   case s of-                    NumSingleType (IntegralNumType t) -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r') (CrossThread, AcquireRelease)-                    NumSingleType t | RMW.Add <- rmw  -> atomicCAS_rmw s (A.add t r') addr-                    NumSingleType t | RMW.Sub <- rmw  -> atomicCAS_rmw s (A.sub t r') addr-                    _ -> case rmw of-                           RMW.Min                    -> atomicCAS_cmp s A.lt addr (op s r')-                           RMW.Max                    -> atomicCAS_cmp s A.gt addr (op s r')-                           _                          -> $internalError "mkPermute_rmw" "unexpected transition"+#if MIN_VERSION_llvm_hs(10,0,0)+                    NumSingleType t             -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r) (CrossThread, AcquireRelease)+#else+                    NumSingleType t+                      | IntegralNumType{} <- t  -> void . instr' $ AtomicRMW t NonVolatile rmw addr (op t r) (CrossThread, AcquireRelease)+                      | RMW.Add <- rmw          -> atomicCAS_rmw s (A.add t r) addr+                      | RMW.Sub <- rmw          -> atomicCAS_rmw s (A.sub t r) addr+#endif+                    _ | RMW.Min <- rmw          -> atomicCAS_cmp s A.lt addr (op s r)+                      | RMW.Max <- rmw          -> atomicCAS_cmp s A.gt addr (op s r)+                    _                           -> internalError "unexpected transition"           ---          _ -> $internalError "mkPermute_rmw" "unexpected transition"+          _ -> internalError "unexpected transition"      return_ @@ -200,38 +213,40 @@ -- a mutex before updating the value at that location. -- mkPermuteP_mutex-    :: forall aenv sh sh' e. (Shape sh, Shape sh', Elt e)-    => UID-    -> Gamma aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRFun1    Native aenv (sh -> sh')-    -> IRDelayed Native aenv (Array sh e)-    -> CodeGen (IROpenAcc Native aenv (Array sh' e))-mkPermuteP_mutex uid aenv combine project IRDelayed{..} =+    :: UID+    -> Gamma             aenv+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRFun1     Native aenv (sh -> PrimMaybe sh')+    -> MIRDelayed Native aenv (Array sh e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array sh' e))+mkPermuteP_mutex uid aenv repr shr combine project marr =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out"  :: Name (Array sh' e))-      (arrLock, paramLock)      = mutableArray ("lock" :: Name (Vector Word8))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    (arrayRshape repr)+      (arrOut,  paramOut)     = mutableArray (reprOut repr shr)  "out"+      (arrLock, paramLock)    = mutableArray reprLock "lock"+      (arrIn,   paramIn)      = delayedArray "in" marr+      paramEnv                = envParam aenv   in-  makeOpenAcc uid "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramEnv) $ do+  makeOpenAcc uid "permuteP_mutex" (paramGang ++ paramOut ++ paramLock ++ paramIn ++ paramEnv) $ do -    sh <- delayedExtent+    sh <- delayedExtent arrIn -    imapFromTo start end $ \i -> do+    imapNestFromTo (arrayRshape repr) start end sh $ \ix _ -> do -      ix  <- indexOfInt sh i       ix' <- app1 project ix        -- project element onto the destination array and (atomically) update-      unless (ignore ix') $ do-        j <- intOfIndex (irArrayShape arrOut) ix'-        x <- app1 delayedLinearIndex i+      when (isJust ix') $ do+        i <- fromJust ix'+        j <- intOfIndex shr (irArrayShape arrOut) i+        x <- app1 (delayedIndex arrIn) ix          atomically arrLock j $ do-          y <- readArray arrOut j+          y <- readArray TypeInt arrOut j           r <- app2 combine x y-          writeArray arrOut j r+          writeArray TypeInt arrOut j r      return_ @@ -249,14 +264,14 @@ -- atomically     :: IRArray (Vector Word8)-    -> IR Int-    -> CodeGen a-    -> CodeGen a+    -> Operands Int+    -> CodeGen Native a+    -> CodeGen Native a atomically barriers i action = do   let       lock      = integral integralType 1       unlock    = integral integralType 0-      unlocked  = lift 0+      unlocked  = ir TypeWord8 unlock   --   spin <- newBlock "spinlock.entry"   crit <- newBlock "spinlock.critical-section"@@ -269,7 +284,7 @@   -- was unlocked we just acquired it, otherwise the state remains unchanged and   -- we spin until it becomes available.   setBlock spin-  old  <- instr $ AtomicRMW integralType NonVolatile Exchange addr lock   (CrossThread, Acquire)+  old  <- instr $ AtomicRMW numType NonVolatile Exchange addr lock   (CrossThread, Acquire)   ok   <- A.eq singleType old unlocked   _    <- cbr ok crit spin @@ -279,7 +294,7 @@   -- rules.   setBlock crit   r    <- action-  _    <- instr $ AtomicRMW integralType NonVolatile Exchange addr unlock (CrossThread, Release)+  _    <- instr $ AtomicRMW numType NonVolatile Exchange addr unlock (CrossThread, Release)   _    <- br exit    setBlock exit@@ -289,18 +304,9 @@ -- Helper functions -- ---------------- --- Test whether the given index is the magic value 'ignore'. This operates--- strictly rather than performing short-circuit (&&).----ignore :: forall ix. Shape ix => IR ix -> CodeGen (IR Bool)-ignore (IR ix) = go (S.eltType (undefined::ix)) (S.fromElt (S.ignore::ix)) ix-  where-    go :: TupleType t -> t -> Operands t -> CodeGen (IR Bool)-    go TypeRunit           ()          OP_Unit        = return (lift True)-    go (TypeRpair tsh tsz) (ish, isz) (OP_Pair sh sz) = do x <- go tsh ish sh-                                                           y <- go tsz isz sz-                                                           land' x y-    go (TypeRscalar s)     ig         sz              = case s of-                                                          SingleScalarType t -> A.eq t (ir t (single t ig)) (ir t (op' t sz))-                                                          VectorScalarType{} -> $internalError "ignore" "unexpected shape type"+reprOut :: ArrayR (Array sh e) -> ShapeR sh' -> ArrayR (Array sh' e)+reprOut (ArrayR _ tp) shr = ArrayR shr tp++reprLock :: ArrayR (Array ((), Int) Word8)+reprLock = ArrayR (ShapeRsnoc ShapeRz) $ TupRsingle scalarTypeWord8 

@@ -3,14 +3,15 @@ {-# LANGUAGE RebindableSyntax    #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeOperators       #-} {-# LANGUAGE ViewPatterns        #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Scan--- Copyright   : [2014..2017] Trevor L. McDonell+-- Copyright   : [2014..2020] The Accelerate Team -- 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,18 +19,17 @@ module Data.Array.Accelerate.LLVM.Native.CodeGen.Scan   where --- accelerate-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.AST                                    ( Direction(..) )+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type -import Data.Array.Accelerate.LLVM.Analysis.Match import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic                as A import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base import Data.Array.Accelerate.LLVM.CodeGen.Environment import Data.Array.Accelerate.LLVM.CodeGen.Exp-import Data.Array.Accelerate.LLVM.CodeGen.IR                        ( IR ) import Data.Array.Accelerate.LLVM.CodeGen.Loop import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar@@ -47,59 +47,34 @@ import Prelude                                                      as P  -data Direction = L | R---- 'Data.List.scanl' style left-to-right exclusive scan, but with the--- restriction that the combination function must be associative to enable--- efficient parallel implementation.+-- 'Data.List.scanl' or 'Data.List.scanl1' style exclusive scan,+-- but with the restriction that the combination function must be associative+-- to enable efficient parallel implementation. -- -- > scanl (+) 10 (use $ fromList (Z :. 10) [0..]) -- > -- > ==> Array (Z :. 11) [10,10,11,13,16,20,25,31,38,46,55] ---mkScanl-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRExp     Native aenv e-    -> IRDelayed Native aenv (Array (sh:.Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e))-mkScanl uid aenv combine seed arr-  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)-  = foldr1 (+++) <$> sequence [ mkScanS L uid aenv combine (Just seed) arr-                              , mkScanP L uid aenv combine (Just seed) arr-                              , mkScanFill uid aenv seed-                              ]-  ---  | otherwise-  = (+++) <$> mkScanS L uid aenv combine (Just seed) arr-          <*> mkScanFill uid aenv seed----- 'Data.List.scanl1' style left-to-right inclusive scan, but with the--- restriction that the combination function must be associative to enable--- efficient parallel implementation. The array must not be empty.------ > scanl1 (+) (use $ fromList (Z :. 10) [0..])--- >--- > ==> Array (Z :. 10) [0,1,3,6,10,15,21,28,36,45]----mkScanl1-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRDelayed Native aenv (Array (sh:.Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e))-mkScanl1 uid aenv combine arr-  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)-  = (+++) <$> mkScanS L uid aenv combine Nothing arr-          <*> mkScanP L uid aenv combine Nothing arr-  ---  | otherwise-  = mkScanS L uid aenv combine Nothing arr-+mkScan+    :: UID+    -> Gamma             aenv+    -> ArrayR                   (Array (sh, Int) e)+    -> Direction+    -> IRFun2       Native aenv (e -> e -> e)+    -> Maybe (IRExp Native aenv e)+    -> MIRDelayed   Native aenv (Array (sh, Int) e)+    -> CodeGen      Native      (IROpenAcc Native aenv (Array (sh, Int) e))+mkScan uid aenv aR dir combine seed arr+  = foldr1 (+++) <$> sequence (codeScanS ++ codeScanP ++ codeScanFill)+  where+    codeScanS = [ mkScanS dir uid aenv aR combine seed arr ]+    codeScanP = case aR of+      ArrayR (ShapeRsnoc ShapeRz) eR -> [ mkScanP dir uid aenv eR combine seed arr ]+      _                              -> []+    -- Input can be empty iff a seed is given. We then need to compile a fill kernel+    codeScanFill = case seed of+      Just s  -> [ mkScanFill uid aenv aR s ]+      Nothing -> []  -- Variant of 'scanl' where the final result is returned in a separate array. --@@ -109,126 +84,46 @@ --       , Array Z [55] --       ) ---mkScanl'-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRExp     Native aenv e-    -> IRDelayed Native aenv (Array (sh:.Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e))-mkScanl' uid aenv combine seed arr-  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)-  = foldr1 (+++) <$> sequence [ mkScan'S L uid aenv combine seed arr-                              , mkScan'P L uid aenv combine seed arr-                              , mkScan'Fill uid aenv seed-                              ]-  ---  | otherwise-  = (+++) <$> mkScan'S L uid aenv combine seed arr-          <*> mkScan'Fill uid aenv seed----- 'Data.List.scanr' style right-to-left exclusive scan, but with the--- restriction that the combination function must be associative to enable--- efficient parallel implementation.------ > scanr (+) 10 (use $ fromList (Z :. 10) [0..])--- >--- > ==> Array (Z :. 11) [55,55,54,52,49,45,40,34,27,19,10]----mkScanr-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRExp     Native aenv e-    -> IRDelayed Native aenv (Array (sh:.Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e))-mkScanr uid aenv combine seed arr-  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)-  = foldr1 (+++) <$> sequence [ mkScanS R uid aenv combine (Just seed) arr-                              , mkScanP R uid aenv combine (Just seed) arr-                              , mkScanFill uid aenv seed-                              ]-  ---  | otherwise-  = (+++) <$> mkScanS R uid aenv combine (Just seed) arr-          <*> mkScanFill uid aenv seed----- 'Data.List.scanr1' style right-to-left inclusive scan, but with the--- restriction that the combination function must be associative to enable--- efficient parallel implementation. The array must not be empty.------ > scanr (+) 10 (use $ fromList (Z :. 10) [0..])--- >--- > ==> Array (Z :. 10) [45,45,44,42,39,35,30,24,17,9]----mkScanr1-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRDelayed Native aenv (Array (sh:.Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e))-mkScanr1 uid aenv combine arr-  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)-  = (+++) <$> mkScanS R uid aenv combine Nothing arr-          <*> mkScanP R uid aenv combine Nothing arr-  ---  | otherwise-  = mkScanS R uid aenv combine Nothing arr----- Variant of 'scanr' where the final result is returned in a separate array.------ > scanr' (+) 10 (use $ fromList (Z :. 10) [0..])--- >--- > ==> ( Array (Z :. 10) [55,54,52,49,45,40,34,27,19,10]---       , Array Z [55]---       )----mkScanr'-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID-    -> Gamma            aenv-    -> IRFun2    Native aenv (e -> e -> e)-    -> IRExp     Native aenv e-    -> IRDelayed Native aenv (Array (sh:.Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e))-mkScanr' uid aenv combine seed arr-  | Just Refl <- matchShapeType (undefined::sh) (undefined::Z)-  = foldr1 (+++) <$> sequence [ mkScan'S R uid aenv combine seed arr-                              , mkScan'P R uid aenv combine seed arr-                              , mkScan'Fill uid aenv seed+mkScan'+    :: UID+    -> Gamma             aenv+    -> ArrayR                 (Array (sh, Int) e)+    -> Direction+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRExp      Native aenv e+    -> MIRDelayed Native aenv (Array (sh, Int) e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh, Int) e, Array sh e))+mkScan' uid aenv aR dir combine seed arr+  | ArrayR (ShapeRsnoc ShapeRz) eR <- aR+  = foldr1 (+++) <$> sequence [ mkScan'S dir uid aenv aR combine seed arr+                              , mkScan'P dir uid aenv eR combine seed arr+                              , mkScan'Fill uid aenv aR seed                               ]   --   | otherwise-  = (+++) <$> mkScan'S R uid aenv combine seed arr-          <*> mkScan'Fill uid aenv seed-+  = (+++) <$> mkScan'S dir uid aenv aR combine seed arr+          <*> mkScan'Fill uid aenv aR seed  -- If the innermost dimension of an exclusive scan is empty, then we just fill -- the result with the seed element. -- mkScanFill-    :: (Shape sh, Elt e)-    => UID-    -> Gamma aenv-    -> IRExp Native aenv e-    -> CodeGen (IROpenAcc Native aenv (Array sh e))-mkScanFill uid aenv seed =-  mkGenerate uid aenv (IRFun1 (const seed))+    :: UID+    -> Gamma          aenv+    -> ArrayR (Array sh e)+    -> IRExp   Native aenv e+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkScanFill uid aenv aR seed =+  mkGenerate uid aenv aR (IRFun1 (const seed))  mkScan'Fill-    :: forall aenv sh e. (Shape sh, Elt e)-    => UID-    -> Gamma aenv-    -> IRExp Native aenv e-    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e))-mkScan'Fill uid aenv seed =-  Safe.coerce <$> (mkScanFill uid aenv seed :: CodeGen (IROpenAcc Native aenv (Array sh e)))+    :: UID+    -> Gamma          aenv+    -> ArrayR (Array (sh, Int) e)+    -> IRExp   Native aenv e+    -> CodeGen Native     (IROpenAcc Native aenv (Array (sh, Int) e, Array sh e))+mkScan'Fill uid aenv aR seed =+  Safe.coerce <$> mkScanFill uid aenv (reduceRank aR) seed   -- A single thread sequentially scans along an entire innermost dimension. For@@ -239,162 +134,159 @@ -- where threads are scheduled over the outer dimensions (segments). -- mkScanS-    :: forall aenv sh e. Elt e-    => Direction+    :: Direction     -> UID-    -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> Maybe (IRExp Native aenv e)-    -> IRDelayed Native aenv (Array (sh:.Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e))-mkScanS dir uid aenv combine mseed IRDelayed{..} =+    -> Gamma             aenv+    -> ArrayR (Array (sh, Int) e)+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Array (sh, Int) e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh, Int) e))+mkScanS dir uid aenv aR combine mseed marr =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array (sh:.Int) e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam shR+      (arrOut, paramOut)      = mutableArray aR "out"+      (arrIn,  paramIn)       = delayedArray    "in"  marr+      paramEnv                = envParam aenv+      ShapeRsnoc shR          = arrayRshape aR       ---      next i                    = case dir of-                                    L -> A.add numType i (lift 1)-                                    R -> A.sub numType i (lift 1)+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)   in-  makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramEnv) $ do+  makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do -    sz    <- indexHead <$> delayedExtent-    szp1  <- A.add numType sz (lift 1)-    szm1  <- A.sub numType sz (lift 1)+    -- The dimensions of the input and output arrays are (almost) the same+    -- but LLVM can't know that so make it explicit so that we reuse loop+    -- variables and index calculations+    shIn <- delayedExtent arrIn+    let sz    = indexHead shIn+        shOut = case mseed of+                  Nothing -> shIn+                  Just{}  -> indexCons (indexTail shIn) (indexHead (irArrayShape arrOut)) -    -- loop over each lower-dimensional index (segment)-    imapFromTo start end $ \seg -> do+    -- Loop over the outer dimensions+    imapNestFromTo shR start end (indexTail shIn) $ \ix _ -> do        -- index i* is the index that we will read data from. Recall that the       -- supremum index is exclusive       i0 <- case dir of-              L -> A.mul numType sz seg-              R -> do x <- A.mul numType sz seg-                      y <- A.add numType szm1 x-                      return y+              LeftToRight -> return (liftInt 0)+              RightToLeft -> A.sub numType sz (liftInt 1)        -- index j* is the index that we write to. Recall that for exclusive scans       -- the output array inner dimension is one larger than the input.       j0 <- case mseed of               Nothing -> return i0        -- merge 'i' and 'j' indices whenever we can               Just{}  -> case dir of-                           L -> A.mul numType szp1 seg-                           R -> do x <- A.mul numType szp1 seg-                                   y <- A.add numType x sz-                                   return y+                           LeftToRight -> return i0+                           RightToLeft -> return sz        -- Evaluate or read the initial element. Update the read-from index       -- appropriately.       (v0,i1) <- case mseed of-                   Just seed -> (,) <$> seed                       <*> pure i0-                   Nothing   -> (,) <$> app1 delayedLinearIndex i0 <*> next i0+                   Just seed -> (,) <$> seed                                        <*> pure i0+                   Nothing   -> (,) <$> app1 (delayedIndex arrIn) (indexCons ix i0) <*> next i0 -      -- Write first element, then continue looping through the rest-      writeArray arrOut j0 v0+      -- Write first element, then continue looping through the rest of+      -- this innermost dimension+      k0 <- intOfIndex (arrayRshape aR) shOut (indexCons ix j0)       j1 <- next j0--      iz <- case dir of-              L -> A.add numType i0 sz-              R -> A.sub numType i0 sz--      let cont i = case dir of-                     L -> A.lt singleType i iz-                     R -> A.gt singleType i iz+      writeArray TypeInt arrOut k0 v0 -      void $ while (cont . A.fst3)-                   (\(A.untrip -> (i,j,v)) -> do-                       u  <- app1 delayedLinearIndex i-                       v' <- case dir of-                               L -> app2 combine v u-                               R -> app2 combine u v-                       writeArray arrOut j v'-                       A.trip <$> next i <*> next j <*> pure v')+      void $ while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` arrayRtype aR)+                   (\(A.untrip -> (i,_,_)) -> do+                       case dir of+                         LeftToRight -> A.lt  singleType i sz+                         RightToLeft -> A.gte singleType i (liftInt 0))+                   (\(A.untrip -> (i,j,u)) -> do+                       v <- app1 (delayedIndex arrIn) (indexCons ix i)+                       w <- case dir of+                              LeftToRight -> app2 combine u v+                              RightToLeft -> app2 combine v u+                       k <- intOfIndex (arrayRshape aR) shOut (indexCons ix j)+                       writeArray TypeInt arrOut k w+                       A.trip <$> next i <*> next j <*> pure w)                    (A.trip i1 j1 v0)      return_   mkScan'S-    :: forall aenv sh e. (Shape sh, Elt e)-    => Direction+    :: Direction     -> UID-    -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> IRExp Native aenv e-    -> IRDelayed Native aenv (Array (sh:.Int) e)-    -> CodeGen (IROpenAcc Native aenv (Array (sh:.Int) e, Array sh e))-mkScan'S dir uid aenv combine seed IRDelayed{..} =+    -> Gamma             aenv+    -> ArrayR (Array (sh, Int) e)+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRExp      Native aenv e+    -> MIRDelayed Native aenv (Array (sh, Int) e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Array (sh, Int) e, Array sh e))+mkScan'S dir uid aenv aR combine seed marr =   let-      (start, end, paramGang)   = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Array (sh:.Int) e))-      (arrSum, paramSum)        = mutableArray ("sum" :: Name (Array sh e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    shR+      (arrOut, paramOut)      = mutableArray aR              "out"+      (arrSum, paramSum)      = mutableArray (reduceRank aR) "sum"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv+      ShapeRsnoc shR          = arrayRshape aR       ---      next i                    = case dir of-                                    L -> A.add numType i (lift 1)-                                    R -> A.sub numType i (lift 1)+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)   in-  makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramSum ++ paramEnv) $ do+  makeOpenAcc uid "scanS" (paramGang ++ paramOut ++ paramSum ++ paramIn ++ paramEnv) $ do -    sz    <- indexHead <$> delayedExtent-    szm1  <- A.sub numType sz (lift 1)+    shIn  <- delayedExtent arrIn+    let sz    = indexHead shIn+        shOut = shIn -    -- iterate over each lower-dimensional index (segment)-    imapFromTo start end $ \seg -> do+    imapNestFromTo shR start end (indexTail shIn) $ \ix ii -> do        -- index to read data from       i0 <- case dir of-              L -> A.mul numType seg sz-              R -> do x <- A.mul numType sz seg-                      y <- A.add numType x szm1-                      return y+              LeftToRight -> return (liftInt 0)+              RightToLeft -> A.sub numType sz (liftInt 1)        -- initial element       v0 <- seed -      iz <- case dir of-              L -> A.add numType i0 sz-              R -> A.sub numType i0 sz--      let cont i  = case dir of-                      L -> A.lt singleType i iz-                      R -> A.gt singleType i iz-       -- Loop through the input. Only at the top of the loop to we write the       -- carry-in value (i.e. value from the last loop iteration) to the output       -- array. This ensures correct behaviour if the input array was empty.-      r  <- while (cont . A.fst)-                  (\(A.unpair -> (i,v)) -> do-                      writeArray arrOut i v+      r  <- while (TupRsingle scalarTypeInt `TupRpair` arrayRtype aR)+                  (\(A.unpair -> (i,_)) -> do+                      case dir of+                        LeftToRight -> A.lt  singleType i sz+                        RightToLeft -> A.gte singleType i (liftInt 0))+                  (\(A.unpair -> (i,u)) -> do+                      k <- intOfIndex (arrayRshape aR) shOut (indexCons ix i)+                      writeArray TypeInt arrOut k u -                      u  <- app1 delayedLinearIndex i-                      v' <- case dir of-                              L -> app2 combine v u-                              R -> app2 combine u v-                      i' <- next i-                      return $ A.pair i' v')+                      v <- app1 (delayedIndex arrIn) (indexCons ix i)+                      w <- case dir of+                             LeftToRight -> app2 combine u v+                             RightToLeft -> app2 combine v u+                      A.pair <$> next i <*> pure w)                   (A.pair i0 v0) -      -- write final reduction result-      writeArray arrSum seg (A.snd r)+      writeArray TypeInt arrSum ii (A.snd r)      return_   mkScanP-    :: forall aenv e. Elt e-    => Direction+    :: Direction     -> UID-    -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> Maybe (IRExp Native aenv e)-    -> IRDelayed Native aenv (Vector e)-    -> CodeGen (IROpenAcc Native aenv (Vector e))-mkScanP dir uid aenv combine mseed arr =-  foldr1 (+++) <$> sequence [ mkScanP1 dir uid aenv combine mseed arr-                            , mkScanP2 dir uid aenv combine-                            , mkScanP3 dir uid aenv combine mseed+    -> Gamma             aenv+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Vector e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Vector e))+mkScanP dir uid aenv eR combine mseed marr =+  foldr1 (+++) <$> sequence [ mkScanP1 dir uid aenv eR combine mseed marr+                            , mkScanP2 dir uid aenv eR combine+                            , mkScanP3 dir uid aenv eR combine mseed                             ]  -- Parallel scan, step 1.@@ -404,36 +296,35 @@ -- result of this chunk is written to a separate array. -- mkScanP1-    :: forall aenv e. Elt e-    => Direction+    :: Direction     -> UID-    -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> Maybe (IRExp Native aenv e)-    -> IRDelayed Native aenv (Vector e)-    -> CodeGen (IROpenAcc Native aenv (Vector e))-mkScanP1 dir uid aenv combine mseed IRDelayed{..} =+    -> Gamma             aenv+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)+    -> MIRExp     Native aenv e+    -> MIRDelayed Native aenv (Vector e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Vector e))+mkScanP1 dir uid aenv eR combine mseed marr =   let-      (chunk, _, paramGang)     = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Vector e))-      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim1 eR) "out"+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv       ---      steps                     = local           scalarType ("ix.steps"  :: Name Int)-      paramSteps                = scalarParameter scalarType ("ix.steps"  :: Name Int)-      stride                    = local           scalarType ("ix.stride" :: Name Int)-      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)+      steps                   = local     (TupRsingle scalarTypeInt) "ix.steps"+      paramSteps              = parameter (TupRsingle scalarTypeInt) "ix.steps"+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"       ---      next i                    = case dir of-                                    L -> A.add numType i (lift 1)-                                    R -> A.sub numType i (lift 1)-      firstChunk                = case dir of-                                    L -> lift 0-                                    R -> steps+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+      firstPiece              = case dir of+                                  LeftToRight -> liftInt 0+                                  RightToLeft -> steps   in-  makeOpenAcc uid "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do--    len <- indexHead <$> delayedExtent+  makeOpenAcc uid "scanP1" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramIn ++ paramEnv) $ do      -- A thread scans a non-empty stripe of the input, storing the final     -- reduction result into a separate array.@@ -441,59 +332,57 @@     -- For exclusive scans the first chunk must incorporate the initial element     -- into the input and output, while all other chunks increment their output     -- index by one.-    inf <- A.mul numType    chunk stride-    a   <- A.add numType    inf   stride-    sup <- A.min singleType a     len-+    --     -- index i* is the index that we read data from. Recall that the supremum     -- index is exclusive     i0  <- case dir of-             L -> return inf-             R -> next sup+             LeftToRight -> return (indexHead start)+             RightToLeft -> next (indexHead end)      -- index j* is the index that we write to. Recall that for exclusive scan-    -- the output array is one larger than the input; the first chunk uses+    -- the output array is one larger than the input; the first piece uses     -- this spot to write the initial element, all other chunks shift by one.     j0  <- case mseed of              Nothing -> return i0              Just _  -> case dir of-                          L -> if A.eq singleType chunk firstChunk-                                 then return i0-                                 else next i0-                          R -> if A.eq singleType chunk firstChunk-                                 then return sup-                                 else return i0+                          LeftToRight -> if (TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)+                                         then return i0+                                         else next i0+                          RightToLeft -> if (TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)+                                         then return (indexHead end)+                                         else return i0 -    -- Evaluate/read the initial element for this chunk. Update the read-from+    -- Evaluate/read the initial element for this piece. Update the read-from     -- index appropriately     (v0,i1) <- A.unpair <$> case mseed of-                 Just seed -> if A.eq singleType chunk firstChunk-                                then A.pair <$> seed                       <*> pure i0-                                else A.pair <$> app1 delayedLinearIndex i0 <*> next i0-                 Nothing   ->        A.pair <$> app1 delayedLinearIndex i0 <*> next i0+                 Just seed -> if (eR `TupRpair` TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)+                                then A.pair <$> seed                               <*> pure i0+                                else A.pair <$> app1 (delayedLinearIndex arrIn) i0 <*> next i0+                 Nothing   ->        A.pair <$> app1 (delayedLinearIndex arrIn) i0 <*> next i0      -- Write first element-    writeArray arrOut j0 v0+    writeArray TypeInt arrOut j0 v0     j1  <- next j0      -- Continue looping through the rest of the input     let cont i =            case dir of-             L -> A.lt  singleType i sup-             R -> A.gte singleType i inf+             LeftToRight -> A.lt  singleType i (indexHead end)+             RightToLeft -> A.gte singleType i (indexHead start) -    r   <- while (cont . A.fst3)+    r   <- while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` eR)+                 (cont . A.fst3)                  (\(A.untrip -> (i,j,v)) -> do-                     u  <- app1 delayedLinearIndex i+                     u  <- app1 (delayedLinearIndex arrIn) i                      v' <- case dir of-                             L -> app2 combine v u-                             R -> app2 combine u v-                     writeArray arrOut j v'+                             LeftToRight -> app2 combine v u+                             RightToLeft -> app2 combine u v+                     writeArray TypeInt arrOut j v'                      A.trip <$> next i <*> next j <*> pure v')                  (A.trip i1 j1 v0) -    -- Final reduction result of this chunk-    writeArray arrTmp chunk (A.thd3 r)+    -- Final reduction result of this piece+    writeArray TypeInt arrTmp piece (A.thd3 r)      return_ @@ -505,43 +394,44 @@ -- results in the final step. -- mkScanP2-    :: forall aenv e. Elt e-    => Direction+    :: Direction     -> UID-    -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> CodeGen (IROpenAcc Native aenv (Vector e))-mkScanP2 dir uid aenv combine =+    -> Gamma          aenv+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)+    -> CodeGen Native      (IROpenAcc Native aenv (Vector e))+mkScanP2 dir uid aenv eR combine =   let-      (start, end, paramGang)   = gangParam-      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    dim1+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      paramEnv                = envParam aenv       ---      cont i                    = case dir of-                                    L -> A.lt  singleType i end-                                    R -> A.gte singleType i start+      cont i                  = case dir of+                                  LeftToRight -> A.lt  singleType i (indexHead end)+                                  RightToLeft -> A.gte singleType i (indexHead start) -      next i                    = case dir of-                                    L -> A.add numType i (lift 1)-                                    R -> A.sub numType i (lift 1)+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)   in   makeOpenAcc uid "scanP2" (paramGang ++ paramTmp ++ paramEnv) $ do      i0 <- case dir of-            L -> return start-            R -> next end+            LeftToRight -> return (indexHead start)+            RightToLeft -> next (indexHead end) -    v0 <- readArray arrTmp i0+    v0 <- readArray TypeInt arrTmp i0     i1 <- next i0 -    void $ while (cont . A.fst)+    void $ while (TupRsingle scalarTypeInt `TupRpair` eR)+                 (cont . A.fst)                  (\(A.unpair -> (i,v)) -> do-                    u  <- readArray arrTmp i+                    u  <- readArray TypeInt arrTmp i                     i' <- next i                     v' <- case dir of-                            L -> app2 combine v u-                            R -> app2 combine u v-                    writeArray arrTmp i v'+                            LeftToRight -> app2 combine v u+                            RightToLeft -> app2 combine u v+                    writeArray TypeInt arrTmp i v'                     return $ A.pair i' v')                  (A.pair i1 v0) @@ -553,165 +443,158 @@ -- Threads combine every element of the partial block results with the carry-in -- value computed from step 2. ----- Note that we launch (chunks-1) threads, because the first chunk does not need--- extra processing (has no carry-in value).+-- Note that first chunk does not need extra processing (has no carry-in value). -- mkScanP3-    :: forall aenv e. Elt e-    => Direction+    :: Direction     -> UID     -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> Maybe (IRExp Native aenv e)-    -> CodeGen (IROpenAcc Native aenv (Vector e))-mkScanP3 dir uid aenv combine mseed =+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)+    -> MIRExp  Native aenv e+    -> CodeGen Native      (IROpenAcc Native aenv (Vector e))+mkScanP3 dir uid aenv eR combine mseed =   let-      (chunk, _, paramGang)     = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Vector e))-      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim1 eR) "out"+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      paramEnv                = envParam aenv       ---      stride                    = local           scalarType ("ix.stride" :: Name Int)-      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)+      steps                   = local     (TupRsingle scalarTypeInt) "ix.steps"+      paramSteps              = parameter (TupRsingle scalarTypeInt) "ix.steps"+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"       ---      next i                    = case dir of-                                    L -> A.add numType i (lift 1)-                                    R -> A.sub numType i (lift 1)-      prev i                    = case dir of-                                    L -> A.sub numType i (lift 1)-                                    R -> A.add numType i (lift 1)+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+      prev i                  = case dir of+                                  LeftToRight -> A.sub numType i (liftInt 1)+                                  RightToLeft -> A.add numType i (liftInt 1)+      firstPiece              = case dir of+                                  LeftToRight -> liftInt 0+                                  RightToLeft -> steps   in-  makeOpenAcc uid "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do--    -- Determine which chunk will be carrying in values for. Compute appropriate-    -- start and end indices.-    a     <- case dir of-               L -> next chunk-               R -> pure chunk+  makeOpenAcc uid "scanP3" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramEnv) $ do -    b     <- A.mul numType    a stride-    c     <- A.add numType    b stride-    d     <- A.min singleType c (indexHead (irArrayShape arrOut))+    -- TODO: Don't schedule the "first" piece. In the scheduler this corresponds+    -- to the split range with the smallest/largest linear index for left/right+    -- scans respectively. For right scans this is not necessarily the last piece(?).+    --+    A.when (neq singleType piece firstPiece) $ do -    (inf,sup) <- case (dir,mseed) of-                   (L,Just _) -> (,) <$> next b <*> next d-                   _          -> (,) <$> pure b <*> pure d+      -- Compute start and end indices, leaving space for the initial element+      (inf,sup) <- case (dir, mseed) of+                     (LeftToRight, Just{}) -> (,) <$> next (indexHead start) <*> next (indexHead end)+                     _                     -> (,) <$> pure (indexHead start) <*> pure (indexHead end) -    -- Carry in value from the previous chunk-    e     <- case dir of-               L -> pure chunk-               R -> prev chunk-    carry <- readArray arrTmp e+      -- Read in the carry in value for this piece+      c <- readArray TypeInt arrTmp =<< prev piece -    imapFromTo inf sup $ \i -> do-      x <- readArray arrOut i-      y <- case dir of-             L -> app2 combine carry x-             R -> app2 combine x carry-      writeArray arrOut i y+      imapFromTo inf sup $ \i -> do+        x <- readArray TypeInt arrOut i+        y <- case dir of+               LeftToRight -> app2 combine c x+               RightToLeft -> app2 combine x c+        writeArray TypeInt arrOut i y      return_   mkScan'P-    :: forall aenv e. Elt e-    => Direction+    :: Direction     -> UID-    -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> IRExp Native aenv e-    -> IRDelayed Native aenv (Vector e)-    -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e))-mkScan'P dir uid aenv combine seed arr =-  foldr1 (+++) <$> sequence [ mkScan'P1 dir uid aenv combine seed arr-                            , mkScan'P2 dir uid aenv combine-                            , mkScan'P3 dir uid aenv combine+    -> Gamma             aenv+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRExp      Native aenv e+    -> MIRDelayed Native aenv (Vector e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P dir uid aenv eR combine seed arr =+  foldr1 (+++) <$> sequence [ mkScan'P1 dir uid aenv eR combine seed arr+                            , mkScan'P2 dir uid aenv eR combine+                            , mkScan'P3 dir uid aenv eR combine                             ]  -- Parallel scan', step 1 -- -- Threads scan a stripe of the input into a temporary array. Similar to--- exclusive scan, but since the size of the output array is the same as the--- input, input and output indices are shifted by one.+-- exclusive scan, the output indices are shifted by one relative to the input+-- indices to make space for the initial element. -- mkScan'P1-    :: forall aenv e. Elt e-    => Direction+    :: Direction     -> UID-    -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> IRExp Native aenv e-    -> IRDelayed Native aenv (Vector e)-    -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e))-mkScan'P1 dir uid aenv combine seed IRDelayed{..} =+    -> Gamma             aenv+    -> TypeR e+    -> IRFun2     Native aenv (e -> e -> e)+    -> IRExp      Native aenv e+    -> MIRDelayed Native aenv (Vector e)+    -> CodeGen    Native      (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P1 dir uid aenv eR combine seed marr =   let-      (chunk, _, paramGang)     = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Vector e))-      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim1 eR) "out"+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrIn,  paramIn)       = delayedArray "in" marr+      paramEnv                = envParam aenv       ---      steps                     = local           scalarType ("ix.steps"  :: Name Int)-      paramSteps                = scalarParameter scalarType ("ix.steps"  :: Name Int)-      stride                    = local           scalarType ("ix.stride" :: Name Int)-      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)+      steps                   = local     (TupRsingle scalarTypeInt) "ix.steps"+      paramSteps              = parameter (TupRsingle scalarTypeInt) "ix.steps"+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"       ---      next i                    = case dir of-                                    L -> A.add numType i (lift 1)-                                    R -> A.sub numType i (lift 1)+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1) -      firstChunk                = case dir of-                                    L -> lift 0-                                    R -> steps+      firstPiece              = case dir of+                                  LeftToRight -> liftInt 0+                                  RightToLeft -> steps   in-  makeOpenAcc uid "scanP1" (paramGang ++ paramStride : paramSteps : paramOut ++ paramTmp ++ paramEnv) $ do--    -- Compute the start and end indices for this non-empty chunk of the input.-    ---    len <- indexHead <$> delayedExtent-    inf <- A.mul numType    chunk stride-    a   <- A.add numType    inf   stride-    sup <- A.min singleType a     len+  makeOpenAcc uid "scanP1" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramIn ++ paramEnv) $ do      -- index i* is the index that we pull data from.     i0 <- case dir of-            L -> return inf-            R -> next sup+            LeftToRight -> return (indexHead start)+            RightToLeft -> next (indexHead end) -    -- index j* is the index that we write results to. The first chunk needs to+    -- index j* is the index that we write results to. The first piece needs to     -- include the initial element, and all other chunks shift their results     -- across by one to make space.-    j0      <- if A.eq singleType chunk firstChunk+    j0      <- if (TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)                  then pure i0                  else next i0      -- Evaluate/read the initial element. Update the read-from index     -- appropriately.-    (v0,i1) <- A.unpair <$> if A.eq singleType chunk firstChunk-                              then A.pair <$> seed                       <*> pure i0-                              else A.pair <$> app1 delayedLinearIndex i0 <*> pure j0+    (v0,i1) <- A.unpair <$> if (eR `TupRpair` TupRsingle scalarTypeInt, A.eq singleType piece firstPiece)+                              then A.pair <$> seed                               <*> pure i0+                              else A.pair <$> app1 (delayedLinearIndex arrIn) i0 <*> pure j0      -- Write the first element-    writeArray arrOut j0 v0+    writeArray TypeInt arrOut j0 v0     j1 <- next j0      -- Continue looping through the rest of the input     let cont i =            case dir of-             L -> A.lt  singleType i sup-             R -> A.gte singleType i inf+             LeftToRight -> A.lt  singleType i (indexHead end)+             RightToLeft -> A.gte singleType i (indexHead start) -    r  <- while (cont . A.fst3)+    r  <- while (TupRunit `TupRpair` TupRsingle scalarTypeInt `TupRpair` TupRsingle scalarTypeInt `TupRpair` eR)+                (cont . A.fst3)                 (\(A.untrip-> (i,j,v)) -> do-                    u  <- app1 delayedLinearIndex i+                    u  <- app1 (delayedLinearIndex arrIn) i                     v' <- case dir of-                            L -> app2 combine v u-                            R -> app2 combine u v-                    writeArray arrOut j v'+                            LeftToRight -> app2 combine v u+                            RightToLeft -> app2 combine u v+                    writeArray TypeInt arrOut j v'                     A.trip <$> next i <*> next j <*> pure v')                 (A.trip i1 j1 v0) -    -- Write the final reduction result of this chunk-    writeArray arrTmp chunk (A.thd3 r)+    -- Write the final reduction result of this piece+    writeArray TypeInt arrTmp piece (A.thd3 r)      return_ @@ -722,48 +605,49 @@ -- array (rather than discard it). -- mkScan'P2-    :: forall aenv e. Elt e-    => Direction+    :: Direction     -> UID-    -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e))-mkScan'P2 dir uid aenv combine =+    -> Gamma          aenv+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)+    -> CodeGen Native      (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P2 dir uid aenv eR combine =   let-      (start, end, paramGang)   = gangParam-      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))-      (arrSum, paramSum)        = mutableArray ("sum" :: Name (Scalar e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    dim1+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      (arrSum, paramSum)      = mutableArray (ArrayR dim0 eR) "sum"+      paramEnv                = envParam aenv       ---      cont i                    = case dir of-                                    L -> A.lt  singleType i end-                                    R -> A.gte singleType i start+      cont i                  = case dir of+                                  LeftToRight -> A.lt  singleType i (indexHead end)+                                  RightToLeft -> A.gte singleType i (indexHead start) -      next i                    = case dir of-                                    L -> A.add numType i (lift 1)-                                    R -> A.sub numType i (lift 1)+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)   in   makeOpenAcc uid "scanP2" (paramGang ++ paramSum ++ paramTmp ++ paramEnv) $ do      i0 <- case dir of-            L -> return start-            R -> next end+            LeftToRight -> return (indexHead start)+            RightToLeft -> next (indexHead end) -    v0 <- readArray arrTmp i0+    v0 <- readArray TypeInt arrTmp i0     i1 <- next i0 -    r  <- while (cont . A.fst)+    r  <- while (TupRpair (TupRsingle scalarTypeInt) eR)+                (cont . A.fst)                 (\(A.unpair -> (i,v)) -> do-                   u  <- readArray arrTmp i+                   u  <- readArray TypeInt arrTmp i                    i' <- next i                    v' <- case dir of-                           L -> app2 combine v u-                           R -> app2 combine u v-                   writeArray arrTmp i v'+                           LeftToRight -> app2 combine v u+                           RightToLeft -> app2 combine u v+                   writeArray TypeInt arrTmp i v'                    return $ A.pair i' v')                 (A.pair i1 v0) -    writeArray arrSum (lift 0 :: IR Int) (A.snd r)+    writeArray TypeInt arrSum (liftInt 0) (A.snd r)      return_ @@ -773,61 +657,58 @@ -- Similar to mkScanP3, except that indices are shifted by one since the output -- array is the same size as the input (despite being an exclusive scan). ----- Launch (chunks-1) threads, because the first chunk does not need extra--- processing.+-- Note that the first chunk does not need to do any extra processing (has no+-- carry-in value). -- mkScan'P3-    :: forall aenv e. Elt e-    => Direction+    :: Direction     -> UID-    -> Gamma aenv-    -> IRFun2 Native aenv (e -> e -> e)-    -> CodeGen (IROpenAcc Native aenv (Vector e, Scalar e))-mkScan'P3 dir uid aenv combine =+    -> Gamma          aenv+    -> TypeR e+    -> IRFun2  Native aenv (e -> e -> e)+    -> CodeGen Native      (IROpenAcc Native aenv (Vector e, Scalar e))+mkScan'P3 dir uid aenv eR combine =   let-      (chunk, _, paramGang)     = gangParam-      (arrOut, paramOut)        = mutableArray ("out" :: Name (Vector e))-      (arrTmp, paramTmp)        = mutableArray ("tmp" :: Name (Vector e))-      paramEnv                  = envParam aenv+      (start, end, paramGang) = gangParam    dim1+      (arrOut, paramOut)      = mutableArray (ArrayR dim1 eR) "out"+      (arrTmp, paramTmp)      = mutableArray (ArrayR dim1 eR) "tmp"+      paramEnv                = envParam aenv       ---      stride                    = local           scalarType ("ix.stride" :: Name Int)-      paramStride               = scalarParameter scalarType ("ix.stride" :: Name Int)+      steps                   = local     (TupRsingle scalarTypeInt) "ix.steps"+      paramSteps              = parameter (TupRsingle scalarTypeInt) "ix.steps"+      piece                   = local     (TupRsingle scalarTypeInt) "ix.piece"+      paramPiece              = parameter (TupRsingle scalarTypeInt) "ix.piece"       ---      next i                    = case dir of-                                    L -> A.add numType i (lift 1)-                                    R -> A.sub numType i (lift 1)-      prev i                    = case dir of-                                    L -> A.sub numType i (lift 1)-                                    R -> A.add numType i (lift 1)+      next i                  = case dir of+                                  LeftToRight -> A.add numType i (liftInt 1)+                                  RightToLeft -> A.sub numType i (liftInt 1)+      prev i                  = case dir of+                                  LeftToRight -> A.sub numType i (liftInt 1)+                                  RightToLeft -> A.add numType i (liftInt 1)+      firstPiece              = case dir of+                                  LeftToRight -> liftInt 0+                                  RightToLeft -> steps   in-  makeOpenAcc uid "scanP3" (paramGang ++ paramStride : paramOut ++ paramTmp ++ paramEnv) $ do--    -- Determine which chunk we will be carrying in the values of, and compute-    -- the appropriate start and end indices-    a     <- case dir of-               L -> next chunk-               R -> pure chunk--    b     <- A.mul numType a stride-    c     <- A.add numType b stride-    d     <- A.min singleType c (indexHead (irArrayShape arrOut))+  makeOpenAcc uid "scanP3" (paramGang ++ paramPiece ++ paramSteps ++ paramOut ++ paramTmp ++ paramEnv) $ do -    inf   <- next b-    sup   <- next d+    -- TODO: don't schedule the "first" piece.+    --+    A.when (neq singleType piece firstPiece) $ do -    -- Carry-value from the previous chunk-    e     <- case dir of-               L -> pure chunk-               R -> prev chunk+      -- Compute start and end indices, leaving space for the initial element+      inf <- next (indexHead start)+      sup <- next (indexHead end) -    carry <- readArray arrTmp e+      -- Read the carry-in value for this piece+      c   <- readArray TypeInt arrTmp =<< prev piece -    imapFromTo inf sup $ \i -> do-      x <- readArray arrOut i-      y <- case dir of-             L -> app2 combine carry x-             R -> app2 combine x carry-      writeArray arrOut i y+      -- Apply the carry-in value to all elements of the output+      imapFromTo inf sup $ \i -> do+        x <- readArray TypeInt arrOut i+        y <- case dir of+               LeftToRight -> app2 combine c x+               RightToLeft -> app2 combine x c+        writeArray TypeInt arrOut i y      return_ 

@@ -0,0 +1,217 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil+-- Copyright   : [2018..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Stencil (++  mkStencil1,+  mkStencil2,++) where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Stencil+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic+import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Loop                      hiding ( imapFromStepTo )+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Stencil+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )++import qualified LLVM.AST.Global                                    as LLVM++import Control.Monad+++-- The stencil function is similar to a map, but has access to surrounding+-- elements as specified by the stencil pattern.+--+-- This generates two functions:+--+--  * stencil_inside: does not apply boundary conditions, assumes all element+--                    accesses are valid+--+--  * stencil_border: applies boundary condition check to each array access+--+mkStencil1+    :: UID+    -> Gamma              aenv+    -> StencilR sh a stencil+    -> TypeR b+    -> IRFun1      Native aenv (stencil -> b)+    -> IRBoundary  Native aenv (Array sh a)+    -> MIRDelayed  Native aenv (Array sh a)+    -> CodeGen     Native      (IROpenAcc Native aenv (Array sh b))+mkStencil1 uid aenv sr tp f bnd marr =+  let (arrIn, paramIn) = delayedArray "in" marr+      repr = ArrayR (stencilShapeR sr) tp+   in (+++) <$> mkInside uid aenv repr (IRFun1 $ app1 f <=< stencilAccess sr Nothing    arrIn) paramIn+            <*> mkBorder uid aenv repr (IRFun1 $ app1 f <=< stencilAccess sr (Just bnd) arrIn) paramIn++mkStencil2+    :: UID+    -> Gamma              aenv+    -> StencilR sh a stencil1+    -> StencilR sh b stencil2+    -> TypeR c+    -> IRFun2      Native aenv (stencil1 -> stencil2 -> c)+    -> IRBoundary  Native aenv (Array sh a)+    -> MIRDelayed  Native aenv (Array sh a)+    -> IRBoundary  Native aenv (Array sh b)+    -> MIRDelayed  Native aenv (Array sh b)+    -> CodeGen     Native      (IROpenAcc Native aenv (Array sh c))+mkStencil2 uid aenv sr1 sr2 tp f bnd1 marr1 bnd2 marr2 =+  let+      (arrIn1, paramIn1)  = delayedArray "in1" marr1+      (arrIn2, paramIn2)  = delayedArray "in2" marr2++      repr = ArrayR (stencilShapeR sr1) tp++      inside  = IRFun1 $ \ix -> do+        stencil1 <- stencilAccess sr1 Nothing arrIn1 ix+        stencil2 <- stencilAccess sr2 Nothing arrIn2 ix+        app2 f stencil1 stencil2+      --+      border  = IRFun1 $ \ix -> do+        stencil1 <- stencilAccess sr1 (Just bnd1) arrIn1 ix+        stencil2 <- stencilAccess sr2 (Just bnd2) arrIn2 ix+        app2 f stencil1 stencil2+  in+  (+++) <$> mkInside uid aenv repr inside (paramIn1 ++ paramIn2)+        <*> mkBorder uid aenv repr border (paramIn1 ++ paramIn2)+++mkInside+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> IRFun1  Native aenv (sh -> e)+    -> [LLVM.Parameter]+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkInside uid aenv repr apply paramIn =+  let+      (start, end, paramGang)   = gangParam    (arrayRshape repr)+      (arrOut, paramOut)        = mutableArray repr "out"+      paramEnv                  = envParam aenv+      shOut                     = irArrayShape arrOut+  in+  makeOpenAcc uid "stencil_inside" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    imapNestFromToTile (arrayRshape repr) 4 start end shOut $ \ix i -> do+      r <- app1 apply ix                        -- apply generator function+      writeArray TypeInt arrOut i r                     -- store result++    return_++mkBorder+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh e)+    -> IRFun1  Native aenv (sh -> e)+    -> [LLVM.Parameter]+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh e))+mkBorder uid aenv repr apply paramIn =+  let+      (start, end, paramGang)   = gangParam    (arrayRshape repr)+      (arrOut, paramOut)        = mutableArray repr "out"+      paramEnv                  = envParam aenv+      shOut                     = irArrayShape arrOut+  in+  makeOpenAcc uid "stencil_border" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    imapNestFromTo (arrayRshape repr) start end shOut $ \ix i -> do+      r <- app1 apply ix                        -- apply generator function+      writeArray TypeInt arrOut i r             -- store result++    return_+++imapNestFromToTile+    :: ShapeR sh+    -> Int                                                  -- ^ unroll amount (tile height)+    -> Operands sh                                          -- ^ initial index (inclusive)+    -> Operands sh                                          -- ^ final index (exclusive)+    -> Operands sh                                          -- ^ total array extent+    -> (Operands sh -> Operands Int -> CodeGen Native ())   -- ^ apply at each index+    -> CodeGen Native ()+imapNestFromToTile shr unroll start end extent body =+  go shr start end body'+  where+    body' ix = body ix =<< intOfIndex shr extent ix++    go :: ShapeR t+       -> Operands t+       -> Operands t+       -> (Operands t -> CodeGen Native ())+       -> CodeGen Native ()+    go ShapeRz OP_Unit OP_Unit k+      = k OP_Unit++    -- To correctly generate the unrolled loop nest we need to explicitly match+    -- on the last two dimensions.+    --+    go (ShapeRsnoc (ShapeRsnoc ShapeRz)) (OP_Pair (OP_Pair OP_Unit sy) sx) (OP_Pair (OP_Pair OP_Unit ey) ex) k+      = do+          -- Tile the stencil operator in the xy-plane by unrolling in the+          -- y-dimension and vectorising in the x-dimension.+          --+          sy' <- imapFromStepTo sy (liftInt unroll) ey $ \iy ->+                  imapFromTo    sx                  ex $ \ix ->+                    forM_ [0 .. unroll-1] $ \n -> do+                    iy' <- add numType iy (liftInt n)+                    k (OP_Pair (OP_Pair OP_Unit iy') ix)++          -- Take care of any remaining loop iterations in the y-dimension+          --+          _       <- imapFromTo  sy' ey $ \iy ->+                      imapFromTo sx  ex $ \ix ->+                        k (OP_Pair (OP_Pair OP_Unit iy) ix)+          return ()++    -- The 1- and 3+-dimensional cases can recurse normally+    --+    go (ShapeRsnoc shr') (OP_Pair ssh ssz) (OP_Pair esh esz) k+      = go shr' ssh esh+      $ \sz      -> imapFromTo ssz esz+      $ \i       -> k (OP_Pair sz i)++imapFromStepTo+    :: Operands Int+    -> Operands Int+    -> Operands Int+    -> (Operands Int -> CodeGen Native ())+    -> CodeGen Native (Operands Int)+imapFromStepTo start step end body =+  let+      incr i = add numType i step+      test i = do i' <- incr i+                  lt singleType i' end+  in+  while (TupRsingle scalarTypeInt) test+        (\i -> body i >> incr i)+        start+

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.CodeGen.Transform+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.CodeGen.Transform+  where++-- accelerate+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.CodeGen.Array+import Data.Array.Accelerate.LLVM.CodeGen.Base+import Data.Array.Accelerate.LLVM.CodeGen.Environment+import Data.Array.Accelerate.LLVM.CodeGen.Exp+import Data.Array.Accelerate.LLVM.CodeGen.Monad+import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.Compile.Cache++import Data.Array.Accelerate.LLVM.Native.Target                     ( Native )+import Data.Array.Accelerate.LLVM.Native.CodeGen.Base+import Data.Array.Accelerate.LLVM.Native.CodeGen.Loop+++-- Hybrid map/backpermute operation+--+mkTransform+    :: UID+    -> Gamma aenv+    -> ArrayR (Array sh  a)+    -> ArrayR (Array sh' b)+    -> IRFun1  Native aenv (sh' -> sh)+    -> IRFun1  Native aenv (a -> b)+    -> CodeGen Native      (IROpenAcc Native aenv (Array sh' b))+mkTransform uid aenv reprIn reprOut p f =+  let+      (start, end, paramGang)   = gangParam (arrayRshape reprOut)+      (arrIn,  paramIn)         = mutableArray reprIn  "in"+      (arrOut, paramOut)        = mutableArray reprOut "out"+      paramEnv                  = envParam aenv+      shIn                      = irArrayShape arrIn+      shOut                     = irArrayShape arrOut+  in+  makeOpenAcc uid "transform" (paramGang ++ paramOut ++ paramIn ++ paramEnv) $ do++    imapNestFromTo (arrayRshape reprOut) start end shOut $ \ix' i' -> do+      ix  <- app1 p ix'+      i   <- intOfIndex (arrayRshape reprIn) shIn ix+      a   <- readArray TypeInt arrIn i+      b   <- app1 f a+      writeArray TypeInt arrOut i' b++    return_+

@@ -3,11 +3,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.Compile--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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) --@@ -19,14 +18,8 @@  ) where --- llvm-hs-import LLVM.AST                                                     hiding ( Module )-import LLVM.Module                                                  as LLVM hiding ( Module )-import LLVM.Context-import LLVM.Target---- accelerate-import Data.Array.Accelerate.Trafo                                  ( DelayedOpenAcc )+import Data.Array.Accelerate.AST                                    ( PreOpenAcc )+import Data.Array.Accelerate.Trafo.Delayed  import Data.Array.Accelerate.LLVM.CodeGen import Data.Array.Accelerate.LLVM.Compile@@ -41,7 +34,11 @@ import Data.Array.Accelerate.LLVM.Native.Target import qualified Data.Array.Accelerate.LLVM.Native.Debug            as Debug --- standard library+import LLVM.AST                                                     hiding ( Module )+import LLVM.Module                                                  as LLVM hiding ( Module )+import LLVM.Context+import LLVM.Target+ import Control.Monad.State import Data.ByteString                                              ( ByteString ) import Data.ByteString.Short                                        ( ShortByteString )@@ -67,15 +64,19 @@  -- | Compile an Accelerate expression to object code ---compile :: DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ObjectR Native)-compile acc aenv = do-  target            <- gets llvmTarget-  (uid, cacheFile)  <- cacheOfOpenAcc acc+compile :: PreOpenAcc DelayedOpenAcc aenv a -> Gamma aenv -> LLVM Native (ObjectR Native)+compile pacc aenv = do    -- Generate code for this Acc operation   ---  let Module ast md = llvmOfOpenAcc target uid acc aenv-      triple        = fromMaybe BS.empty (moduleTargetTriple ast)+  -- We require the metadata result, which will give us the names of the+  -- functions which will be contained in the object code, but the actual+  -- code generation step is executed lazily.+  --+  (uid, cacheFile)  <- cacheOfPreOpenAcc pacc+  Module ast md     <- llvmOfPreOpenAcc uid pacc aenv++  let triple        = fromMaybe BS.empty (moduleTargetTriple ast)       datalayout    = moduleDataLayout ast       nms           = [ f | Name f <- Map.keys md ] 

@@ -2,10 +2,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.Compile.Cache--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] The Accelerate Team -- 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,9 @@ -- | -- Module      : Data.Array.Accelerate.LLVM.Native.Compile.Optimise--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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) --

@@ -2,11 +2,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.Debug--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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,65 +0,0 @@--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Distribution.Simple--- Copyright   : [2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.Native.Distribution.Simple (--  defaultMain,-  simpleUserHooks,-  module Distribution.Simple,--) where--import Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build--import Distribution.PackageDescription                              ( PackageDescription )-import Distribution.Simple.Setup                                    ( BuildFlags )-import Distribution.Simple.LocalBuildInfo                           ( LocalBuildInfo )-import Distribution.Simple.PreProcess                               ( PPSuffixHandler, knownSuffixHandlers )-import Distribution.Simple                                          hiding ( defaultMain, simpleUserHooks )-import qualified Distribution.Simple                                as Cabal--import Data.List                                                    ( unionBy )----- | A simple implementation of @main@ for a Cabal setup script. This is the--- same as 'Distribution.Simple.defaultMain', with added support for building--- libraries utilising 'Data.Array.Accelerate.LLVM.Native.runQ'*.----defaultMain :: IO ()-defaultMain = Cabal.defaultMainWithHooks simpleUserHooks----- | Hooks that correspond to a plain instantiation of the \"simple\" build--- system.----simpleUserHooks :: UserHooks-simpleUserHooks =-  Cabal.simpleUserHooks-    { buildHook = accelerateBuildHook-    }--accelerateBuildHook-    :: PackageDescription-    -> LocalBuildInfo-    -> UserHooks-    -> BuildFlags-    -> IO ()-accelerateBuildHook pkg_descr localbuildinfo hooks flags =-  build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)---- | Combine the preprocessors in the given hooks with the--- preprocessors built into cabal.-allSuffixHandlers :: UserHooks -> [PPSuffixHandler]-allSuffixHandlers hooks-    = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers-    where-      overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]-      overridesPP = unionBy (\x y -> fst x == fst y)-

@@ -1,467 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build--- Copyright   : [2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/Build.hs-----module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.Build (--  build,--) where--import qualified Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC as Acc--import qualified Distribution.Simple.Build as Cabal--import Distribution.Types.Dependency-import Distribution.Types.LocalBuildInfo-import Distribution.Types.TargetInfo-import Distribution.Types.ComponentRequestedSpec-import Distribution.Types.ForeignLib-import Distribution.Types.MungedPackageId-import Distribution.Types.MungedPackageName-import Distribution.Types.UnqualComponentName-import Distribution.Types.ComponentLocalBuildInfo-import Distribution.Types.ExecutableScope--import Distribution.Package-import Distribution.Backpack-import Distribution.Backpack.DescribeUnitId-import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite-import qualified Distribution.Simple.PackageIndex as Index--import qualified Distribution.Simple.Program.HcPkg as HcPkg--import Distribution.Simple.Compiler hiding (Flag)-import Distribution.PackageDescription hiding (Flag)-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.InstalledPackageInfo (InstalledPackageInfo)--import Distribution.Simple.Setup-import Distribution.Simple.BuildTarget-import Distribution.Simple.BuildToolDepends-import Distribution.Simple.PreProcess-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Program.Types-import Distribution.Simple.Program.Db-import Distribution.Simple.BuildPaths-import Distribution.Simple.Configure-import Distribution.Simple.Register-import Distribution.Simple.Test.LibV09-import Distribution.Simple.Utils--import Distribution.Text-#if MIN_VERSION_Cabal(2,4,0)-import Distribution.System (buildPlatform, Platform)-#else-import Distribution.System (buildPlatform)-#endif-import Distribution.Verbosity--import Distribution.Compat.Graph (IsNode(..))--import Control.Monad-import qualified Data.Set as Set-import System.FilePath ( (</>), (<.>) )-import System.Directory ( getCurrentDirectory )---build    :: PackageDescription  -- ^ Mostly information from the .cabal file-         -> LocalBuildInfo      -- ^ Configuration information-         -> BuildFlags          -- ^ Flags that the user passed to build-         -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling-         -> IO ()-build pkg_descr lbi flags suffixes = do-  targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)-  let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)-  info verbosity $ "Component build order: "-                ++ intercalate ", "-                    (map (showComponentName . componentLocalName . targetCLBI)-                        componentsToBuild)--  when (null targets) $-    -- Only bother with this message if we're building the whole package-    setupMessage verbosity "Building" (packageId pkg_descr)--  internalPackageDB <- createInternalPackageDB verbosity lbi distPref--  (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do-    let comp = targetComponent target-        clbi = targetCLBI target-    Cabal.componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity-    let bi     = componentBuildInfo comp-        progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)-        lbi'   = lbi {-                   withPrograms  = progs',-                   withPackageDB = withPackageDB lbi ++ [internalPackageDB],-                   installedPkgs = index-                 }-    mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr-                   lbi' suffixes comp clbi distPref-    return (maybe index (Index.insert `flip` index) mb_ipi)-  return ()- where-  distPref  = fromFlag (buildDistPref flags)-  verbosity = fromFlag (buildVerbosity flags)---buildComponent :: Verbosity-               -> Flag (Maybe Int)-               -> PackageDescription-               -> LocalBuildInfo-               -> [PPSuffixHandler]-               -> Component-               -> ComponentLocalBuildInfo-               -> FilePath-               -> IO (Maybe InstalledPackageInfo)-buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CLib lib) clbi distPref = do-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    let libbi = libBuildInfo lib-        lib' = lib { libBuildInfo = addExtraCSources libbi extras }-    buildLib verbosity numJobs pkg_descr lbi lib' clbi--    let oneComponentRequested (OneComponentRequestedSpec _) = True-        oneComponentRequested _ = False-    -- Don't register inplace if we're only building a single component;-    -- it's not necessary because there won't be any subsequent builds-    -- that need to tag us-    if (not (oneComponentRequested (componentEnabledSpec lbi)))-      then do-        -- Register the library in-place, so exes can depend-        -- on internally defined libraries.-        pwd <- getCurrentDirectory-        let -- The in place registration uses the "-inplace" suffix, not an ABI hash-            installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr-                                    -- NB: Use a fake ABI hash to avoid-                                    -- needing to recompute it every build.-                                    (mkAbiHash "inplace") lib' lbi clbi--        debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo)-        registerPackage verbosity (compiler lbi) (withPrograms lbi)-                        (withPackageDB lbi) installedPkgInfo-                        HcPkg.defaultRegisterOptions {-                          HcPkg.registerMultiInstance = True-                        }-        return (Just installedPkgInfo)-      else return Nothing--buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CFLib flib) clbi _distPref = do-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    buildFLib verbosity numJobs pkg_descr lbi flib clbi-    return Nothing--buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CExe exe) clbi _ = do-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    let ebi = buildInfo exe-        exe' = exe { buildInfo = addExtraCSources ebi extras }-    buildExe verbosity numJobs pkg_descr lbi exe' clbi-    return Nothing---buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })-               clbi _distPref = do-    let exe = testSuiteExeV10AsExe test-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    let ebi = buildInfo exe-        exe' = exe { buildInfo = addExtraCSources ebi extras }-    buildExe verbosity numJobs pkg_descr lbi exe' clbi-    return Nothing---buildComponent verbosity numJobs pkg_descr lbi0 suffixes-               comp@(CTest-                 test@TestSuite { testInterface = TestSuiteLibV09{} })-               clbi -- This ComponentLocalBuildInfo corresponds to a detailed-                    -- test suite and not a real component. It should not-                    -- be used, except to construct the CLBIs for the-                    -- library and stub executable that will actually be-                    -- built.-               distPref = do-    pwd <- getCurrentDirectory-    let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) =-          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    buildLib verbosity numJobs pkg lbi lib libClbi-    -- NB: need to enable multiple instances here, because on 7.10+-    -- the package name is the same as the library, and we still-    -- want the registration to go through.-    registerPackage verbosity (compiler lbi) (withPrograms lbi)-                    (withPackageDB lbi) ipi-                    HcPkg.defaultRegisterOptions {-                      HcPkg.registerMultiInstance = True-                    }-    let ebi = buildInfo exe-        exe' = exe { buildInfo = addExtraCSources ebi extras }-    buildExe verbosity numJobs pkg_descr lbi exe' exeClbi-    return Nothing -- Can't depend on test suite---buildComponent verbosity _ _ _ _-               (CTest TestSuite { testInterface = TestSuiteUnsupported tt })-               _ _ =-    die' verbosity $ "No support for building test suite type " ++ display tt---buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })-               clbi _ = do-    let (exe, exeClbi) = benchmarkExeV10asExe bm clbi-    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes-    extras <- preprocessExtras verbosity comp lbi-    setupMessage' verbosity "Building" (packageId pkg_descr)-      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)-    let ebi = buildInfo exe-        exe' = exe { buildInfo = addExtraCSources ebi extras }-    buildExe verbosity numJobs pkg_descr lbi exe' exeClbi-    return Nothing---buildComponent verbosity _ _ _ _-               (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })-               _ _ =-    die' verbosity $ "No support for building benchmark type " ++ display tt------ | Add extra C sources generated by preprocessing to build--- information.-addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo-addExtraCSources bi extras = bi { cSources = new }-  where new = Set.toList $ old `Set.union` exs-        old = Set.fromList $ cSources bi-        exs = Set.fromList extras----- | Translate a exe-style 'TestSuite' component into an exe for building-testSuiteExeV10AsExe :: TestSuite -> Executable-testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } =-    Executable {-      exeName    = testName test,-      modulePath = mainFile,-      exeScope   = ExecutablePublic,-      buildInfo  = testBuildInfo test-    }-testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"--#if MIN_VERSION_Cabal(2,4,0)-setBuildDepends :: [Dependency] -> PackageDescription -> PackageDescription-setBuildDepends deps pkg_descr@PackageDescription{ setupBuildInfo = Just buildInfo'}-  = pkg_descr { setupBuildInfo = Just (buildInfo' {setupDepends = deps})}-setBuildDepends deps pkg_descr@PackageDescription{ setupBuildInfo = Nothing}-  = pkg_descr-    { setupBuildInfo = Just (SetupBuildInfo {setupDepends = deps, defaultSetupDepends = True})-    }-exeExtension' :: Platform -> String-exeExtension' = exeExtension-#else-setBuildDepends :: [Dependency] -> PackageDescription -> PackageDescription-setBuildDepends deps pkg_descr = pkg_descr {buildDepends = deps}-exeExtension' :: a -> String-exeExtension' _ = exeExtension-#endif----- | Translate a lib-style 'TestSuite' component into a lib + exe for building-testSuiteLibV09AsLibAndExe :: PackageDescription-                           -> TestSuite-                           -> ComponentLocalBuildInfo-                           -> LocalBuildInfo-                           -> FilePath-                           -> FilePath-                           -> (PackageDescription,-                               Library, ComponentLocalBuildInfo,-                               LocalBuildInfo,-                               IPI.InstalledPackageInfo,-                               Executable, ComponentLocalBuildInfo)-testSuiteLibV09AsLibAndExe pkg_descr-                     test@TestSuite { testInterface = TestSuiteLibV09 _ m }-                     clbi lbi distPref pwd =-    (pkg, lib, libClbi, lbi, ipi, exe, exeClbi)-  where-    bi  = testBuildInfo test-    lib = Library {-            libName = Nothing,-            exposedModules = [ m ],-            reexportedModules = [],-            signatures = [],-            libExposed     = True,-            libBuildInfo   = bi-          }-    -- This is, like, the one place where we use a CTestName for a library.-    -- Should NOT use library name, since that could conflict!-    PackageIdentifier pkg_name pkg_ver = package pkg_descr-    compat_name = computeCompatPackageName pkg_name (Just (testName test))-    compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi)-    libClbi = LibComponentLocalBuildInfo-                { componentPackageDeps = componentPackageDeps clbi-                , componentInternalDeps = componentInternalDeps clbi-                , componentIsIndefinite_ = False-                , componentExeDeps = componentExeDeps clbi-                , componentLocalName = CSubLibName (testName test)-                , componentIsPublic = False-                , componentIncludes = componentIncludes clbi-                , componentUnitId = componentUnitId clbi-                , componentComponentId = componentComponentId clbi-                , componentInstantiatedWith = []-                , componentCompatPackageName = compat_name-                , componentCompatPackageKey = compat_key-                , componentExposedModules = [IPI.ExposedModule m Nothing]-                }-    pkg = setBuildDepends (targetBuildDepends $ testBuildInfo test) $ pkg_descr {-            package      = (package pkg_descr) { pkgName = mkPackageName $ unMungedPackageName compat_name }-          , executables  = []-          , testSuites   = []-          , subLibraries = [lib]-          }-    ipi    = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi-    testDir = buildDir lbi </> stubName test-          </> stubName test ++ "-tmp"-    testLibDep = thisPackageVersion $ package pkg-    exe = Executable {-            exeName    = mkUnqualComponentName $ stubName test,-            modulePath = stubFilePath test,-            exeScope   = ExecutablePublic,-            buildInfo  = (testBuildInfo test) {-                           hsSourceDirs       = [ testDir ],-                           targetBuildDepends = testLibDep-                             : (targetBuildDepends $ testBuildInfo test)-                         }-          }-    -- | The stub executable needs a new 'ComponentLocalBuildInfo'-    -- that exposes the relevant test suite library.-    deps = (IPI.installedUnitId ipi, mungedId ipi)-         : (filter (\(_, x) -> let name = unMungedPackageName $ mungedName x-                               in name == "Cabal" || name == "base")-                   (componentPackageDeps clbi))-    exeClbi = ExeComponentLocalBuildInfo {-                -- TODO: this is a hack, but as long as this is unique-                -- (doesn't clobber something) we won't run into trouble-                componentUnitId = mkUnitId (stubName test),-                componentComponentId = mkComponentId (stubName test),-                componentInternalDeps = [componentUnitId clbi],-                componentExeDeps = [],-                componentLocalName = CExeName $ mkUnqualComponentName $ stubName test,-                componentPackageDeps = deps,-                -- Assert DefUnitId invariant!-                -- Executable can't be indefinite, so dependencies must-                -- be definite packages.-                componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps)-                                        (repeat defaultRenaming)-              }-testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"----- | Translate a exe-style 'Benchmark' component into an exe for building-benchmarkExeV10asExe :: Benchmark -> ComponentLocalBuildInfo-                     -> (Executable, ComponentLocalBuildInfo)-benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f }-                     clbi =-    (exe, exeClbi)-  where-    exe = Executable {-            exeName    = benchmarkName bm,-            modulePath = f,-            exeScope   = ExecutablePublic,-            buildInfo  = benchmarkBuildInfo bm-          }-    exeClbi = ExeComponentLocalBuildInfo {-                componentUnitId = componentUnitId clbi,-                componentComponentId = componentComponentId clbi,-                componentLocalName = CExeName (benchmarkName bm),-                componentInternalDeps = componentInternalDeps clbi,-                componentExeDeps = componentExeDeps clbi,-                componentPackageDeps = componentPackageDeps clbi,-                componentIncludes = componentIncludes clbi-              }-benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind"----- | Initialize a new package db file for libraries defined--- internally to the package.-createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath-                        -> IO PackageDB-createInternalPackageDB verbosity lbi distPref = do-    existsAlready <- doesPackageDBExist dbPath-    when existsAlready $ deletePackageDB dbPath-    createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath-    return (SpecificPackageDB dbPath)-  where-    dbPath = internalPackageDBPath lbi distPref--addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo-                      -> ProgramDb -> ProgramDb-addInternalBuildTools pkg lbi bi progs =-    foldr updateProgram progs internalBuildTools-  where-    internalBuildTools =-      [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation)-      | toolName <- getAllInternalToolDependencies pkg bi-      , let toolName' = unUnqualComponentName toolName-      , let toolLocation = buildDir lbi </> toolName' </> toolName' <.> exeExtension' buildPlatform ]----- TODO: build separate libs in separate dirs so that we can build--- multiple libs, e.g. for 'LibTest' library-style test suites-buildLib :: Verbosity -> Flag (Maybe Int)-                      -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity numJobs pkg_descr lbi lib clbi =-  case compilerFlavor (compiler lbi) of-    GHC   -> Acc.buildLib   verbosity numJobs pkg_descr lbi lib clbi    -- XXX only change here-    GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi-    UHC   -> UHC.buildLib   verbosity         pkg_descr lbi lib clbi-    HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi-    _    -> die' verbosity "Building is not supported with this compiler."---- | Build a foreign library------ NOTE: We assume that we already checked that we can actually build the--- foreign library in configure.-buildFLib :: Verbosity -> Flag (Maybe Int)-                       -> PackageDescription -> LocalBuildInfo-                       -> ForeignLib         -> ComponentLocalBuildInfo -> IO ()-buildFLib verbosity numJobs pkg_descr lbi flib clbi =-    case compilerFlavor (compiler lbi) of-      GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi-      _   -> die' verbosity "Building is not supported with this compiler."--buildExe :: Verbosity -> Flag (Maybe Int)-                      -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity numJobs pkg_descr lbi exe clbi =-  case compilerFlavor (compiler lbi) of-    GHC   -> GHC.buildExe   verbosity numJobs pkg_descr lbi exe clbi-    GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi-    UHC   -> UHC.buildExe   verbosity         pkg_descr lbi exe clbi-    _     -> die' verbosity "Building is not supported with this compiler."--

@@ -1,458 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC--- Copyright   : [2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC.hs-----module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC (--  buildLib,-  replLib,--) where--import qualified Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal as Internal-import qualified Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo                 as Internal--import qualified Distribution.Simple.GHC as Cabal-import Distribution.PackageDescription as PD-import Distribution.Simple.LocalBuildInfo-import Distribution.Types.ComponentLocalBuildInfo-import qualified Distribution.Simple.Hpc as Hpc-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Program-import qualified Distribution.Simple.Program.Ar    as Ar-import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup-import qualified Distribution.Simple.Setup as Cabal-import Distribution.Simple.Compiler hiding (Flag)-import Distribution.Version-import Distribution.System-import Distribution.Verbosity-import Distribution.Text-import Distribution.Types.UnitId(UnitId)-import Distribution.Utils.NubList-import Language.Haskell.Extension--import Control.Monad (when, unless)-import Data.List (nub)-import Data.Maybe (catMaybes)-import System.FilePath ( (</>), replaceExtension, isRelative )-import qualified Data.Map as Map----- <https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC.hs#L505>----buildLib, replLib :: Verbosity          -> Cabal.Flag (Maybe Int)-                  -> PackageDescription -> LocalBuildInfo-                  -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib = buildOrReplLib False-replLib  = buildOrReplLib True---#if MIN_VERSION_Cabal(2,4,0)-nubList :: a -> a-nubList = id--overNubListR' :: a -> a-overNubListR' = id--mkSharedLibName' :: Platform -> CompilerId -> UnitId -> String -mkSharedLibName' = mkSharedLibName-#else-nubList :: (Ord a) => [a] -> NubListR a-nubList = toNubListR--overNubListR' :: (Ord a) => ([a] -> [a]) -> NubListR a -> NubListR a-overNubListR' = overNubListR--mkSharedLibName' :: Platform -> CompilerId -> UnitId -> String -mkSharedLibName' _ compiler_uid path = mkSharedLibName compiler_uid path-#endif--buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)-               -> PackageDescription -> LocalBuildInfo-               -> Library            -> ComponentLocalBuildInfo -> IO ()-buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do-  let uid = componentUnitId clbi-      libTargetDir = componentBuildDir lbi clbi-      whenVanillaLib forceVanilla =-        when (forceVanilla || withVanillaLib lbi)-      whenProfLib = when (withProfLib lbi)-      whenSharedLib forceShared =-        when (forceShared || withSharedLib lbi)-      whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)-      ifReplLib = when forRepl-      comp = compiler lbi-      ghcVersion = compilerVersion comp-      implInfo  = Cabal.getImplInfo comp-      platform@(Platform _hostArch hostOS) = hostPlatform lbi-      has_code = not (componentIsIndefinite clbi)--  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let runGhcProg = runGHC verbosity ghcProg comp platform--  libBi <- hackThreadedFlag verbosity-             comp (withProfLib lbi) (libBuildInfo lib)--  let isGhcDynamic        = Cabal.isDynamic comp-      dynamicTooSupported = supportsDynamicToo comp-      doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi-      forceVanillaLib = doingTH && not isGhcDynamic-      forceSharedLib  = doingTH &&     isGhcDynamic-      -- TH always needs default libs, even when building for profiling--  -- Determine if program coverage should be enabled and if so, what-  -- '-hpcdir' should be.-  let isCoverageEnabled = libCoverage lbi-      -- TODO: Historically HPC files have been put into a directory which-      -- has the package name.  I'm going to avoid changing this for-      -- now, but it would probably be better for this to be the-      -- component ID instead...-      pkg_name = display (PD.package pkg_descr)-      distPref = fromFlag $ configDistPref $ configFlags lbi-      hpcdir way-        | forRepl = mempty  -- HPC is not supported in ghci-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name-        | otherwise = mempty--  createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive-  -- modules?-  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)-      baseOpts    = Cabal.componentGhcOptions verbosity lbi libBi clbi libTargetDir-      vanillaOpts = baseOpts `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptNumJobs      = numJobs,-                      ghcOptInputModules = toNubListR $ allLibModules lib clbi,-                      ghcOptHPCDir       = hpcdir Hpc.Vanilla-                    }--      profOpts    = vanillaOpts `mappend` mempty {-                      ghcOptProfilingMode = toFlag True,-                      ghcOptProfilingAuto = Internal.profDetailLevelFlag True-                                              (withProfLibDetail lbi),-                      ghcOptHiSuffix      = toFlag "p_hi",-                      ghcOptObjSuffix     = toFlag "p_o",-                      ghcOptExtra         = nubList $ hcProfOptions GHC libBi,-                      ghcOptHPCDir        = hpcdir Hpc.Prof-                    }--      sharedOpts  = vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                      ghcOptFPic        = toFlag True,-                      ghcOptHiSuffix    = toFlag "dyn_hi",-                      ghcOptObjSuffix   = toFlag "dyn_o",-                      ghcOptExtra       = nubList $ hcSharedOptions GHC libBi,-                      ghcOptHPCDir      = hpcdir Hpc.Dyn-                    }-      linkerOpts = mempty {-                      ghcOptLinkOptions       = nubList $ PD.ldOptions libBi,-                      ghcOptLinkLibs          = nubList $ extraLibs libBi,-                      ghcOptLinkLibPath       = toNubListR $ extraLibDirs libBi,-                      ghcOptLinkFrameworks    = toNubListR $-                                                PD.frameworks libBi,-                      ghcOptLinkFrameworkDirs = toNubListR $-                                                PD.extraFrameworkDirs libBi,-                      ghcOptInputFiles     = toNubListR-                                             [libTargetDir </> x | x <- cObjs]-                   }-      replOpts    = vanillaOpts {-                      ghcOptExtra        = overNubListR' Internal.filterGhciFlags $-                                           ghcOptExtra vanillaOpts,-                      ghcOptNumJobs      = mempty-                    }-                    `mappend` linkerOpts-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeInteractive,-                      ghcOptOptimisation = toFlag GhcNoOptimisation-                    }--      vanillaSharedOpts = vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,-                      ghcOptDynHiSuffix  = toFlag "dyn_hi",-                      ghcOptDynObjSuffix = toFlag "dyn_o",-                      ghcOptHPCDir       = hpcdir Hpc.Dyn-                    }--  unless (forRepl || null (allLibModules lib clbi)) $-    do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)-           shared  = whenSharedLib  forceSharedLib  (runGhcProg sharedOpts)-           useDynToo = dynamicTooSupported &&-                       (forceVanillaLib || withVanillaLib lbi) &&-                       (forceSharedLib  || withSharedLib  lbi) &&-                       null (hcSharedOptions GHC libBi)-       if not has_code-        then vanilla-        else-         if useDynToo-          then do-              runGhcProg vanillaSharedOpts-              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of-                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) ->-                    -- When the vanilla and shared library builds are done-                    -- in one pass, only one set of HPC module interfaces-                    -- are generated. This set should suffice for both-                    -- static and dynamically linked executables. We copy-                    -- the modules interfaces so they are available under-                    -- both ways.-                    copyDirectoryRecursive verbosity dynDir vanillaDir-                _ -> return ()-          else if isGhcDynamic-            then do shared;  vanilla-            else do vanilla; shared-       when has_code $ whenProfLib (runGhcProg profOpts)--  -- build any C sources-  unless (not has_code || null (cSources libBi)) $ do-    info verbosity "Building C Sources..."-    sequence_-      [ do let baseCcOpts    = Cabal.componentCcGhcOptions verbosity-                               lbi libBi clbi libTargetDir filename-               vanillaCcOpts = if isGhcDynamic-                               -- Dynamic GHC requires C sources to be built-                               -- with -fPIC for REPL to work. See #2207.-                               then baseCcOpts { ghcOptFPic = toFlag True }-                               else baseCcOpts-               profCcOpts    = vanillaCcOpts `mappend` mempty {-                                 ghcOptProfilingMode = toFlag True,-                                 ghcOptObjSuffix     = toFlag "p_o"-                               }-               sharedCcOpts  = vanillaCcOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                                 ghcOptObjSuffix   = toFlag "dyn_o"-                               }-               odir          = fromFlag (ghcOptObjDir vanillaCcOpts)-           createDirectoryIfMissingVerbose verbosity True odir-           let runGhcProgIfNeeded ccOpts = do-                 needsRecomp <- checkNeedsRecompilation filename ccOpts-                 when needsRecomp $ runGhcProg ccOpts-           runGhcProgIfNeeded vanillaCcOpts-           unless forRepl $-             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)-           unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)-      | filename <- cSources libBi]--  -- TODO: problem here is we need the .c files built first, so we can load them-  -- with ghci, but .c files can depend on .h files generated by ghc by ffi-  -- exports.--  when has_code . ifReplLib $ do-    when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"-    ifReplLib (runGhcProg replOpts)--  -- link:-  when has_code . unless forRepl $ do-    info verbosity "Linking..."-    let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))-                      (cSources libBi)-        cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))-                      (cSources libBi)-        compiler_id = compilerId (compiler lbi)-        vanillaLibFilePath = libTargetDir </> mkLibName uid-        profileLibFilePath = libTargetDir </> mkProfLibName uid-        sharedLibFilePath  = libTargetDir </> mkSharedLibName' buildPlatform compiler_id uid-        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName uid-        libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest-        sharedLibInstallPath = libInstallPath </> mkSharedLibName' buildPlatform compiler_id uid--    stubObjs <- catMaybes <$> sequenceA-      [ findFileWithExtension [objExtension] [libTargetDir]-          (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files-      , x <- allLibModules lib clbi ]-    stubProfObjs <- catMaybes <$> sequenceA-      [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]-          (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files-      , x <- allLibModules lib clbi ]-    stubSharedObjs <- catMaybes <$> sequenceA-      [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]-          (ModuleName.toFilePath x ++"_stub")-      | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files-      , x <- allLibModules lib clbi ]--    hObjs     <- Internal.getHaskellObjects implInfo lib lbi clbi-                      libTargetDir objExtension True-    hProfObjs <--      if withProfLib lbi-              then Internal.getHaskellObjects implInfo lib lbi clbi-                      libTargetDir ("p_" ++ objExtension) True-              else return []-    hSharedObjs <--      if withSharedLib lbi-              then Internal.getHaskellObjects implInfo lib lbi clbi-                      libTargetDir ("dyn_" ++ objExtension) False-              else return []--    -- XXX: This is the only change; determine if there are any-    -- accelerate-generated object files which need to linked into the final-    -- libraries.-    accObjs   <- fmap (nub . concat . Map.elems)-               $ Internal.readBuildInfo-               $ Internal.mkBuildInfoFileName libTargetDir--    unless (null accObjs && null hObjs && null cObjs && null stubObjs) $ do-      rpaths <- getRPaths lbi clbi--      let staticObjectFiles =-                 hObjs-              ++ accObjs-              ++ map (libTargetDir </>) cObjs-              ++ stubObjs-          profObjectFiles =-                 hProfObjs-              ++ accObjs-              ++ map (libTargetDir </>) cProfObjs-              ++ stubProfObjs-          ghciObjFiles =-                 hObjs-              ++ accObjs-              ++ map (libTargetDir </>) cObjs-              ++ stubObjs-          dynamicObjectFiles =-                 hSharedObjs-              ++ accObjs-              ++ map (libTargetDir </>) cSharedObjs-              ++ stubSharedObjs-          -- After the relocation lib is created we invoke ghc -shared-          -- with the dependencies spelled out as -package arguments-          -- and ghc invokes the linker with the proper library paths-          ghcSharedLinkArgs =-              mempty {-                ghcOptShared             = toFlag True,-                ghcOptDynLinkMode        = toFlag GhcDynamicOnly,-                ghcOptInputFiles         = toNubListR dynamicObjectFiles,-                ghcOptOutputFile         = toFlag sharedLibFilePath,-                ghcOptExtra              = nubList $ hcSharedOptions GHC libBi,-                -- For dynamic libs, Mac OS/X needs to know the install location-                -- at build time. This only applies to GHC < 7.8 - see the-                -- discussion in #1660.-                ghcOptDylibName          = if hostOS == OSX-                                              && ghcVersion < mkVersion [7,8]-                                            then toFlag sharedLibInstallPath-                                            else mempty,-                ghcOptHideAllPackages    = toFlag True,-                ghcOptNoAutoLinkPackages = toFlag True,-                ghcOptPackageDBs         = withPackageDB lbi,-                ghcOptThisUnitId = case clbi of-                    LibComponentLocalBuildInfo { componentCompatPackageKey = pk }-                      -> toFlag pk-                    _ -> mempty,-                ghcOptThisComponentId = case clbi of-                    LibComponentLocalBuildInfo { componentInstantiatedWith = insts } ->-                        if null insts-                            then mempty-                            else toFlag (componentComponentId clbi)-                    _ -> mempty,-                ghcOptInstantiatedWith = case clbi of-                    LibComponentLocalBuildInfo { componentInstantiatedWith = insts }-                      -> insts-                    _ -> [],-                ghcOptPackages           = toNubListR $-                                           Internal.mkGhcOptPackages clbi ,-                ghcOptLinkLibs           = nubList $ extraLibs libBi,-                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi,-                ghcOptLinkFrameworks     = toNubListR $ PD.frameworks libBi,-                ghcOptLinkFrameworkDirs  =-                  toNubListR $ PD.extraFrameworkDirs libBi,-                ghcOptRPaths             = rpaths-              }--      info verbosity (show (ghcOptPackages ghcSharedLinkArgs))--      whenVanillaLib False $-        Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles--      whenProfLib $-        Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles--      whenGHCiLib $ do-        (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)-        Internal.combineObjectFiles verbosity lbi ldProg-          ghciLibFilePath ghciObjFiles--      whenSharedLib False $-        runGhcProg ghcSharedLinkArgs----- | Returns True if the modification date of the given source file is newer than--- the object file we last compiled for it, or if no object file exists yet.-checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool-checkNeedsRecompilation filename opts = filename `moreRecentFile` oname-    where oname = getObjectFileName filename opts---- | Finds the object file name of the given source file-getObjectFileName :: FilePath -> GhcOptions -> FilePath-getObjectFileName filename opts = oname-    where odir  = fromFlag (ghcOptObjDir opts)-          oext  = fromFlagOrDefault "o" (ghcOptObjSuffix opts)-          oname = odir </> replaceExtension filename oext---- | Calculate the RPATHs for the component we are building.------ Calculates relative RPATHs when 'relocatable' is set.-getRPaths :: LocalBuildInfo-          -> ComponentLocalBuildInfo -- ^ Component we are building-          -> IO (NubListR FilePath)-getRPaths lbi clbi | supportRPaths hostOS = do-    libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi-    let hostPref = case hostOS of-                     OSX -> "@loader_path"-                     _   -> "$ORIGIN"-        relPath p = if isRelative p then hostPref </> p else p-        rpaths    = toNubListR (map relPath libraryPaths)-    return rpaths-  where-    (Platform _ hostOS) = hostPlatform lbi--    -- The list of RPath-supported operating systems below reflects the-    -- platforms on which Cabal's RPATH handling is tested. It does _NOT_-    -- reflect whether the OS supports RPATH.--    -- E.g. when this comment was written, the *BSD operating systems were-    -- untested with regards to Cabal RPATH handling, and were hence set to-    -- 'False', while those operating systems themselves do support RPATH.-    supportRPaths Linux       = True-    supportRPaths Windows     = False-    supportRPaths OSX         = True-    supportRPaths FreeBSD     = False-    supportRPaths OpenBSD     = False-    supportRPaths NetBSD      = False-    supportRPaths DragonFly   = False-    supportRPaths Solaris     = False-    supportRPaths AIX         = False-    supportRPaths HPUX        = False-    supportRPaths IRIX        = False-    supportRPaths HaLVM       = False-    supportRPaths IOS         = False-    supportRPaths Android     = False-    supportRPaths Ghcjs       = False-    supportRPaths Hurd        = False-    supportRPaths (OtherOS _) = False-    -- Do _not_ add a default case so that we get a warning here when a new OS-    -- is added.--getRPaths _ _ = return mempty---- | Filter the "-threaded" flag when profiling as it does not---   work with ghc-6.8 and older.-hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo-hackThreadedFlag _ _ _ = return---- -------------------------------------------------------------------------------- Utils--supportsDynamicToo :: Compiler -> Bool-supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"-

@@ -1,126 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal--- Copyright   : [2017] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Copied from: https://github.com/haskell/cabal/blob/2.0/Cabal/Distribution/Simple/GHC/Internal.hs-----module Data.Array.Accelerate.LLVM.Native.Distribution.Simple.GHC.Internal (--  mkGHCiLibName,-  ghcLookupProperty,-  filterGhciFlags,-  getHaskellObjects,-  mkGhcOptPackages,-  profDetailLevelFlag,-  combineObjectFiles--) where--#if MIN_VERSION_Cabal(2,0,0)-import Distribution.Backpack-#endif-import Distribution.PackageDescription as PD hiding (Flag)-import Distribution.Simple.Compiler hiding (Flag)-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Program (ConfiguredProgram)-import Distribution.Simple.Program.GHC-import qualified Distribution.Simple.Program.Ld as Ld-import Distribution.Simple.Setup-import Distribution.Simple-import Distribution.Verbosity (Verbosity)-import qualified Distribution.ModuleName as ModuleName--import qualified Data.Map as Map-import System.Directory ( getDirectoryContents )-import System.FilePath ( (</>), (<.>), takeExtension )----- | Strip out flags that are not supported in ghci-filterGhciFlags :: [String] -> [String]-filterGhciFlags = filter supported-  where-    supported ('-':'O':_) = False-    supported "-debug"    = False-    supported "-threaded" = False-    supported "-ticky"    = False-    supported "-eventlog" = False-    supported "-prof"     = False-    supported "-unreg"    = False-    supported _           = True--#if MIN_VERSION_Cabal(1,24,0)-mkGHCiLibName :: UnitId -> String-mkGHCiLibName lib = getHSLibraryName lib <.> "o"-#else-mkGHCiLibName :: LibraryName -> String-mkGHCiLibName (LibraryName lib) = lib <.> "o"-#endif--ghcLookupProperty :: String -> Compiler -> Bool-ghcLookupProperty prop comp =-  case Map.lookup prop (compilerProperties comp) of-    Just "YES" -> True-    _          -> False---- when using -split-objs, we need to search for object files in the--- Module_split directory for each module.-getHaskellObjects :: _GhcImplInfo -> Library -> LocalBuildInfo-                  -> ComponentLocalBuildInfo-                  -> FilePath -> String -> Bool -> IO [FilePath]-getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs-  | splitObjs lbi && allow_split_objs = do-        let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"-            dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)-                   | x <- allLibModules lib clbi ]-        objss <- traverse getDirectoryContents dirs-        let objs = [ dir </> obj-                   | (objs',dir) <- zip objss dirs, obj <- objs',-                     let obj_ext = takeExtension obj,-                     '.':wanted_obj_ext == obj_ext ]-        return objs-  | otherwise  =-        return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext-               | x <- allLibModules lib clbi ]--#if MIN_VERSION_Cabal(2,0,0)-mkGhcOptPackages :: ComponentLocalBuildInfo-                 -> [(OpenUnitId, ModuleRenaming)]-mkGhcOptPackages = componentIncludes-#else-mkGhcOptPackages :: ComponentLocalBuildInfo-                 -> [(InstalledPackageId, PackageId, ModuleRenaming)]-mkGhcOptPackages clbi =-  map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi)))-      (componentPackageDeps clbi)-#endif--profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto-profDetailLevelFlag forLib mpl =-    case mpl of-      ProfDetailNone                -> mempty-      ProfDetailDefault | forLib    -> toFlag GhcProfAutoExported-                        | otherwise -> toFlag GhcProfAutoToplevel-      ProfDetailExportedFunctions   -> toFlag GhcProfAutoExported-      ProfDetailToplevelFunctions   -> toFlag GhcProfAutoToplevel-      ProfDetailAllFunctions        -> toFlag GhcProfAutoAll-      ProfDetailOther _             -> mempty--#if !MIN_VERSION_Cabal(2,0,0)-allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName.ModuleName]-allLibModules lib _ = libModules lib-#endif--combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram-                   -> FilePath -> [FilePath] -> IO ()-#if MIN_VERSION_Cabal(2,1,0)-combineObjectFiles = Ld.combineObjectFiles-#else-combineObjectFiles v _ = Ld.combineObjectFiles v-#endif

@@ -1,14 +1,15 @@ {-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE CPP             #-} {-# LANGUAGE QuasiQuotes     #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns    #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.Embed--- Copyright   : [2017] Trevor L. McDonell+-- Copyright   : [2017..2020] The Accelerate Team -- 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) --@@ -39,14 +40,18 @@ import Control.Monad import Data.Hashable import Foreign.Ptr-import GHC.Ptr                                                      ( Ptr(..) ) import Language.Haskell.TH                                          ( Q, TExp ) import Numeric import System.IO.Unsafe import qualified Language.Haskell.TH                                as TH import qualified Language.Haskell.TH.Syntax                         as TH +#if __GLASGOW_HASKELL__ >= 806+import Data.Maybe+import qualified Data.Set                                           as Set+#endif + instance Embed Native where   embedForTarget = embed @@ -56,7 +61,7 @@ -- embed :: Native -> ObjectR Native -> Q (TExp (ExecutableR Native)) embed target (ObjectR uid nms !_) = do-  objFile <- TH.runIO (evalNative target (cacheOfUID uid))+  objFile <- getObjectFile   funtab  <- forM nms $ \fn -> return [|| ( $$(liftSBS (BS.take (BS.length fn - 65) fn)), $$(makeFFI fn objFile) ) ||]   --   [|| NativeR (unsafePerformIO $ newLifetime (FunctionTable $$(listE funtab))) ||]@@ -64,13 +69,6 @@     listE :: [Q (TExp a)] -> Q (TExp [a])     listE xs = TH.unsafeTExpCoerce (TH.listE (map TH.unTypeQ xs)) -    liftSBS :: ShortByteString -> Q (TExp ShortByteString)-    liftSBS bs =-      let bytes = BS.unpack bs-          len   = BS.length bs-      in-      [|| unsafePerformIO $ BS.createFromPtr $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||]-     makeFFI :: ShortByteString -> FilePath -> Q (TExp (FunPtr ()))     makeFFI (S8.unpack -> fn) objFile = do       i   <- TH.runIO newUnique@@ -79,4 +77,26 @@       ann <- TH.pragAnnD (TH.ValueAnnotation fn') [| (Object objFile) |]       TH.addTopDecls [dec, ann]       TH.unsafeTExpCoerce (TH.varE fn')++    -- Note: [Template Haskell and raw object files]+    --+    -- We can only addForeignFilePath once per object file, otherwise the+    -- linker will complain about duplicate symbols. To work around this,+    -- we use putQ/getQ to keep track of which object files have already+    -- been encountered during compilation _of the current module_. This+    -- means that we might still run into problems if runQ is invoked at+    -- multiple modules.+    --+    getObjectFile :: Q FilePath+    getObjectFile = do+      this <- TH.runIO (evalNative target (cacheOfUID uid))+#if __GLASGOW_HASKELL__ >= 806+      rest <- fromMaybe Set.empty <$> TH.getQ+      if Set.member this rest+         then return ()+         else do+           TH.addForeignFilePath TH.RawObject this+           TH.putQ (Set.insert this rest)+#endif+      return this 

@@ -1,516 +1,1017 @@-{-# LANGUAGE FlexibleContexts         #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GADTs                    #-}-{-# LANGUAGE OverloadedStrings        #-}-{-# LANGUAGE RecordWildCards          #-}-{-# LANGUAGE ScopedTypeVariables      #-}-{-# LANGUAGE TemplateHaskell          #-}-{-# LANGUAGE TypeOperators            #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Execute--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.Native.Execute (--  executeAcc, executeAfun,-  executeOpenAcc--) where---- accelerate-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Error--import Data.Array.Accelerate.LLVM.Analysis.Match-import Data.Array.Accelerate.LLVM.Execute-import Data.Array.Accelerate.LLVM.State--import Data.Array.Accelerate.LLVM.Native.Array.Data-import Data.Array.Accelerate.LLVM.Native.Link-import Data.Array.Accelerate.LLVM.Native.Execute.Async-import Data.Array.Accelerate.LLVM.Native.Execute.Environment-import Data.Array.Accelerate.LLVM.Native.Execute.Marshal-import Data.Array.Accelerate.LLVM.Native.Target-import qualified Data.Array.Accelerate.LLVM.Native.Debug            as Debug---- Use work-stealing scheduler-import Data.Range                                                   ( Range(..) )-import Control.Parallel.Meta                                        ( Executable(..) )-import Data.Array.Accelerate.LLVM.Native.Execute.LBS---- library-import Control.Monad.State                                          ( gets )-import Control.Monad.Trans                                          ( liftIO )-import Data.ByteString.Short                                        ( ShortByteString )-import Data.List                                                    ( find )-import Data.Maybe                                                   ( fromMaybe )-import Data.Time.Clock                                              ( getCurrentTime, diffUTCTime )-import Data.Word                                                    ( Word8 )-import Text.Printf                                                  ( printf )-import Prelude                                                      hiding ( map, sum, scanl, scanr, init )-import qualified Data.ByteString.Short.Char8                        as S8--import Foreign.C-import Foreign.LibFFI-import Foreign.Ptr----- Array expression evaluation--- ------------------------------- Computations are evaluated by traversing the AST bottom up, and for each node--- distinguishing between three cases:------  1. If it is a Use node, we return a reference to the array data. Even though---     we execute with multiple cores, we assume a shared memory multiprocessor---     machine.------  2. If it is a non-skeleton node, such as a let binding or shape conversion,---     then execute directly by updating the environment or similar.------  3. If it is a skeleton node, then we need to execute the generated LLVM---     code.----instance Execute Native where-  map           = simpleOp-  generate      = simpleOp-  transform     = simpleOp-  backpermute   = simpleOp-  fold          = foldOp-  fold1         = fold1Op-  foldSeg       = foldSegOp-  fold1Seg      = foldSegOp-  scanl         = scanOp-  scanl1        = scan1Op-  scanl'        = scan'Op-  scanr         = scanOp-  scanr1        = scan1Op-  scanr'        = scan'Op-  permute       = permuteOp-  stencil1      = simpleOp-  stencil2      = stencil2Op-  aforeign      = aforeignOp----- Skeleton implementation--- --------------------------- Simple kernels just needs to know the shape of the output array.----simpleOp-    :: (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> sh-    -> LLVM Native (Array sh e)-simpleOp exe gamma aenv () sh = withExecutable exe $ \nativeExecutable -> do-  let fun = case functionTable nativeExecutable of-              f:_ -> f-              _   -> $internalError "simpleOp" "no functions found"-  ---  Native{..} <- gets llvmTarget-  liftIO $ do-    out <- allocateArray sh-    executeOp defaultLargePPT fillP fun gamma aenv (IE 0 (size sh)) out-    return out--simpleNamed-    :: (Shape sh, Elt e)-    => ShortByteString-    -> ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> sh-    -> LLVM Native (Array sh e)-simpleNamed name exe gamma aenv () sh = withExecutable exe $ \nativeExecutable -> do-  Native{..} <- gets llvmTarget-  liftIO $ do-    out <- allocateArray sh-    executeOp defaultLargePPT fillP (nativeExecutable !# name) gamma aenv (IE 0 (size sh)) out-    return out----- Note: [Reductions]------ There are two flavours of reduction:------   1. If we are collapsing to a single value, then threads reduce strips of---      the input in parallel, and then a single thread reduces the partial---      reductions to a single value. Load balancing occurs over the input---      stripes.------   2. If this is a multidimensional reduction, then each inner dimension is---      handled by a single thread. Load balancing occurs over the outer---      dimension indices.------ The entry points to executing the reduction are 'foldOp' and 'fold1Op', for--- exclusive and inclusive reductions respectively. These functions handle--- whether the input array is empty. If the input and output arrays are--- non-empty, we then further dispatch (via 'foldCore') to 'foldAllOp' or--- 'foldDimOp' for single or multidimensional reductions, respectively.--- 'foldAllOp' in particular must execute specially whether the gang has--- multiple worker threads which can process the array in parallel.-----fold1Op-    :: (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> (sh :. Int)-    -> LLVM Native (Array sh e)-fold1Op kernel gamma aenv stream sh@(sx :. sz)-  = $boundsCheck "fold1" "empty array" (sz > 0)-  $ case size sh of-      0 -> liftIO $ allocateArray sx   -- empty, but possibly with non-zero dimensions-      _ -> foldCore kernel gamma aenv stream sh--foldOp-    :: (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> (sh :. Int)-    -> LLVM Native (Array sh e)-foldOp kernel gamma aenv stream sh@(sx :. _) =-  case size sh of-    0 -> simpleNamed "generate" kernel gamma aenv stream sx-    _ -> foldCore kernel gamma aenv stream sh--foldCore-    :: (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> (sh :. Int)-    -> LLVM Native (Array sh e)-foldCore kernel gamma aenv stream sh-  | Just Refl <- matchShapeType sh (undefined::DIM1)-  = foldAllOp kernel gamma aenv stream sh-  ---  | otherwise-  = foldDimOp kernel gamma aenv stream sh--foldAllOp-    :: forall aenv e. Elt e-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> DIM1-    -> LLVM Native (Scalar e)-foldAllOp exe gamma aenv () (Z :. sz) = withExecutable exe $ \nativeExecutable -> do-  Native{..} <- gets llvmTarget-  let-      ncpu    = gangSize-      stride  = defaultLargePPT `min` ((sz + ncpu - 1) `quot` ncpu)-      steps   = (sz + stride - 1) `quot` stride-  ---  if ncpu == 1 || sz <= defaultLargePPT-    then liftIO $ do-      -- Sequential reduction-      out <- allocateArray Z-      executeOp 1 fillS (nativeExecutable !# "foldAllS") gamma aenv (IE 0 sz) out-      return out--    else liftIO $ do-      -- Parallel reduction-      out <- allocateArray Z-      tmp <- allocateArray (Z :. steps) :: IO (Vector e)-      executeOp 1 fillP (nativeExecutable !# "foldAllP1") gamma aenv (IE 0 steps) (sz, stride, tmp)-      executeOp 1 fillS (nativeExecutable !# "foldAllP2") gamma aenv (IE 0 steps) (tmp, out)-      return out--foldDimOp-    :: (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> (sh :. Int)-    -> LLVM Native (Array sh e)-foldDimOp exe gamma aenv () (sh :. sz) = withExecutable exe $ \nativeExecutable -> do-  Native{..} <- gets llvmTarget-  let ppt = defaultSmallPPT `max` (defaultLargePPT `quot` (max 1 sz))-  liftIO $ do-    out <- allocateArray sh-    executeOp ppt fillP (nativeExecutable !# "fold") gamma aenv (IE 0 (size sh)) (sz, out)-    return out--foldSegOp-    :: (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> (sh :. Int)-    -> (Z  :. Int)-    -> LLVM Native (Array (sh :. Int) e)-foldSegOp exe gamma aenv () (sh :. _) (Z :. ss) = withExecutable exe $ \nativeExecutable -> do-  Native{..} <- gets llvmTarget-  let-      kernel | segmentOffset  = "foldSegP"-             | otherwise      = "foldSegS"-      n      | segmentOffset  = ss - 1            -- segments array has been 'scanl (+) 0'`ed-             | otherwise      = ss-      ppt    | rank sh == 0   = defaultLargePPT   -- work-steal over the single dimension-             | otherwise      = n                 -- a thread computes all segments along an index-  ---  liftIO $ do-    out <- allocateArray (sh :. n)-    executeOp ppt fillP (nativeExecutable !# kernel) gamma aenv (IE 0 (size (sh :. n))) out-    return out---scanOp-    :: (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> sh :. Int-    -> LLVM Native (Array (sh:.Int) e)-scanOp kernel gamma aenv stream (sz :. n) =-  case n of-    0 -> simpleNamed "generate" kernel gamma aenv stream (sz :. 1)-    _ -> scanCore kernel gamma aenv stream sz n (n+1)--scan1Op-    :: (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> sh :. Int-    -> LLVM Native (Array (sh:.Int) e)-scan1Op kernel gamma aenv stream (sz :. n)-  = $boundsCheck "scan1" "empty array" (n > 0)-  $ scanCore kernel gamma aenv stream sz n n--scanCore-    :: forall aenv sh e. (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> sh-    -> Int-    -> Int-    -> LLVM Native (Array (sh:.Int) e)-scanCore exe gamma aenv () sz n m = withExecutable exe $ \nativeExecutable -> do-  Native{..} <- gets llvmTarget-  let-      ncpu    = gangSize-      stride  = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu)-      steps   = (n + stride - 1) `quot` stride-      steps'  = steps - 1-  ---  if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT-    then liftIO $ do-      -- Either:-      ---      --  1. Sequential scan of an array of any rank-      ---      --  2. Parallel scan of multidimensional array: threads scan along the-      --     length of the innermost dimension. Threads are scheduled over the-      --     inner dimensions.-      ---      --  3. Small 1D array. Since parallel scan requires ~4n data transfer-      --     compared to ~2n in the sequential case, it is only worthwhile if-      --     the extra cores can offset the increased bandwidth requirements.-      ---      out <- allocateArray (sz :. m)-      executeOp 1 fillP (nativeExecutable !# "scanS") gamma aenv (IE 0 (size sz)) out-      return out--    else liftIO $ do-      -- parallel one-dimensional scan-      out <- allocateArray (sz :. m)-      tmp <- allocateArray (Z  :. steps) :: IO (Vector e)-      executeOp 1 fillP (nativeExecutable !# "scanP1") gamma aenv (IE 0 steps) (stride, steps', out, tmp)-      executeOp 1 fillS (nativeExecutable !# "scanP2") gamma aenv (IE 0 steps) tmp-      executeOp 1 fillP (nativeExecutable !# "scanP3") gamma aenv (IE 0 steps') (stride, out, tmp)-      return out---scan'Op-    :: forall aenv sh e. (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> sh :. Int-    -> LLVM Native (Array (sh:.Int) e, Array sh e)-scan'Op native gamma aenv stream sh@(sz :. n) =-  case n of-    0 -> do-      out <- liftIO $ allocateArray (sz :. 0)-      sum <- simpleNamed "generate" native gamma aenv stream sz-      return (out, sum)-    ---    _ -> scan'Core native gamma aenv stream sh--scan'Core-    :: forall aenv sh e. (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> sh :. Int-    -> LLVM Native (Array (sh:.Int) e, Array sh e)-scan'Core exe gamma aenv () sh@(sz :. n) = withExecutable exe $ \nativeExecutable -> do-  Native{..} <- gets llvmTarget-  let-      ncpu    = gangSize-      stride  = defaultLargePPT `min` ((n + ncpu - 1) `quot` ncpu)-      steps   = (n + stride - 1) `quot` stride-      steps'  = steps - 1-  ---  if ncpu == 1 || rank sz > 0 || n <= 2 * defaultLargePPT-    then liftIO $ do-      out <- allocateArray sh-      sum <- allocateArray sz-      executeOp 1 fillP (nativeExecutable !# "scanS") gamma aenv (IE 0 (size sz)) (out,sum)-      return (out,sum)--    else liftIO $ do-      tmp <- allocateArray (Z :. steps) :: IO (Vector e)-      out <- allocateArray sh-      sum <- allocateArray sz-      executeOp 1 fillP (nativeExecutable !# "scanP1") gamma aenv (IE 0 steps)  (stride, steps', out, tmp)-      executeOp 1 fillS (nativeExecutable !# "scanP2") gamma aenv (IE 0 steps)  (sum, tmp)-      executeOp 1 fillP (nativeExecutable !# "scanP3") gamma aenv (IE 0 steps') (stride, out, tmp)-      return (out,sum)----- Forward permutation, specified by an indexing mapping into an array and a--- combination function to combine elements.----permuteOp-    :: (Shape sh, Shape sh', Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> Bool-    -> sh-    -> Array sh' e-    -> LLVM Native (Array sh' e)-permuteOp exe gamma aenv () inplace shIn dfs = withExecutable exe $ \nativeExecutable -> do-  Native{..} <- gets llvmTarget-  out        <- if inplace-                  then return dfs-                  else cloneArray dfs-  let-      ncpu    = gangSize-      n       = size shIn-      m       = size (shape out)-  ---  if ncpu == 1 || n <= defaultLargePPT-    then liftIO $ do-      -- sequential permutation-      executeOp 1 fillS (nativeExecutable !# "permuteS") gamma aenv (IE 0 n) out--    else liftIO $ do-      -- parallel permutation-      case lookupFunction "permuteP_rmw" nativeExecutable of-        Just f  -> executeOp defaultLargePPT fillP f gamma aenv (IE 0 n) out-        Nothing -> do-          barrier@(Array _ adb) <- allocateArray (Z :. m) :: IO (Vector Word8)-          memset (ptrsOfArrayData adb) 0 m-          executeOp defaultLargePPT fillP (nativeExecutable !# "permuteP_mutex") gamma aenv (IE 0 n) (out, barrier)--  return out---stencil2Op-    :: (Shape sh, Elt e)-    => ExecutableR Native-    -> Gamma aenv-    -> Aval aenv-    -> Stream-    -> sh-    -> sh-    -> LLVM Native (Array sh e)-stencil2Op kernel gamma aenv stream sh1 sh2 =-  simpleOp kernel gamma aenv stream (sh1 `intersect` sh2)---aforeignOp-    :: (Arrays as, Arrays bs)-    => String-    -> (Stream -> as -> LLVM Native bs)-    -> Stream-    -> as-    -> LLVM Native bs-aforeignOp name asm stream arr = do-  wallBegin <- liftIO $ getCurrentTime-  result    <- Debug.timed Debug.dump_exec (\wall cpu -> printf "exec: %s %s" name (Debug.elapsedP wall cpu)) (asm stream arr)-  wallEnd   <- liftIO $ getCurrentTime-  liftIO $ Debug.addProcessorTime Debug.Native (realToFrac (diffUTCTime wallEnd wallBegin))-  return result----- Skeleton execution--- --------------------(!#) :: FunctionTable -> ShortByteString -> Function-(!#) exe name-  = fromMaybe ($internalError "lookupFunction" ("function not found: " ++ S8.unpack name))-  $ lookupFunction name exe--lookupFunction :: ShortByteString -> FunctionTable -> Maybe Function-lookupFunction name nativeExecutable = do-  find (\(n,_) -> n == name) (functionTable nativeExecutable)---- Execute the given function distributed over the available threads.----executeOp-    :: Marshalable args-    => Int-    -> Executable-    -> Function-    -> Gamma aenv-    -> Aval aenv-    -> Range-    -> args-    -> IO ()-executeOp ppt exe (name, f) gamma aenv r args = do-  args' <- marshal (undefined::Native) () (args, (gamma, aenv))-  ---  runExecutable exe name ppt r $ \start end _tid -> do-   monitorProcTime             $-    callFFI f retVoid (argInt start : argInt end : args')----- Standard C functions--- ----------------------memset :: Ptr Word8 -> Word8 -> Int -> IO ()-memset p w s = c_memset p (fromIntegral w) (fromIntegral s) >> return ()--foreign import ccall unsafe "string.h memset" c_memset-    :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)----- Debugging--- -----------monitorProcTime :: IO a -> IO a-monitorProcTime = Debug.withProcessor Debug.Native+{-# LANGUAGE BangPatterns             #-}+{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs                    #-}+{-# LANGUAGE LambdaCase               #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE RecordWildCards          #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE TemplateHaskell          #-}+{-# LANGUAGE TypeApplications         #-}+{-# LANGUAGE TypeOperators            #-}+{-# LANGUAGE ViewPatterns             #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute+-- Copyright   : [2014..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Execute (++  executeAcc,+  executeOpenAcc++) where++import Data.Array.Accelerate.Analysis.Match+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type++import Data.Array.Accelerate.LLVM.Execute+import Data.Array.Accelerate.LLVM.Execute.Async (FutureArraysR)+import Data.Array.Accelerate.LLVM.State++import Data.Array.Accelerate.LLVM.Native.Array.Data+import Data.Array.Accelerate.LLVM.Native.Execute.Async+import Data.Array.Accelerate.LLVM.Native.Execute.Divide+import Data.Array.Accelerate.LLVM.Native.Execute.Environment        ( Val )+import Data.Array.Accelerate.LLVM.Native.Execute.Marshal+import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler+import Data.Array.Accelerate.LLVM.Native.Link+import Data.Array.Accelerate.LLVM.Native.Target+import qualified Data.Array.Accelerate.LLVM.Native.Debug            as Debug++import Control.Concurrent                                           ( myThreadId )+import Control.Monad.State                                          ( gets )+import Control.Monad.Trans                                          ( liftIO )+import Data.ByteString.Short                                        ( ShortByteString )+import Data.IORef                                                   ( newIORef, readIORef, writeIORef )+import Data.List                                                    ( find )+import Data.Maybe                                                   ( fromMaybe )+import Data.Sequence                                                ( Seq )+import Data.Foldable                                                ( asum )+import System.CPUTime                                               ( getCPUTime )+import Text.Printf                                                  ( printf )+import qualified Data.ByteString.Short.Char8                        as S8+import qualified Data.Sequence                                      as Seq+import qualified Data.DList                                         as DL+import Prelude                                                      hiding ( map, sum, scanl, scanr, init )++import Foreign.LibFFI+import Foreign.Ptr++{-# SPECIALISE INLINE executeAcc     :: ExecAcc     Native      a ->             Par Native (FutureArraysR Native a) #-}+{-# SPECIALISE INLINE executeOpenAcc :: ExecOpenAcc Native aenv a -> Val aenv -> Par Native (FutureArraysR Native a) #-}++-- Array expression evaluation+-- ---------------------------++-- Computations are evaluated by traversing the AST bottom up, and for each node+-- distinguishing between three cases:+--+--  1. If it is a Use node, we return a reference to the array data. Even though+--     we execute with multiple cores, we assume a shared memory multiprocessor+--     machine.+--+--  2. If it is a non-skeleton node, such as a let binding or shape conversion,+--     then execute directly by updating the environment or similar.+--+--  3. If it is a skeleton node, then we need to execute the generated LLVM+--     code.+--+instance Execute Native where+  {-# INLINE map         #-}+  {-# INLINE generate    #-}+  {-# INLINE transform   #-}+  {-# INLINE backpermute #-}+  {-# INLINE fold        #-}+  {-# INLINE foldSeg     #-}+  {-# INLINE scan        #-}+  {-# INLINE scan'       #-}+  {-# INLINE permute     #-}+  {-# INLINE stencil1    #-}+  {-# INLINE stencil2    #-}+  {-# INLINE aforeign    #-}+  map           = mapOp+  generate      = generateOp+  transform     = transformOp+  backpermute   = backpermuteOp+  fold True     = foldOp+  fold False    = fold1Op+  foldSeg i _   = foldSegOp i+  scan _ True   = scanOp+  scan _ False  = scan1Op+  scan' _       = scan'Op+  permute       = permuteOp+  stencil1      = stencil1Op+  stencil2      = stencil2Op+  aforeign      = aforeignOp+++-- Skeleton implementation+-- -----------------------++-- Simple kernels just needs to know the shape of the output array.+--+{-# INLINE simpleOp #-}+simpleOp+    :: HasCallStack+    => ShortByteString+    -> ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh+    -> Par Native (Future (Array sh e))+simpleOp name repr NativeR{..} gamma aenv sh = do+  let fun   = nativeExecutable !# name+      param = TupRsingle $ ParamRarray repr+  Native{..} <- gets llvmTarget+  future     <- new+  result     <- allocateRemote repr sh+  scheduleOp fun gamma aenv (arrayRshape repr) sh param result+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable   -- XXX: must not unload the object code early+  return future++-- Mapping over an array can ignore the dimensionality of the array and+-- treat it as its underlying linear representation.+--+{-# INLINE mapOp #-}+mapOp+    :: HasCallStack+    => Maybe (a :~: b)+    -> ArrayR (Array sh a)+    -> TypeR b+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Array sh a+    -> Par Native (Future (Array sh b))+mapOp inplace repr tp NativeR{..} gamma aenv input = do+  let fun   = nativeExecutable !# "map"+      sh    = shape input+      shr   = arrayRshape repr+      repr' = ArrayR shr tp+      param = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr)+  Native{..} <- gets llvmTarget+  future     <- new+  result     <- case inplace of+                  Just Refl -> return input+                  Nothing   -> allocateRemote repr' sh+  scheduleOp fun gamma aenv dim1 ((), size shr sh) param (result, input)+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable+  return future++{-# INLINE generateOp #-}+generateOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh+    -> Par Native (Future (Array sh e))+generateOp = simpleOp "generate"++{-# INLINE transformOp #-}+transformOp+    :: HasCallStack+    => ArrayR (Array sh  a)+    -> ArrayR (Array sh' b)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh'+    -> Array sh a+    -> Par Native (Future (Array sh' b))+transformOp repr repr' NativeR{..} gamma aenv sh' input = do+  let fun = nativeExecutable !# "transform"+  Native{..} <- gets llvmTarget+  future     <- new+  result     <- allocateRemote repr' sh'+  let param = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray repr)+  scheduleOp fun gamma aenv (arrayRshape repr') sh' param (result, input)+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable+  return future++{-# INLINE backpermuteOp #-}+backpermuteOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ShapeR sh'+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh'+    -> Array sh e+    -> Par Native (Future (Array sh' e))+backpermuteOp (ArrayR shr tp) shr' = transformOp (ArrayR shr tp) (ArrayR shr' tp)++-- Note: [Reductions]+--+-- There are two flavours of reduction:+--+--   1. If we are collapsing to a single value, then threads reduce strips of+--      the input in parallel, and then a single thread reduces the partial+--      reductions to a single value. Load balancing occurs over the input+--      stripes.+--+--   2. If this is a multidimensional reduction, then each inner dimension is+--      handled by a single thread. Load balancing occurs over the outer+--      dimension indices.+--+-- The entry points to executing the reduction are 'foldOp' and 'fold1Op', for+-- exclusive and inclusive reductions respectively. These functions handle+-- whether the input array is empty. If the input and output arrays are+-- non-empty, we then further dispatch (via 'foldCore') to 'foldAllOp' or+-- 'foldDimOp' for single or multidimensional reductions, respectively.+-- 'foldAllOp' in particular behaves differently whether we are evaluating the+-- array in parallel or sequentially.+--++{-# INLINE fold1Op #-}+fold1Op+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array sh e))+fold1Op repr exe gamma aenv arr@(delayedShape -> sh@(sx, sz))+  = boundsCheck "empty array" (sz > 0)+  $ case size (ShapeRsnoc $ arrayRshape repr) sh of+      0 -> newFull =<< allocateRemote repr sx    -- empty, but possibly with non-zero dimensions+      _ -> foldCore repr exe gamma aenv arr++{-# INLINE foldOp #-}+foldOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array sh e))+foldOp repr exe gamma aenv arr@(delayedShape -> sh@(sx, _)) =+  case size (ShapeRsnoc $ arrayRshape repr) sh of+    0 -> generateOp repr exe gamma aenv sx+    _ -> foldCore repr exe gamma aenv arr++{-# INLINE foldCore #-}+foldCore+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array sh e))+foldCore repr exe gamma aenv arr+  | ArrayR ShapeRz tp <- repr+  = foldAllOp tp exe gamma aenv arr+  --+  | otherwise+  = foldDimOp repr exe gamma aenv arr++{-# INLINE foldAllOp #-}+foldAllOp+    :: HasCallStack+    => TypeR e+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Vector e)+    -> Par Native (Future (Scalar e))+foldAllOp tp NativeR{..} gamma aenv arr = do+  Native{..}  <- gets llvmTarget+  future      <- new+  result      <- allocateRemote (ArrayR dim0 tp) ()+  let+      minsize = 4096+      splits  = numWorkers workers+      ranges  = divideWork1 splits minsize ((), 0) sh (,,)+      steps   = Seq.length ranges+      sh      = delayedShape arr+  --+  if steps <= 1+    then+      let param = TupRsingle (ParamRarray $ ArrayR dim0 tp) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR dim1 tp)+      in  scheduleOpUsing ranges (nativeExecutable !# "foldAllS") gamma aenv dim1 param (result, manifest arr)+            `andThen` do putIO workers future result+                         touchLifetime nativeExecutable++    else do+      let param1 = TupRsingle (ParamRarray $ ArrayR dim1 tp) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR dim1 tp)+      let param2 = TupRsingle (ParamRarray $ ArrayR dim1 tp) `TupRpair` TupRsingle (ParamRarray $ ArrayR dim0 tp)+      tmp   <- allocateRemote (ArrayR dim1 tp) ((), steps)+      job2  <- mkJobUsing (Seq.singleton (0, ((), 0), ((), steps))) (nativeExecutable !# "foldAllP2") gamma aenv dim1 param2 (tmp, result)+                 `andThen` do putIO workers future result+                              touchLifetime nativeExecutable++      job1  <- mkJobUsingIndex ranges (nativeExecutable !# "foldAllP1") gamma aenv dim1 param1 (tmp, manifest arr)+                 `andThen` do schedule workers job2++      liftIO $ schedule workers job1+  --+  return future+++{-# INLINE foldDimOp #-}+foldDimOp+    :: HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array sh e))+foldDimOp repr NativeR{..} gamma aenv arr@(delayedShape -> (sh, _)) = do+  Native{..}  <- gets llvmTarget+  future      <- new+  result      <- allocateRemote repr sh+  let+      ArrayR shr tp = repr+      fun     = nativeExecutable !# "fold"+      splits  = numWorkers workers+      minsize = 1+      param   = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray $ ArrayR (ShapeRsnoc shr) tp)+  --+  scheduleOpWith splits minsize fun gamma aenv shr sh param (result, manifest arr)+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable+  return future+++{-# INLINE foldSegOp #-}+foldSegOp+    :: HasCallStack+    => IntegralType i+    -> ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Delayed (Segments i)+    -> Par Native (Future (Array (sh, Int) e))+foldSegOp int repr NativeR{..} gamma aenv input@(delayedShape -> (sh, _)) segments@(delayedShape -> ((), ss)) = do+  Native{..}  <- gets llvmTarget+  future      <- new+  let+      n       = ss-1+      splits  = numWorkers workers+      minsize = 1+      shR     = arrayRshape repr+      segR    = ArrayR dim1 $ TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType int+      param   = TupRsingle (ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray segR)+  --+  result  <- allocateRemote repr (sh, n)+  scheduleOpWith splits minsize (nativeExecutable !# "foldSegP") gamma aenv shR (sh, n) param ((result, manifest input), manifest segments)+    `andThen` do putIO workers future result+                 touchLifetime nativeExecutable++  return future+++{-# INLINE scanOp #-}+scanOp+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e))+scanOp repr exe gamma aenv arr@(delayedShape -> (sz, n)) =+  case n of+    0 -> generateOp repr exe gamma aenv (sz, 1)+    _ -> scanCore   repr exe gamma aenv (n+1) arr++{-# INLINE scan1Op #-}+scan1Op+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e))+scan1Op repr exe gamma aenv arr@(delayedShape -> (_, n))+  = boundsCheck "empty array" (n > 0)+  $ scanCore repr exe gamma aenv n arr++{-# INLINE scanCore #-}+scanCore+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Int        -- output size of innermost dimension+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e))+scanCore repr NativeR{..} gamma aenv m input@(delayedShape -> (sz, n)) = do+  Native{..}  <- gets llvmTarget+  future      <- new+  result      <- allocateRemote repr (sz, m)+  --+  let paramA = TupRsingle $ ParamRarray repr+      param  = paramA `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+      shR    = arrayRshape (reduceRank repr)++  if isMultiDim $ arrayRshape repr+    -- This is a multidimensional scan. Each partial scan result is evaluated+    -- individually by a thread, so no inter-thread communication is required.+    then+      let+          fun     = nativeExecutable !# "scanS"+          splits  = numWorkers workers+          minsize = 1+      in+      scheduleOpWith splits minsize fun gamma aenv shR sz param (result, manifest input)+        `andThen` do putIO workers future result+                     touchLifetime nativeExecutable++    -- This is a one-dimensional scan. If the array is small just compute it+    -- sequentially using a single thread, otherwise we require multiple steps+    -- to execute it in parallel.+    else+      if n < 8192+        -- sequential execution+        then+          scheduleOpUsing (Seq.singleton (0, (), ())) (nativeExecutable !# "scanS") gamma aenv dim0 param (result, manifest input)+            `andThen` do putIO workers future result+                         touchLifetime nativeExecutable++        -- parallel execution+        else do+          let+              splits   = numWorkers workers+              minsize  = 8192+              ranges   = divideWork dim1 splits minsize ((), 0) ((), n) (,,)+              steps    = Seq.length ranges+              reprTmp  = ArrayR dim1 $ arrayRtype repr+              paramTmp = TupRsingle $ ParamRarray reprTmp+              param1   = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+              param3   = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp+          --+          -- XXX: Should the sequential scan of the carry-in values just be+          -- executed immediately as part of the finalisation action?+          --+          tmp   <- allocateRemote (ArrayR dim1 $ arrayRtype repr) ((), steps)+          job3  <- mkJobUsingIndex ranges (nativeExecutable !# "scanP3") gamma aenv dim1 param3 ((steps, result), tmp)+                     `andThen` do putIO workers future result+                                  touchLifetime nativeExecutable+          job2  <- mkJobUsing (Seq.singleton (0, ((), 0), ((), steps))) (nativeExecutable !# "scanP2") gamma aenv dim1 paramTmp tmp+                     `andThen` schedule workers job3+          job1  <- mkJobUsingIndex ranges (nativeExecutable !# "scanP1") gamma aenv dim1 param1 (((steps, result), tmp), manifest input)+                     `andThen` schedule workers job2++          liftIO $ schedule workers job1+  --+  return future+++{-# INLINE scan'Op #-}+scan'Op+    :: HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e, Array sh e))+scan'Op repr exe gamma aenv arr@(delayedShape -> (sz, n)) = do+  case n of+    0 -> do+      out     <- allocateRemote repr (sz, 0)+      sum     <- generateOp (reduceRank repr) exe gamma aenv sz+      future  <- new+      fork $ do sum' <- get sum+                put future (out, sum')+      return future+    --+    _ -> scan'Core repr exe gamma aenv arr++{-# INLINE scan'Core #-}+scan'Core+    :: forall aenv sh e. HasCallStack+    => ArrayR (Array (sh, Int) e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array (sh, Int) e)+    -> Par Native (Future (Array (sh, Int) e, Array sh e))+scan'Core repr NativeR{..} gamma aenv input@(delayedShape -> sh@(sz, n)) = do+  let+      ArrayR shR eR   = repr+      ShapeRsnoc shR' = shR+      repr'           = ArrayR shR' eR+      paramA          = TupRsingle $ ParamRarray repr+      paramA'         = TupRsingle $ ParamRarray repr'+  --+  Native{..}  <- gets llvmTarget+  future      <- new+  result      <- allocateRemote repr  sh+  sums        <- allocateRemote repr' sz+  --+  if isMultiDim shR+    -- This is a multidimensional scan. Each partial scan result is evaluated+    -- individually by a thread, so no inter-thread communication is required.+    --+    then+      let fun     = nativeExecutable !# "scanS"+          splits  = numWorkers workers+          minsize = 1+          param   = paramA `TupRpair` paramA' `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+      in+      scheduleOpWith splits minsize fun gamma aenv shR' sz param ((result, sums), manifest input)+        `andThen` do putIO workers future (result, sums)+                     touchLifetime nativeExecutable++    -- One dimensional scan. If the array is small just compute it sequentially+    -- with a single thread, otherwise we require multiple steps to execute it+    -- in parallel.+    --+    else+      if n < 8192+        -- sequential execution+        then+          let param = paramA `TupRpair` paramA' `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+          in  scheduleOpUsing (Seq.singleton (0, (), ())) (nativeExecutable !# "scanS") gamma aenv dim0 param ((result, sums), manifest input)+                `andThen` do putIO workers future (result, sums)+                             touchLifetime nativeExecutable++        -- parallel execution+        else do+          let+              splits   = numWorkers workers+              minsize  = 8192+              ranges   = divideWork1 splits minsize ((), 0) ((), n) (,,)+              steps    = Seq.length ranges+              reprTmp  = ArrayR dim1 eR+              paramTmp = TupRsingle $ ParamRarray reprTmp+              param1   = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+              param2   = paramA' `TupRpair` paramTmp+              param3   = TupRsingle ParamRint `TupRpair` paramA `TupRpair` paramTmp+          --+          tmp   <- allocateRemote reprTmp ((), steps)+          job3  <- mkJobUsingIndex ranges (nativeExecutable !# "scanP3") gamma aenv dim1 param3 ((steps, result), tmp)+                     `andThen` do putIO workers future (result, sums)+                                  touchLifetime nativeExecutable+          job2  <- mkJobUsing (Seq.singleton (0, ((), 0), ((), steps))) (nativeExecutable !# "scanP2") gamma aenv dim1 param2 (sums, tmp)+                     `andThen` schedule workers job3+          job1  <- mkJobUsingIndex ranges (nativeExecutable !# "scanP1") gamma aenv dim1 param1 (((steps, result), tmp), manifest input)+                     `andThen` schedule workers job2++          liftIO $ schedule workers job1+  --+  return future++isMultiDim :: ShapeR sh -> Bool+isMultiDim (ShapeRsnoc ShapeRz) = False+isMultiDim _                    = True++-- Forward permutation, specified by an indexing mapping into an array and a+-- combination function to combine elements.+--+{-# INLINE permuteOp #-}+permuteOp+    :: forall sh e sh' aenv. HasCallStack+    => Bool+    -> ArrayR (Array sh e)+    -> ShapeR sh'+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Array sh' e+    -> Delayed (Array sh e)+    -> Par Native (Future (Array sh' e))+permuteOp inplace repr shr' NativeR{..} gamma aenv defaults@(shape -> shOut) input@(delayedShape -> shIn) = do+  let+      ArrayR shr tp = repr+      repr' = ArrayR shr' tp+  Native{..}  <- gets llvmTarget+  future      <- new+  result      <- if inplace+                   then Debug.trace Debug.dump_exec               "exec: permute/inplace"                            $ return defaults+                   else Debug.timed Debug.dump_exec (\wall cpu -> "exec: permute/clone " ++ Debug.elapsedS wall cpu) $ liftPar (cloneArray repr' defaults)+  let+      splits  = numWorkers workers+      minsize = case shr of+                  ShapeRsnoc ShapeRz              -> 4096+                  ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64+                  _                               -> 16+      ranges  = divideWork shr splits minsize (empty shr) shIn (,,)+      steps   = Seq.length ranges+      paramR = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+  --+  if steps <= 1+    -- sequential execution does not require handling critical sections+    then+      scheduleOpUsing ranges (nativeExecutable !# "permuteS") gamma aenv shr paramR (result, manifest input)+        `andThen` do putIO workers future result+                     touchLifetime nativeExecutable++    -- parallel execution+    else+      case lookupFunction "permuteP_rmw" nativeExecutable of+        -- using atomic operations+        Just f ->+          scheduleOpUsing ranges f gamma aenv shr paramR (result, manifest input)+            `andThen` do putIO workers future result+                         touchLifetime nativeExecutable++        -- uses a temporary array of spin-locks to guard the critical section+        Nothing -> do+          let m           = size shr' shOut+              reprBarrier = ArrayR dim1 $ TupRsingle scalarTypeWord8+              paramR'     = TupRsingle (ParamRarray repr') `TupRpair` TupRsingle (ParamRarray reprBarrier) `TupRpair` TupRsingle (ParamRmaybe $ ParamRarray repr)+          --+          barrier@(Array _ adb) <- allocateRemote reprBarrier ((), m) :: Par Native (Vector Word8)+          liftIO $ memset (unsafeUniqueArrayPtr adb) 0 m+          scheduleOpUsing ranges (nativeExecutable !# "permuteP_mutex") gamma aenv shr paramR' ((result, barrier), manifest input)+            `andThen` do putIO workers future result+                         touchLifetime nativeExecutable+  --+  return future+++{-# INLINE stencil1Op #-}+stencil1Op+    :: HasCallStack+    => TypeR a+    -> ArrayR (Array sh b)+    -> sh+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array sh a)+    -> Par Native (Future (Array sh b))+stencil1Op tp repr halo exe gamma aenv input@(delayedShape -> sh) =+  stencilCore repr exe gamma aenv halo sh (TupRsingle $ ParamRmaybe $ ParamRarray $ ArrayR (arrayRshape repr) tp) (manifest input)++{-# INLINE stencil2Op #-}+stencil2Op+    :: forall aenv sh a b c. HasCallStack+    => TypeR a+    -> TypeR b+    -> ArrayR (Array sh c)+    -> sh+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> Delayed (Array sh a)+    -> Delayed (Array sh b)+    -> Par Native (Future (Array sh c))+stencil2Op t1 t2 repr halo exe gamma aenv input1@(delayedShape -> sh1) input2@(delayedShape -> sh2) =+  stencilCore repr exe gamma aenv halo (intersect (arrayRshape repr) sh1 sh2) (param t1 `TupRpair` param t2) (manifest input1, manifest input2)+  where+    shr = arrayRshape repr+    param :: TypeR t -> ParamsR Native (Maybe (Array sh t))+    param = TupRsingle . ParamRmaybe . ParamRarray . ArrayR shr++{-# INLINE stencilCore #-}+stencilCore+    :: forall aenv sh e params. HasCallStack+    => ArrayR (Array sh e)+    -> ExecutableR Native+    -> Gamma aenv+    -> Val aenv+    -> sh                       -- border dimensions (i.e. index of first interior element)+    -> sh                       -- output array size+    -> ParamsR Native params+    -> params+    -> Par Native (Future (Array sh e))+stencilCore repr NativeR{..} gamma aenv halo sh paramsR params = do+  Native{..} <- gets llvmTarget+  future     <- new+  result     <- allocateRemote repr sh+  let+      shr     = arrayRshape repr+      inside  = nativeExecutable !# "stencil_inside"+      border  = nativeExecutable !# "stencil_border"++      splits  = numWorkers workers+      minsize = case shr of+                  ShapeRsnoc ShapeRz              -> 4096+                  ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64+                  _                               -> 16++      ins     = divideWork shr splits minsize halo (sub sh halo) (,,)+      outs    = asum . flip fmap (stencilBorders shr sh halo) $ \(u,v) -> divideWork shr splits minsize u v (,,)++      sub :: sh -> sh -> sh+      sub a b = go shr a b+        where+          go :: ShapeR t -> t -> t -> t+          go ShapeRz          ()      ()      = ()+          go (ShapeRsnoc shr') (xa,xb) (ya,yb) = (go shr' xa ya, xb - yb)++      paramsR' = TupRsingle (ParamRarray repr) `TupRpair` paramsR+  --+  jobsInside <- mkTasksUsing ins  inside gamma aenv shr paramsR' (result, params)+  jobsBorder <- mkTasksUsing outs border gamma aenv shr paramsR' (result, params)+  let jobTasks  = jobsInside Seq.>< jobsBorder+      jobDone   = Just $ do putIO workers future result+                            touchLifetime nativeExecutable+  --+  liftIO $ schedule workers =<< timed "stencil" Job{..}+  return future++-- Compute the stencil border regions, where we may need to evaluate the+-- boundary conditions.+--+{-# INLINE stencilBorders #-}+stencilBorders+    :: forall sh. HasCallStack+    => ShapeR sh+    -> sh+    -> sh+    -> Seq (sh, sh)+stencilBorders shr sh halo = Seq.fromFunction (2 * rank shr) face+  where+    face :: Int -> (sh, sh)+    face n = go n shr sh halo++    go :: Int -> ShapeR t -> t -> t -> (t, t)+    go _ ShapeRz          ()         ()         = ((), ())+    go n (ShapeRsnoc shr') (sha, sza) (shb, szb)+      = let+            (sha', shb')  = go (n-2) shr' sha shb+            (sza', szb')+              | n <  0    = (0,       sza)+              | n == 0    = (0,       szb)+              | n == 1    = (sza-szb, sza)+              | otherwise = (szb,     sza-szb)+        in+        ((sha', sza'), (shb', szb'))++{-# INLINE aforeignOp #-}+aforeignOp+    :: HasCallStack+    => String+    -> ArraysR as+    -> ArraysR bs+    -> (as -> Par Native (Future bs))+    -> as+    -> Par Native (Future bs)+aforeignOp name _ _ asm arr = do+  wallBegin <- liftIO getMonotonicTime+  result    <- Debug.timed Debug.dump_exec (\wall cpu -> printf "exec: %s %s" name (Debug.elapsedP wall cpu)) (asm arr)+  wallEnd   <- liftIO getMonotonicTime+  liftIO $ Debug.addProcessorTime Debug.Native (wallEnd - wallBegin)+  return result+++-- Skeleton execution+-- ------------------++(!#) :: HasCallStack => Lifetime FunctionTable -> ShortByteString -> Function+(!#) exe name+  = fromMaybe (internalError ("function not found: " ++ S8.unpack name))+  $ lookupFunction name exe++lookupFunction :: ShortByteString -> Lifetime FunctionTable -> Maybe Function+lookupFunction name nativeExecutable = do+  find (\(n,_) -> n == name) (functionTable (unsafeGetValue nativeExecutable))++andThen :: (Maybe a -> t) -> a -> t+andThen f g = f (Just g)++delayedShape :: Delayed (Array sh e) -> sh+delayedShape (Delayed sh) = sh+delayedShape (Manifest a) = shape a++manifest :: Delayed (Array sh e) -> Maybe (Array sh e)+manifest (Manifest a) = Just a+manifest Delayed{}    = Nothing+++{-# INLINABLE scheduleOp #-}+scheduleOp+    :: HasCallStack+    => Function+    -> Gamma aenv+    -> Val aenv+    -> ShapeR sh+    -> sh+    -> ParamsR Native params+    -> params+    -> Maybe Action+    -> Par Native ()+scheduleOp fun gamma aenv shr sz paramsR params done = do+  Native{..} <- gets llvmTarget+  let+      splits  = numWorkers workers+      minsize = case shr of+                  ShapeRsnoc ShapeRz              -> 4096+                  ShapeRsnoc (ShapeRsnoc ShapeRz) -> 64+                  _                               -> 16+  --+  scheduleOpWith splits minsize fun gamma aenv shr sz paramsR params done++-- Schedule an operation over the entire iteration space, specifying the number+-- of partitions and minimum dimension size.+--+{-# INLINABLE scheduleOpWith #-}+scheduleOpWith+    :: Int            -- # subdivisions (hint)+    -> Int            -- minimum size of a dimension (must be a power of two)+    -> Function       -- function to execute+    -> Gamma aenv+    -> Val aenv+    -> ShapeR sh+    -> sh+    -> ParamsR Native params+    -> params+    -> Maybe Action   -- run after the last piece completes+    -> Par Native ()+scheduleOpWith splits minsize fun gamma aenv shr sz paramsR params done = do+  Native{..} <- gets llvmTarget+  job        <- mkJob splits minsize fun gamma aenv shr (empty shr) sz paramsR params done+  liftIO $ schedule workers job++{-# INLINABLE scheduleOpUsing #-}+scheduleOpUsing+    :: Seq (Int, sh, sh)+    -> Function+    -> Gamma aenv+    -> Val aenv+    -> ShapeR sh+    -> ParamsR Native params+    -> params+    -> Maybe Action+    -> Par Native ()+scheduleOpUsing ranges fun gamma aenv shr paramsR params jobDone = do+  Native{..} <- gets llvmTarget+  job        <- mkJobUsing ranges fun gamma aenv shr paramsR params jobDone+  liftIO $ schedule workers job++{-# INLINABLE mkJob #-}+mkJob :: Int+      -> Int+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> sh+      -> sh+      -> ParamsR Native params+      -> params+      -> Maybe Action+      -> Par Native Job+mkJob splits minsize fun gamma aenv shr from to paramsR params jobDone =+  mkJobUsing (divideWork shr splits minsize from to (,,)) fun gamma aenv shr paramsR params jobDone++{-# INLINABLE mkJobUsing #-}+mkJobUsing+      :: Seq (Int, sh, sh)+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> ParamsR Native params+      -> params+      -> Maybe Action+      -> Par Native Job+mkJobUsing ranges fun@(name,_) gamma aenv shr paramsR params jobDone = do+  jobTasks <- mkTasksUsing ranges fun gamma aenv shr paramsR params+  liftIO    $ timed name Job {..}++{-# INLINABLE mkJobUsingIndex #-}+mkJobUsingIndex+      :: Seq (Int, sh, sh)+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> ParamsR Native params+      -> params+      -> Maybe Action+      -> Par Native Job+mkJobUsingIndex ranges fun@(name,_) gamma aenv shr paramsR params jobDone = do+  jobTasks <- mkTasksUsingIndex ranges fun gamma aenv shr paramsR params+  liftIO    $ timed name Job {..}++{-# INLINABLE mkTasksUsing #-}+mkTasksUsing+      :: Seq (Int, sh, sh)+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> ParamsR Native params+      -> params+      -> Par Native (Seq Action)+mkTasksUsing ranges (name, f) gamma aenv shr paramsR params = do+  arg <- marshalParams' @Native (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv)+  return $ flip fmap ranges $ \(_,u,v) -> do+    sched $ printf "%s (%s) -> (%s)" (S8.unpack name) (showShape shr u) (showShape shr v)+    let argU = marshalShape' @Native shr u+    let argV = marshalShape' @Native shr v+    callFFI f retVoid $ DL.toList $ argU `DL.append` argV `DL.append` arg++{-# INLINABLE mkTasksUsingIndex #-}+mkTasksUsingIndex+      :: Seq (Int, sh, sh)+      -> Function+      -> Gamma aenv+      -> Val aenv+      -> ShapeR sh+      -> ParamsR Native params+      -> params+      -> Par Native (Seq Action)+mkTasksUsingIndex ranges (name, f) gamma aenv shr paramsR params = do+  arg <- marshalParams' @Native (paramsR `TupRpair` TupRsingle (ParamRenv gamma)) (params, aenv)+  return $ flip fmap ranges $ \(i,u,v) -> do+    sched $ printf "%s (%s) -> (%s)" (S8.unpack name) (showShape shr u) (showShape shr v)+    let argU = marshalShape' @Native shr u+    let argV = marshalShape' @Native shr v+    let argI = DL.singleton $ marshalInt @Native i+    callFFI f retVoid $ DL.toList $ argU `DL.append` argV `DL.append` argI `DL.append` arg+++-- Standard C functions+-- --------------------++memset :: Ptr Word8 -> Word8 -> Int -> IO ()+memset p w s = c_memset p (fromIntegral w) (fromIntegral s) >> return ()++foreign import ccall unsafe "string.h memset" c_memset+    :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)+++-- Debugging+-- ---------++-- Since the (new) thread scheduler does not operate in block-synchronous mode,+-- it is a bit more difficult to track how long an individual operation took to+-- execute as we won't know when exactly it will begin. The following method+-- (where initial timing information is recorded as the first task) should give+-- reasonable results.+--+-- TLM: missing GC stats information (verbose mode) since we aren't using the+--      the default 'timed' helper.+--+timed :: ShortByteString -> Job -> IO Job+timed name job =+  case Debug.debuggingIsEnabled of+    False -> return job+    True  -> do+      yes <- if Debug.monitoringIsEnabled+               then return True+               else Debug.getFlag Debug.dump_exec+      --+      if yes+        then do+          ref1 <- newIORef 0+          ref2 <- newIORef 0+          let start = do !wall0 <- getMonotonicTime+                         !cpu0  <- getCPUTime+                         writeIORef ref1 wall0+                         writeIORef ref2 cpu0++              end   = do !cpu1  <- getCPUTime+                         !wall1 <- getMonotonicTime+                         !wall0 <- readIORef ref1+                         !cpu0  <- readIORef ref2+                         --+                         let wallTime = wall1 - wall0+                             cpuTime  = fromIntegral (cpu1 - cpu0) * 1E-12+                         --+                         Debug.addProcessorTime Debug.Native cpuTime+                         Debug.traceIO Debug.dump_exec $ printf "exec: %s %s" (S8.unpack name) (Debug.elapsedP wallTime cpuTime)+              --+          return $ Job { jobTasks = start Seq.<| jobTasks job+                       , jobDone  = case jobDone job of+                                      Nothing       -> Just end+                                      Just finished -> Just (finished >> end)+                       }+        else+          return job++-- accelerate/cbits/clock.c+foreign import ccall unsafe "clock_gettime_monotonic_seconds" getMonotonicTime :: IO Double+++sched :: String -> IO ()+sched msg+  = Debug.when Debug.verbose+  $ Debug.when Debug.dump_sched+  $ do tid <- myThreadId+       Debug.putTraceMsg $ printf "sched: %s %s" (show tid) msg 

@@ -1,52 +1,164 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Async--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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.LLVM.Native.Execute.Async ( -  Async, Stream, Event,-  module Data.Array.Accelerate.LLVM.Execute.Async,+  Async(..), Future(..), IVar(..), getArrays,+  evalPar, putIO,  ) where  -- accelerate-import Data.Array.Accelerate.LLVM.Execute.Async                     hiding ( Async )-import qualified Data.Array.Accelerate.LLVM.Execute.Async           as A-+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.LLVM.Execute.Async+import Data.Array.Accelerate.LLVM.Native.Execute.Scheduler import Data.Array.Accelerate.LLVM.Native.Target+import Data.Array.Accelerate.LLVM.State +-- standard library+import Control.Concurrent+import Control.Monad.Cont+import Control.Monad.State+import Data.IORef+import Data.Sequence                                                ( Seq )+import qualified Data.Sequence                                      as Seq -type Async a = A.AsyncR  Native a-type Stream  = A.StreamR Native-type Event   = A.EventR  Native --- The native backend does everything synchronously.+-- | Evaluate a parallel computation ---instance A.Async Native where-  type StreamR Native = ()-  type EventR  Native = ()+-- The worker threads execute the computation, while the calling thread+-- effectively sleeps waiting for the result.+--+{-# INLINEABLE evalPar #-}+evalPar :: Par Native a -> LLVM Native a+evalPar work = do+  result <- liftIO newEmptyMVar+  runContT (runPar work) (liftIO . putMVar result)+  liftIO $ takeMVar result -  {-# INLINE fork #-}-  fork = return ()+  -- XXX: Running the initial computation on the worker threads can lead to the+  -- workers becoming blocked, possibly waiting for the result MVars to be+  -- filled from previous (lazily evaluated) computations (speculation). This+  -- happened for example with the code from Issue255, when extracting the+  -- result at index > number of worker threads.+  --+  -- liftIO  $ do+  --   schedule (workers native)+  --     Job { jobTasks = Seq.singleton $ evalLLVM native (runContT (runPar work) (liftIO . putMVar result))+  --         , jobDone  = Nothing+  --         }+  --   takeMVar result -  {-# INLINE join #-}-  join () = return () -  {-# INLINE checkpoint #-}-  checkpoint () = return ()+-- Implementation+-- -------------- -  {-# INLINE after #-}-  after () () = return ()+data Future a = Future {-# UNPACK #-} !(IORef (IVar a)) -  {-# INLINE block #-}-  block () = return ()+data IVar a+    = Full    !a+    | Blocked !(Seq (a -> IO ()))+    | Empty++instance Async Native where+  type FutureR Native  = Future+  newtype Par Native a = Par { runPar :: ContT () (LLVM Native) a }+    deriving ( Functor, Applicative, Monad, MonadIO, MonadCont, MonadState Native )++  {-# INLINE new     #-}+  {-# INLINE newFull #-}+  new       = Future <$> liftIO (newIORef Empty)+  newFull v = Future <$> liftIO (newIORef (Full v))++  {-# INLINE fork  #-}+  {-# INLINE spawn #-}+  fork  = id+  spawn = id++  {-# INLINE get #-}+  get (Future ref) =+    callCC $ \k -> do+      native <- gets llvmTarget+      next   <- liftIO . atomicModifyIORef' ref $ \case+                  Empty      -> (Blocked (Seq.singleton (evalParIO native . k)), reschedule)+                  Blocked ks -> (Blocked (ks Seq.|>      evalParIO native . k),  reschedule)+                  Full a     -> (Full a,                                         return a)+      next++  {-# INLINE put #-}+  put future ref = do+    Native{..} <- gets llvmTarget+    liftIO (putIO workers future ref)++  {-# INLINE liftPar #-}+  liftPar = Par . lift++-- | Evaluate a continuation+--+{-# INLINE evalParIO #-}+evalParIO :: Native -> Par Native () -> IO ()+evalParIO native@Native{} work =+  evalLLVM native (runContT (runPar work) return)++-- | The value represented by a future is now available. Push any blocked+-- continuations to the worker threads.+--+{-# INLINEABLE putIO #-}+putIO :: HasCallStack => Workers -> Future a -> a -> IO ()+putIO workers (Future ref) v = do+  ks <- atomicModifyIORef' ref $ \case+          Empty      -> (Full v, Seq.empty)+          Blocked ks -> (Full v, ks)+          _          -> internalError "multiple put"+  --+  schedule workers Job { jobTasks = fmap ($ v) ks+                       , jobDone  = Nothing+                       }++-- | The worker threads should search for other work to execute+--+{-# INLINE reschedule #-}+reschedule :: Par Native a+reschedule = Par $ ContT (\_ -> return ())+++-- reschedule :: Par Native a+-- reschedule = Par $ ContT (const loop)+--   where+--     loop :: ReaderT Schedule (LLVM Native) ()+--     loop = do+--       queue <- ask+--       mwork <- liftIO $ tryPopR queue+--       case mwork of+--         Just work -> runContT (runPar work) (const loop)+--         Nothing   -> liftIO yield >> loop++-- pushL :: MVar (Seq a) -> a -> IO ()+-- pushL ref a =+--   mask_ $ do+--     ma <- tryTakeMVar ref+--     case ma of+--       Nothing -> putMVar ref (Seq.singleton a)+--       Just as -> putMVar ref (a Seq.<| as)++-- popR :: MVar (Seq a) -> IO a+-- popR ref = do+--   q <- takeMVar ref+--   case Seq.viewr q of+--     Seq.EmptyR  -> popR ref   -- should be impossible+--     as Seq.:> a -> putMVar ref as >> return a 

@@ -0,0 +1,178 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+-- |+-- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Divide+-- Copyright   : [2018..2020] The Accelerate Team+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.LLVM.Native.Execute.Divide (++  divideWork, divideWork1++) where++import Data.Array.Accelerate.Representation.Shape++import Data.Bits+import Data.Sequence                                                ( Seq )+import qualified Data.Sequence                                      as Seq+import qualified Data.Vector.Unboxed                                as U+import qualified Data.Vector.Unboxed.Mutable                        as M+++-- Divide the given multidimensional index range into a sequence of work pieces.+-- Splits will be made on the outermost (left-most) index preferentially, so+-- that spans are longest on the innermost dimension (because caches).+--+-- No dimension will be made smaller than the given minimum.+--+-- The number of subdivisions a hint (at most, it should generate a number of+-- pieces rounded up to the next power-of-two).+--+-- Full pieces will occur first in the resulting sequence, with smaller pieces+-- at the end (suitable for work-stealing). Note that the pieces are not sorted+-- according by size, and are ordered in the resulting sequence depending only+-- on whether all dimensions are above the minimum threshold or not. The integer+-- parameter to the apply action can be used to access the chunks linearly (for+-- example, this is useful when evaluating non-commutative operations).+--+-- {-# INLINABLE divideWork #-}+divideWork+    :: ShapeR sh+    -> Int                        -- #subdivisions (hint)+    -> Int                        -- minimum size of a dimension (must be a power of two)+    -> sh                         -- start index (e.g. top-left)+    -> sh                         -- end index   (e.g. bottom-right)+    -> (Int -> sh -> sh -> a)     -- action given start/end index range, and split number in the range [0..]+    -> Seq a+divideWork ShapeRz              = divideWork0+divideWork (ShapeRsnoc ShapeRz) = divideWork1+divideWork shr                  = divideWorkN shr+  --+  -- It is slightly faster to use lists instead of a Sequence here (though the+  -- difference is <1us on 'divideWork empty (Z:.2000) nop 8 32'). However,+  -- later operations will benefit from more efficient append, etc.++divideWork0 :: Int -> Int -> DIM0 -> DIM0 -> (Int -> DIM0 -> DIM0 -> a) -> Seq a+divideWork0 _ _ () () action = Seq.singleton (action 0 () ())++divideWork1 :: Int -> Int -> DIM1 -> DIM1 -> (Int -> DIM1 -> DIM1 -> a) -> Seq a+divideWork1 !pieces !minsize ((), (!from)) ((), (!to)) action =+  let+      split 0 !u !v !i !f !s+        | v - u < minsize = (i+1, f, s Seq.|> apply i u v)+        | otherwise       = (i+1, f Seq.|> apply i u v, s)+      --+      split !s !u !v !i0 !f0 !s0 =+        case findSplitPoint1 u v minsize of+          Nothing       -> (i0+1, f0, s0 Seq.|> apply i0 u v)+          Just (u', v') ->+            let s'         = unsafeShiftR s 1+                (i1,f1,s1) = split s' u  v' i0 f0 s0+                (i2,f2,s2) = split s' u' v  i1 f1 s1+            in+            (i2, f2, s2)++      apply i u v = action i ((), u) ((), v)+      (_, fs, ss) = split pieces from to 0 Seq.empty Seq.empty+  in+  fs Seq.>< ss++{-# INLINE findSplitPoint1 #-}+findSplitPoint1+    :: Int+    -> Int+    -> Int+    -> Maybe (Int, Int)+findSplitPoint1 !u !v !minsize =+  let a = v - u in+  if a <= minsize+    then Nothing+    else+      let b = unsafeShiftR (a+1) 1+          c = minsize - 1+          d = (b+c) .&. complement c+      in+      Just (d+u, v-a+d)+++divideWorkN :: ShapeR sh -> Int -> Int -> sh -> sh -> (Int -> sh -> sh -> a) -> Seq a+divideWorkN !shr !pieces !minsize !from !to action =+  let+      -- Is it worth checking whether the piece is full? Doing so ensures that+      -- full pieces are assigned to threads first, with the non-full blocks+      -- being the ones at the end of the work queue to be stolen.+      --+      split 0 !u !v !i !f !s+        | U.any (< minsize) (U.zipWith (-) v u) = (i+1, f, s Seq.|> apply i u v)+        | otherwise                             = (i+1, f Seq.|> apply i u v, s)+      --+      split !s !u !v !i0 !f0 !s0 =+        case findSplitPointN u v minsize of+          Nothing       -> (i0+1, f0, s0 Seq.|> apply i0 u v)+          Just (u', v') ->+            let s'      = unsafeShiftR s 1+                (i1,f1,s1) = split s' u  v' i0 f0 s0+                (i2,f2,s2) = split s' u' v  i1 f1 s1+            in+            (i2, f2, s2)++      apply i u v = action i (vecToShape shr u) (vecToShape shr v)+      (_, fs, ss) = split pieces (shapeToVec shr from) (shapeToVec shr to) 0 Seq.empty Seq.empty+  in+  fs Seq.>< ss+++-- Determine if and where to split the given index range. Returns new start and+-- end indices if found.+--+{-# INLINE findSplitPointN #-}+findSplitPointN+    :: U.Vector Int           -- start+    -> U.Vector Int           -- end+    -> Int                    -- minimum size of a dimension (must be power of 2)+    -> Maybe (U.Vector Int, U.Vector Int)+findSplitPointN !from !to !minsize =+  let+      mix = U.ifoldr' combine Nothing+          $ U.zipWith (-) to from++      combine i v old =+        if v <= minsize+          then old+          else case old of+                 Nothing    -> Just (i,v)+                 Just (_,u) -> if v < u+                                 then Just (i,v)+                                 else old+  in+  case mix of+    Nothing     -> Nothing+    Just (i,a)  ->+      let b     = unsafeShiftR (a+1) 1    -- divide by 2 (rounded up)+          c     = minsize - 1+          d     = (b+c) .&. complement c  -- round up to next multiple of chunk size+          e     = U.unsafeIndex from i+          f     = U.unsafeIndex to   i+          --+          from' = U.modify (\mv -> M.unsafeWrite mv i (d+e))   from+          to'   = U.modify (\mv -> M.unsafeWrite mv i (f-a+d)) to+      in+      Just (from', to')++{-# INLINE vecToShape #-}+vecToShape :: ShapeR sh -> U.Vector Int -> sh+vecToShape shr = listToShape shr . U.toList++{-# INLINE shapeToVec #-}+shapeToVec :: ShapeR sh -> sh -> U.Vector Int+shapeToVec shr sh = U.fromListN (rank shr) (shapeToList shr sh)+

@@ -2,24 +2,23 @@ {-# LANGUAGE GADTs #-} -- | -- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Environment--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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.LLVM.Native.Execute.Environment ( -  Aval, aprj+  module Data.Array.Accelerate.LLVM.Execute.Environment,+  module Data.Array.Accelerate.LLVM.Native.Execute.Environment,  ) where --- accelerate import Data.Array.Accelerate.LLVM.Native.Target import Data.Array.Accelerate.LLVM.Execute.Environment -type Aval = AvalR Native+type Val = ValR Native 

@@ -1,34 +0,0 @@--- |--- Module      : Data.Array.Accelerate.LLVM.Native.Execute.LBS--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)-----module Data.Array.Accelerate.LLVM.Native.Execute.LBS-  where---- Some default values for the profitable parallelism threshold (PPT). These are--- chosen as to reduce the frequency of deque checks. Since a deque check also--- requires returning from the foreign LLVM function back to the scheduler code,--- it is important to combine fine-grained iterations via the PPT.------ The large PPT is meant for operations such as @map@ and @generate@, where the--- input length equates the total number of elements to process. The small PPT--- is meant for operations such as multidimensional reduction, where each input--- index corresponds to a non-unit amount of work.------ These should really be dynamic values based on how long it took to execute--- the last chunk, increase or decrease the chunk size to ensure quick--- turnaround and also low scheduler overhead.----defaultLargePPT :: Int-defaultLargePPT = 4096--defaultSmallPPT :: Int-defaultSmallPPT = 64-

@@ -1,108 +1,39 @@-{-# LANGUAGE CPP                   #-}+{-# LANGUAGE BangPatterns          #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-#if __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE OverlappingInstances  #-}-{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}-#endif -- | -- Module      : Data.Array.Accelerate.LLVM.Native.Execute.Marshal--- Copyright   : [2014..2017] Trevor L. McDonell---               [2014..2014] Vinod Grover (NVIDIA Corporation)+-- Copyright   : [2014..2020] The Accelerate Team -- 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.LLVM.Native.Execute.Marshal (--  Marshalable, M.marshal--) where+module Data.Array.Accelerate.LLVM.Native.Execute.Marshal ( module M )+  where  -- accelerate-import Data.Array.Accelerate.LLVM.CodeGen.Environment           ( Gamma, Idx'(..) )-import qualified Data.Array.Accelerate.LLVM.Execute.Marshal     as M+import Data.Array.Accelerate.LLVM.Execute.Marshal               as M+import Data.Array.Accelerate.Array.Unique -import Data.Array.Accelerate.LLVM.Native.Array.Data-import Data.Array.Accelerate.LLVM.Native.Execute.Async-import Data.Array.Accelerate.LLVM.Native.Execute.Environment+import Data.Array.Accelerate.LLVM.Native.Execute.Async          () -- instance Async Native import Data.Array.Accelerate.LLVM.Native.Target  -- libraries-import Data.DList                                               ( DList ) import qualified Data.DList                                     as DL-import qualified Data.IntMap                                    as IM import qualified Foreign.LibFFI                                 as FFI ---- Instances for the Native backend----type Marshalable args       = M.Marshalable Native args-type instance M.ArgR Native = FFI.Arg----- Instances for handling concrete types in this backend, namely shapes and--- array data.----instance M.Marshalable Native Int where-  marshal' _ _ x = return $ DL.singleton (FFI.argInt x)--instance {-# OVERLAPS #-} M.Marshalable Native (Gamma aenv, Aval aenv) where-  marshal' t s (gamma, aenv)-    = fmap DL.concat-    $ mapM (\(_, Idx' idx) -> M.marshal' t s (sync (aprj idx aenv))) (IM.elems gamma)-    where-      sync (AsyncR () a) = a+instance Marshal Native where+  type ArgR Native = FFI.Arg -instance ArrayElt e => M.Marshalable Native (ArrayData e) where-  marshal' _ _ adata = return $ marshalR arrayElt adata-    where-      marshalR :: ArrayEltR e' -> ArrayData e' -> DList FFI.Arg-      marshalR ArrayEltRunit             _  = DL.empty-      marshalR (ArrayEltRpair aeR1 aeR2) ad =-        marshalR aeR1 (fstArrayData ad) `DL.append`-        marshalR aeR2 (sndArrayData ad)-      ---      marshalR (ArrayEltRvec2 ae)  (AD_V2 ad)  = marshalR ae ad-      marshalR (ArrayEltRvec3 ae)  (AD_V3 ad)  = marshalR ae ad-      marshalR (ArrayEltRvec4 ae)  (AD_V4 ad)  = marshalR ae ad-      marshalR (ArrayEltRvec8 ae)  (AD_V8 ad)  = marshalR ae ad-      marshalR (ArrayEltRvec16 ae) (AD_V16 ad) = marshalR ae ad-      ---      marshalR ArrayEltRint     ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRint8    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRint16   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRint32   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRint64   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRword    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRword8   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRword16  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRword32  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRword64  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRhalf    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRfloat   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRdouble  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRchar    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcshort  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcushort ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcint    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcuint   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRclong   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRculong  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcllong  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcullong ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcchar   ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcschar  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcuchar  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcfloat  ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRcdouble ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)-      marshalR ArrayEltRbool    ad = DL.singleton $ FFI.argPtr (ptrsOfArrayData ad)+  marshalInt = FFI.argInt+  marshalScalarData' _ = return . DL.singleton . FFI.argPtr . unsafeUniqueArrayPtr