accelerate-llvm 1.2.0.1 → 1.3.0.0
raw patch · 68 files changed
+4172/−5311 lines, 68 filesdep +constraintsdep −abstract-dequedep −chaselev-dequedep −mwc-randomdep ~acceleratedep ~basedep ~directoryPVP ok
version bump matches the API change (PVP)
Dependencies added: constraints
Dependencies removed: abstract-deque, chaselev-deque, mwc-random
Dependency ranges changed: accelerate, base, directory, llvm-hs, llvm-hs-pure, primitive
API changes (from Hackage documentation)
Files
- CHANGELOG.md +21/−20
- LICENSE +1/−1
- README.md +31/−22
- accelerate-llvm.cabal +18/−58
- src/Control/Parallel/Meta.hs +0/−253
- src/Control/Parallel/Meta/Resource/Backoff.hs +0/−91
- src/Control/Parallel/Meta/Resource/SMP.hs +0/−119
- src/Control/Parallel/Meta/Resource/Single.hs +0/−34
- src/Control/Parallel/Meta/Trans/LBS.hs +0/−131
- src/Control/Parallel/Meta/Worker.hs +0/−233
- src/Data/Array/Accelerate/LLVM/AST.hs +157/−104
- src/Data/Array/Accelerate/LLVM/Analysis/Match.hs +0/−41
- src/Data/Array/Accelerate/LLVM/Array/Data.hs +257/−324
- src/Data/Array/Accelerate/LLVM/CodeGen.hs +63/−70
- src/Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs +247/−192
- src/Data/Array/Accelerate/LLVM/CodeGen/Array.hs +212/−30
- src/Data/Array/Accelerate/LLVM/CodeGen/Base.hs +102/−62
- src/Data/Array/Accelerate/LLVM/CodeGen/Constant.hs +14/−13
- src/Data/Array/Accelerate/LLVM/CodeGen/Downcast.hs +0/−549
- src/Data/Array/Accelerate/LLVM/CodeGen/Environment.hs +17/−18
- src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs +275/−444
- src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs-boot +20/−0
- src/Data/Array/Accelerate/LLVM/CodeGen/IR.hs +117/−239
- src/Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs +6/−5
- src/Data/Array/Accelerate/LLVM/CodeGen/Loop.hs +66/−60
- src/Data/Array/Accelerate/LLVM/CodeGen/Module.hs +2/−2
- src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs +102/−103
- src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot +5/−4
- src/Data/Array/Accelerate/LLVM/CodeGen/Permute.hs +96/−86
- src/Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs +9/−10
- src/Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs +103/−211
- src/Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs +153/−139
- src/Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs +27/−38
- src/Data/Array/Accelerate/LLVM/CodeGen/Type.hs +22/−182
- src/Data/Array/Accelerate/LLVM/Compile.hs +221/−184
- src/Data/Array/Accelerate/LLVM/Compile/Cache.hs +14/−12
- src/Data/Array/Accelerate/LLVM/Embed.hs +76/−135
- src/Data/Array/Accelerate/LLVM/Execute.hs +448/−303
- src/Data/Array/Accelerate/LLVM/Execute/Async.hs +79/−53
- src/Data/Array/Accelerate/LLVM/Execute/Environment.hs +37/−21
- src/Data/Array/Accelerate/LLVM/Execute/Marshal.hs +82/−58
- src/Data/Array/Accelerate/LLVM/Extra.hs +45/−0
- src/Data/Array/Accelerate/LLVM/Foreign.hs +10/−15
- src/Data/Array/Accelerate/LLVM/Link.hs +44/−99
- src/Data/Array/Accelerate/LLVM/Link/Cache.hs +2/−2
- src/Data/Array/Accelerate/LLVM/State.hs +2/−4
- src/Data/Array/Accelerate/LLVM/Target.hs +5/−8
- src/Data/Array/Accelerate/LLVM/Util.hs +0/−51
- src/Data/ByteString/Short/Char8.hs +2/−2
- src/Data/ByteString/Short/Extra.hs +22/−5
- src/Data/Range.hs +0/−184
- src/LLVM/AST/Type/AddrSpace.hs +2/−2
- src/LLVM/AST/Type/Constant.hs +86/−3
- src/LLVM/AST/Type/Downcast.hs +86/−0
- src/LLVM/AST/Type/Flags.hs +2/−2
- src/LLVM/AST/Type/Function.hs +94/−0
- src/LLVM/AST/Type/Global.hs +27/−35
- src/LLVM/AST/Type/InlineAssembly.hs +44/−0
- src/LLVM/AST/Type/Instruction.hs +339/−34
- src/LLVM/AST/Type/Instruction/Atomic.hs +27/−2
- src/LLVM/AST/Type/Instruction/Compare.hs +2/−6
- src/LLVM/AST/Type/Instruction/RMW.hs +45/−2
- src/LLVM/AST/Type/Instruction/Volatile.hs +10/−2
- src/LLVM/AST/Type/Metadata.hs +30/−3
- src/LLVM/AST/Type/Name.hs +20/−11
- src/LLVM/AST/Type/Operand.hs +19/−3
- src/LLVM/AST/Type/Representation.hs +84/−179
- src/LLVM/AST/Type/Terminator.hs +23/−3
CHANGELOG.md view
@@ -6,53 +6,54 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) -## [1.2.0.1] - 2019-04-29+## [1.3.0.0] - 2018-08-27 ### Added- * support for GHC-8.6- * support for LLVM-7- * support for LLVM-8+ * Support for LLVM-9+ * Support for GHC-8.10 ### Contributors Special thanks to those who contributed patches as part of this release: - * Trevor L. McDonell (@tmcdonell)- * Viktor Kronvall (@considerate)+ * Trevor L. McDonell (@tmcdonell)+ * Ivo Gabe de Wolff (@ivogabe)+ * Lars van den Haak (@sakehl)+ * Joshua Meredith (@JoshMeredith) ## [1.2.0.0] - 2018-04-03 ### 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 ### Fixed- * Fix for 32-bit `IsNan` and `IsInfinite` ([#407])+ * Fix for 32-bit `IsNan` and `IsInfinite` ([#407]) ### Contributors Special thanks to those who contributed patches as part of this release: - * Trevor L. McDonell (@tmcdonell)- * Ryan Scott (@ryanglscott)- * Moritz Kiefer (@cocreature)+ * Trevor L. McDonell (@tmcdonell)+ * Ryan Scott (@ryanglscott)+ * Moritz Kiefer (@cocreature) ## [1.1.0.0] - 2017-09-21 ### Added- * support for GHC-8.2- * support for LLVM-5.0+ * support for GHC-8.2+ * support for LLVM-5.0 ### Changed- * internal restructuring of compile/link phases+ * internal restructuring of compile/link phases ## [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.0...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.0...1.2.0.0 [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
LICENSE view
@@ -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:
README.md view
@@ -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"/> -[](https://travis-ci.org/AccelerateHS/accelerate-llvm)-[](https://ci.appveyor.com/project/tmcdonell/accelerate-llvm)+# LLVM backends for the Accelerate array language++[](https://github.com/tmcdonell/accelerate-llvm/actions)+[](https://gitter.im/AccelerateHS/Lobby)+<br> [](https://stackage.org/lts/package/accelerate-llvm) [](https://stackage.org/nightly/package/accelerate-llvm) [](https://hackage.haskell.org/package/accelerate-llvm)+<br> [](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) [](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
accelerate-llvm.cabal view
@@ -1,7 +1,7 @@ name: accelerate-llvm-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 component generating LLVM IR@@ -27,7 +27,7 @@ . Example using Homebrew on macOS: .- > brew install llvm-hs/llvm/llvm-8+ > brew install llvm-hs/llvm/llvm-9 . /Debian & Ubuntu/ .@@ -36,7 +36,7 @@ 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/ .@@ -51,43 +51,19 @@ @LLVM_TARGETS_TO_BUILD@ option includes the @NVPTX@ target (if not specified, all targets are 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 README.md --- Configuration flags--- ---------------------Flag chase-lev- Default: True- Description: Use a Chase-Lev deque for work stealing-- -- Build configuration -- ------------------- @@ -95,14 +71,12 @@ exposed-modules: -- Accelerate-LLVM middle-end Data.Array.Accelerate.LLVM.AST- Data.Array.Accelerate.LLVM.Analysis.Match Data.Array.Accelerate.LLVM.Array.Data Data.Array.Accelerate.LLVM.CodeGen Data.Array.Accelerate.LLVM.CodeGen.Arithmetic Data.Array.Accelerate.LLVM.CodeGen.Array Data.Array.Accelerate.LLVM.CodeGen.Base Data.Array.Accelerate.LLVM.CodeGen.Constant- Data.Array.Accelerate.LLVM.CodeGen.Downcast Data.Array.Accelerate.LLVM.CodeGen.Environment Data.Array.Accelerate.LLVM.CodeGen.Exp Data.Array.Accelerate.LLVM.CodeGen.IR@@ -123,18 +97,21 @@ Data.Array.Accelerate.LLVM.Execute.Async Data.Array.Accelerate.LLVM.Execute.Environment Data.Array.Accelerate.LLVM.Execute.Marshal+ Data.Array.Accelerate.LLVM.Extra Data.Array.Accelerate.LLVM.Foreign Data.Array.Accelerate.LLVM.Link Data.Array.Accelerate.LLVM.Link.Cache Data.Array.Accelerate.LLVM.State Data.Array.Accelerate.LLVM.Target- Data.Array.Accelerate.LLVM.Util -- LLVM code generation LLVM.AST.Type.AddrSpace LLVM.AST.Type.Constant+ LLVM.AST.Type.Downcast LLVM.AST.Type.Flags+ LLVM.AST.Type.Function LLVM.AST.Type.Global+ LLVM.AST.Type.InlineAssembly LLVM.AST.Type.Instruction LLVM.AST.Type.Instruction.Atomic LLVM.AST.Type.Instruction.Compare@@ -146,39 +123,29 @@ LLVM.AST.Type.Representation LLVM.AST.Type.Terminator - -- Scheduler- Control.Parallel.Meta- Control.Parallel.Meta.Worker- Control.Parallel.Meta.Resource.Backoff- Control.Parallel.Meta.Resource.Single- Control.Parallel.Meta.Resource.SMP- Control.Parallel.Meta.Trans.LBS- -- Extras Data.ByteString.Short.Char8 Data.ByteString.Short.Extra- Data.Range other-modules: Paths_accelerate_llvm build-depends:- base >= 4.7 && < 4.13- , abstract-deque >= 0.3- , accelerate == 1.2.*+ base >= 4.10 && < 5+ , accelerate == 1.3.* , bytestring >= 0.10.4+ , constraints >= 0.9 , containers >= 0.5 , data-default-class >= 0.0.1 , deepseq >= 1.3- , directory >= 1.0+ , directory >= 1.2.3 , dlist >= 0.6 , exceptions >= 0.6 , filepath >= 1.0- , 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 , mtl >= 2.0- , mwc-random >= 0.13- , primitive >= 0.6+ , primitive >= 0.6.4 , template-haskell , unordered-containers >= 0.2 , vector >= 0.10@@ -202,20 +169,13 @@ ghc-options: -Wmissed-specialisations - if flag(chase-lev)- cpp-options:- -DCHASELEV_DEQUE-- build-depends:- chaselev-deque >= 0.5- source-repository head type: git location: https://github.com/AccelerateHS/accelerate-llvm.git 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
− src/Control/Parallel/Meta.hs
@@ -1,253 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Control.Parallel.Meta--- 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 Control.Parallel.Meta (-- WorkSearch(..),- Resource(..),- Executable(..),- Action,- runSeqIO, runParIO,--) where--import Control.Monad-import Control.Parallel.Meta.Worker-import Data.ByteString.Short ( ShortByteString )-import Data.Concurrent.Deque.Class-import Data.Monoid ( Monoid(..) )-#if __GLASGOW_HASKELL__ >= 800-import Data.Semigroup ( Semigroup(..) )-#endif-import Data.Range as R-import Prelude as P-import qualified Data.Vector as V--import GHC.Base ( quotInt, remInt )----- | The 'WorkSearch' component of a 'Resource' is a callback that responds to--- requests for work from meta-workers. The arguments to 'WorkSearch' are the--- scheduler state for the current thread and a reference to all workers in the--- program.----data WorkSearch = WorkSearch {- runWorkSearch :: Int -> Workers -> IO (Maybe Range)- }--#if __GLASGOW_HASKELL__ >= 800-instance Semigroup WorkSearch where- {-# INLINE (<>) #-}- WorkSearch ws1 <> WorkSearch ws2 =- WorkSearch $ \tid st -> do- mwork <- ws1 tid st- case mwork of- Nothing -> ws2 tid st- _ -> return mwork-#endif--instance Monoid WorkSearch where- {-# INLINE mempty #-}- {-# INLINE mappend #-}- mempty = WorkSearch $ \_ _ -> return Nothing- WorkSearch ws1 `mappend` WorkSearch ws2 =- WorkSearch $ \tid st -> do- mwork <- ws1 tid st- case mwork of- Nothing -> ws2 tid st- _ -> return mwork----- | A 'Resource' provides an abstraction of heterogeneous execution resources--- that may be combined. Composition of resources is left-biased. That is, if if--- @resource1@ always returns work from its 'WorkSearch', then the composed--- resource @resource1 <> resource2@ will never request work from @resource2@.----data Resource = Resource {- -- startup :: Startup- workSearch :: WorkSearch- }--#if __GLASGOW_HASKELL__ >= 800-instance Semigroup Resource where- {-# INLINE (<>) #-}- Resource ws1 <> Resource ws2 = Resource (ws1 <> ws2)-#endif--instance Monoid Resource where- {-# INLINE mempty #-}- {-# INLINE mappend #-}- mempty = Resource mempty- mappend (Resource ws1) (Resource ws2) = Resource (ws1 `mappend` ws2)----- | An action to execute. The first parameters are the start and end indices of--- the range this action should process, and the final is the ID of the thread--- doing the work.----type Action = Int -> Int -> Int -> IO ()--- data Action = Action {--- runAction :: Int -> Int -> Int -> IO }--- }---- instance Monoid Action where--- mempty = Action $ \_ _ _ -> return ()--- Action f1 `mappend` Action f2 = Action $ \m n i -> f1 m n i >> f1 m n i----- | An 'Executable' provides a callback that can be used to run a provided--- function using an encapsulated work-stealing gang of threads.----data Executable = Executable {- runExecutable- :: ShortByteString -- Function name- -> Int -- Profitable parallelism threshold (PPT)- -> Range -- The range to execute over- -> Action -- The main function to execute- -> IO ()- }----- | Run a sequential operation------ We just have the first thread of the gang execute the operation, but we could--- also make the threads compete, which might be useful on a loaded system.----{-# INLINEABLE runSeqIO #-}-runSeqIO- :: Gang- -> Range- -> Action- -> IO ()-runSeqIO _ Empty _ = return ()-runSeqIO gang (IE u v) action =- gangIO gang $ \workers ->- workerIO workers $ \thread ->- when (thread == 0) $ action u v thread- -- let- -- target = V.unsafeIndex workers 0- -- loop 0 = return ()- -- loop n = do- -- mwork <- tryPopR (workpool target)- -- case mwork of- -- Nothing -> loop (n-1)- -- Just Empty -> return ()- -- Just (IE u v) -> action u v thread- -- --- -- when (thread == 0) $ pushL (workpool target) range- -- loop 3----- | Run a parallel work-stealing operation.------ Each thread initialises its work queue with an equally sized chunk of the--- work. Threads keep working until their work search returns Nothing, at which--- point the thread exits. In our LBS implementation, a worker thread takes a--- small chunk of its work range to process, and places the remainder back onto--- its deque. Thus the work queues are only empty:------ (a) Briefly during the scheduling process; or------ (b) After the deque has been robbed. If the stolen chunk is large enough,--- the stealee will split the remainder onto its deque to be stolen; or------ (c) There is no more work.------ As long as the thread makes a small number of retries, this should correctly--- balance the work without too much scheduler overhead.------ An alternative to every thread initialising with an even chunk size is to put--- the entire range onto the first worker and then have the scheduler handle the--- decomposition. However, this method should be better for locality,--- particularly when the workloads are balanced and little stealing occurs.------ TLM: Should threads check whether the work queues of all threads are empty--- before deciding to exit? If the PPT is too large then threads might not--- react quickly enough to splitting once their deque is emptied. Maybe the--- first thread to return Nothing can probe the queues to see if they are--- all empty. If True, write into a shared MVar to signal to the others--- that it is time to exit. But, that still assumes that the PPT is not so--- large that the queues are always empty.------ TLM: The initial work distribution should probably be aligned to cache--- boundaries, rather than attempting to split exactly evenly.----{-# INLINEABLE runParIO #-}-runParIO- :: Resource- -> Gang- -> Range- -> Action- -> IO ()-runParIO _ _ Empty _ = return ()-runParIO resource gang (IE inf sup) action =- gangIO gang $ \workers ->- workerIO workers $ \tid -> do- let- len = sup - inf- threads = V.length workers- chunk = len `quotInt` threads- leftover = len `remInt` threads-- start = splitIx tid- end = splitIx (tid + 1)- me = V.unsafeIndex workers tid-- splitIx n | n < leftover = inf + n * (chunk + 1)- splitIx n = inf + n * chunk + leftover-- loop = do- work <- runWorkSearch (workSearch resource) tid workers- case work of- -- Got a work unit. Execute it then search for more.- Just (IE u v) -> action u v tid >> loop-- -- If the work search failed (which is random), to be extra safe- -- make sure all the work queues are exhausted before exiting.- _ -> do- done <- exhausted workers- unless done loop-- when (end > start) $ pushL (workpool me) (IE start end)- loop------ Icebox--- --------{----- | The 'Startup' component of a 'Resource' is a callback that implements--- initialisation behaviour. For example, it might contact remote hosts, spawn--- threads, or initialise hardware such as GPUs.----data Startup = Startup {- _runStartup :: Gang -> IO () }--instance Monoid Startup where- mempty = Startup $ \_ -> return ()- Startup st1 `mappend` Startup st2 = Startup $ \g -> st1 g >> st2 g---- | The 'Finalise' component of an executable is an action the thread applies--- after processing the work function, given its thread id the ranges that this--- thread actually handled.----data Finalise = Finalise {- _runFinalise :: Seq Range -> IO ()- }--instance Monoid Finalise where- mempty = Finalise $ \_ -> return ()- Finalise f1 `mappend` Finalise f2 = Finalise $ \r -> f1 r >> f2 r---}-
− src/Control/Parallel/Meta/Resource/Backoff.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Control.Parallel.Meta.Resource.Backoff--- 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)------ This module implements exponential backoff so as to prevent spamming of--- stealing actions. Most scheduler compositions should include this at the--- bottom of the stack.------ Inspired by the meta-par package. This package has a BSD license.--- <http://hackage.haskell.org/package/meta-par>-----module Control.Parallel.Meta.Resource.Backoff (-- mkResource,- defaultWorkSearch, mkWorkSearch,--) where--import Control.Concurrent-import Text.Printf--import Control.Parallel.Meta-import Control.Parallel.Meta.Worker-import Data.Primitive.MutVar-import Data.Range as R-import qualified Data.Vector as V-import qualified Data.Array.Accelerate.Debug as Debug---{-# INLINE mkResource #-}-mkResource :: Resource-mkResource = Resource defaultWorkSearch--{-# INLINE defaultWorkSearch #-}-defaultWorkSearch :: WorkSearch-defaultWorkSearch = mkWorkSearch 100 10000----- | To construct the work search, we need to know the minimum and maximum--- amount of time, in nanoseconds, to sleep. The exponential backoff policy is--- always the same: it starts at 1µs and doubles at every failure.------ The thing that changes over time is whether sleeping actually occurs. For--- example, the 'defaultWorkSearch':------ > mkWorkSearch 100 10000------ will not sleep for the first 7 invocations (until 128), and then will sleep--- an amount that doubles each time until it surpasses the maximum, at which--- point it will always sleep for the maximum time (10ms)----{-# INLINE mkWorkSearch #-}-mkWorkSearch :: Int -> Int -> WorkSearch-mkWorkSearch _ 0 = WorkSearch $ \_ _ -> return Nothing-mkWorkSearch shortest longest = WorkSearch backoff- where- backoff :: Int -> Workers -> IO (Maybe Range)- backoff tid workers = do- let Worker{..} = V.unsafeIndex workers tid- failed <- readMutVar consecutiveFailures- let sleep = min longest (2 ^ failed)- if sleep >= shortest- then do- message workerId (printf "sleeping for %d µs" sleep)- threadDelay sleep-- else do- message workerId "not sleeping"- return ()-- return Nothing----- Debugging--- -----------{-# INLINE message #-}-message :: Int -> String -> IO ()-message tid msg- = Debug.when Debug.verbose- $ Debug.traceIO Debug.dump_sched (printf "sched/backoff: [%d] %s" tid msg)-
− src/Control/Parallel/Meta/Resource/SMP.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Control.Parallel.Meta.Resource.SMP--- 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)------ This module implements a resource for SMP parallelism. It is suitable as a--- base for combining a bunch of resources that can steal cheaply from each--- other.------ Inspired by the meta-par package. This package has a BSD license.--- <http://hackage.haskell.org/package/meta-par>-----module Control.Parallel.Meta.Resource.SMP (-- mkResource,- mkWorkSearch,--) where---- accelerate-import Control.Parallel.Meta-import Control.Parallel.Meta.Worker-import Data.Primitive.MutVar-import Data.Range-import qualified Data.Array.Accelerate.Debug as Debug---- standard library-import Data.Concurrent.Deque.Class-import System.Random.MWC-import Text.Printf-import qualified Data.Vector as V----- | Create an SMP (symmetric multiprocessor) resource where all underlying--- workers have uniform access to shared resources such as memory. Thus workers--- at this level can steal cheaply from each other.----{-# INLINE mkResource #-}-mkResource- :: Int -- ^ number of steal attempts per 'WorkSearch'- -> Resource-mkResource retries =- Resource (mkWorkSearch retries)----- | Given a set of workers and a number of steal attempts per worker, return a--- work search function. Steals from workers in this gang are considered cheap--- and uniform.------ Note: [Number of retries in SMP resource]------ A large number of retries in the work search will prevent the search function--- from traversing the resource stack. This can result in spamming of stealing--- actions. In particular, the exponential backoff resource usually placed at--- the bottom of the stack may never be reached. Thus a balance is required--- between number of times to traverse each level and number of times to--- traverse the entire resource stack.----{-# INLINE mkWorkSearch #-}-mkWorkSearch :: Int -> WorkSearch-mkWorkSearch retries = WorkSearch search- where- search :: Int -> Workers -> IO (Maybe Range)- search !tid !workers =- let- me = V.unsafeIndex workers tid- myId = workerId me- random = uniformR (0, V.length workers - 1) (rngState me)-- loop 0 = do- message myId "work search failed"- modifyMutVar' (consecutiveFailures me) (+1)- return Nothing-- loop n = do- target <- V.unsafeIndex workers `fmap` random- if workerId target == myId- then loop (n-1)- else do- mwork <- tryPopR (workpool target)- case mwork of- Nothing -> loop (n-1)- _ -> do event myId (printf "steal from %d" (workerId target))- writeMutVar (consecutiveFailures me) 0- return mwork- in- loop retries--- self <- tryPopL (workpool me)--- case self of--- Nothing -> loop retries--- _ -> do message myId "steal from self"--- writeMutVar (consecutiveFailures me) 0--- return self----- Debugging--- -----------{-# INLINE message #-}-message :: Int -> String -> IO ()-message tid msg- = Debug.when Debug.verbose- $ Debug.traceIO Debug.dump_sched (printf "sched/smp: [%d] %s" tid msg)--{-# INLINE event #-}-event :: Int -> String -> IO ()-event tid msg = do- let msg' = printf "sched/smp: [%d] %s" tid msg- Debug.traceIO Debug.dump_sched msg'- Debug.traceEventIO Debug.dump_sched msg'-
− src/Control/Parallel/Meta/Resource/Single.hs
@@ -1,34 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Control.Parallel.Meta.Resource.Single--- 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 Control.Parallel.Meta.Resource.Single- where---- accelerate-import Control.Parallel.Meta-import Control.Parallel.Meta.Worker---- library-import Data.Concurrent.Deque.Class-import qualified Data.Vector as V----- | Create a resource where each thread works in isolation. The resource is not--- aware of any other sources of work (at this level) and only ever tries to pop--- from its own local queue.----{-# INLINE mkResource #-}-mkResource :: Resource-mkResource- = Resource- $ WorkSearch $ \tid workers -> tryPopL (workpool (V.unsafeIndex workers tid))-
− src/Control/Parallel/Meta/Trans/LBS.hs
@@ -1,131 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Control.Parallel.Meta.Resource.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)------ This module implements a lazy binary splitting resource transformer. It is--- suitable to add an adaptive runtime work-stealing component to resource.-----module Control.Parallel.Meta.Trans.LBS (-- mkResource,- mkWorkSearch,--) where--import Control.Parallel.Meta-import Control.Parallel.Meta.Worker-import Data.Concurrent.Deque.Class-import Data.Range ( Range )-import qualified Data.Range as R-import qualified Data.Array.Accelerate.Debug as Debug--import Control.Monad-import Text.Printf-import qualified Data.Vector as V----- | Transform the 'WorkSearch' function of the given 'Resource' to include a--- lazy binary splitting work stealing scheduler.----{-# INLINE mkResource #-}-mkResource- :: Int -- ^ profitable parallelism threshold- -> Resource -- ^ the resource to modify- -> Resource-mkResource ppt (Resource ws)- = Resource (mkWorkSearch ppt ws)----- | This transforms the 'WorkSearch' function to add a lazy binary splitting--- operation on top of an existing (work-stealing) scheduler. On receiving a--- unit of work, the scheduler proceeds as follows:------ 1. If the number of iterations is less than the profitable parallelism--- threshold (ppt), execute the remaining iterations and exit, else (2).------ 2. Check this worker's remaining work queue. If it is not empty, then--- execute ppt iterations, then go to (1) with the remainder.------ 3. If the remaining work queue is empty, split this work chunk in half.--- Place the second half onto the remaining work queue and go to (1).----{-# INLINE mkWorkSearch #-}-mkWorkSearch- :: Int -- ^ profitable parallelism threshold- -> WorkSearch -- ^ the basic work search method to modify- -> WorkSearch-mkWorkSearch ppt steal = WorkSearch search- where- search :: Int -> Workers -> IO (Maybe Range)- search tid workers = do- let Worker{..} = V.unsafeIndex workers tid-- -- Look for some work to do. If there is work on the local queue, take- -- that first before trying to steal from the neighbours.- --- self <- tryPopL workpool- work <- case self of- Nothing -> runWorkSearch steal tid workers- Just _ -> return self-- -- Once we have some work, take the first ppt elements (which we will- -- return so that they are processed next) and decide what do do with- -- the remainder:- --- -- 1. If the deque is not empty OR the remainder is less than the PPT,- -- push it back without splitting.- --- -- 2. If our deque is empty, split it in half and push both pieces- -- back onto the deque.- --- -- This strategy avoids excessive splitting, especially in the case- -- where this worker steals back the remainder from itself.- --- case work of- Just r | not (R.null r) -> do- let (this, rest) = R.splitAt ppt r- handleRemainder- | R.null rest = return ()-- | R.size rest < ppt = do- message workerId (printf "not splitting remainder (size %d < ppt %d)" (R.size rest) ppt)- pushL workpool rest-- | otherwise = do- empty <- nullQ workpool- if not empty- then do- message workerId (printf "not splitting remainder %s (deque not empty)" (show rest))- pushL workpool rest-- else do- let (l,u) = R.bisect rest- message workerId (printf "splitting remainder %s -> %s, %s" (show rest) (show l) (show u))- unless (R.null u) $ pushL workpool u- pushL workpool l- --- message workerId (printf "got work range %s" (show this))- handleRemainder- return (Just this)-- _ -> message workerId "work search failed" >> return Nothing----- Debugging--- -----------{-# INLINE message #-}-message :: Int -> String -> IO ()-message tid msg- = Debug.when Debug.verbose- $ Debug.traceIO Debug.dump_sched (printf "sched/lbs: [%d] %s" tid msg)-
− src/Control/Parallel/Meta/Worker.hs
@@ -1,233 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Control.Parallel.Meta.Worker--- 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 Control.Parallel.Meta.Worker (-- Gang, Workers, Worker(..), Req(..),- gangIO, forkGang, forkGangOn, workerIO, exhausted,--) where---- accelerate-import Data.Range-import qualified Data.Array.Accelerate.Debug as Debug---- standard library-import Control.Applicative-import Control.Concurrent-import Control.Exception-import Control.Monad-import Control.Monad.Primitive-import Data.Primitive.MutVar-import Data.Vector ( Vector )-import System.IO.Unsafe-import System.Random.MWC ( GenIO, createSystemRandom )-import Text.Printf-import Prelude-import qualified Data.Vector as V--import Data.Concurrent.Deque.Class-#ifdef CHASELEV_DEQUE-import Data.Concurrent.Deque.ChaseLev.DequeInstance ()-#else-import Data.Concurrent.Deque.Reference.DequeInstance ()-#endif----- | The 'Gang' structure tracks the state of all workers in the program. It--- starts empty, and workers append to it as they are brought online. Although--- the vector append operation is expensive, it is expected it is only called--- occasionally; e.g. at program initialisation. So, we prioritise for constant--- lookup of the worker structure, which will be done frequently during the work--- search.----type Gang = MVar Workers-type Workers = Vector Worker----- | The 'Worker' is the per-worker-thread state.------ If the worker has work that can be stolen by other processors, it is stored--- in the 'workpool'. Thieves treat the workpool as a stack which can be popped--- on the right, where as the owner can both push and pop on the left.------ In the lazy binary splitting work stealing setup, a worker processes its--- range in chunks, checking the state of its workpool periodically. Whenever--- the queue is empty, it splits it's current workload in two so that the second--- half can be stolen by another processor.----data Worker = Worker {- workerId :: {-# UNPACK #-} !Int-- -- Coordinating with the host thread- , requestVar :: {-# UNPACK #-} !(MVar Req)- , resultVar :: {-# UNPACK #-} !(MVar ())-- -- Work scheduling- , workpool :: {-# UNPACK #-} !(WSDeque Range)- , consecutiveFailures :: {-# UNPACK #-} !(MutVar RealWorld Int)- , rngState :: {-# UNPACK #-} !GenIO -- TLM: don't unpack: too large?-- -- TODO: debug/work statistics- }--instance Eq Worker where- w1 == w2 = workerId w1 == workerId w2----- | The 'Req' type encapsulates work requests for individual workers----data Req- -- | Instruct the worker to run the given action- = ReqDo (Int -> IO ())-- -- | Tell the worker to exit. The worker should signal that it received the- -- request by writing its result var before exiting.- | ReqShutdown----- A global name supply. This is not strictly necessary, but useful for ensuring--- that each worker thread has a unique identifier. We can't just use the--- threadId the worker is spawned on, because we might have multiple work groups--- (i.e. for CPUs and GPUs)------ TLM: This isn't a bottleneck, but it would have been better to use something--- like 'Data.Atomic' as in the base Accelerate package.----{-# NOINLINE uniqueSupply #-}-uniqueSupply :: MVar Int-uniqueSupply = unsafePerformIO $ newMVar 0---- Generate a fresh identifier. Note that the bang pattern is important.-freshId :: IO Int-freshId = modifyMVar uniqueSupply (\n -> let !n' = n+1 in return (n', n))----- | Create a set of workers. This is a somewhat expensive function, so it is--- expected that it is called only occasionally (e.g. once per program--- execution).----forkGang :: Int -> IO Gang-forkGang n = forkGangOn [0..n-1]----- | Create a set of workers on specific capabilities. Note that the thread ID--- passed to the 'gangWorker' is the index of this worker in the gang structure,--- not necessarily the capability is is spawned on.----forkGangOn :: [Int] -> IO Gang-forkGangOn caps = do- ws <- V.forM (V.indexed (V.fromList caps)) $ \(i, cap) -> do- worker <- Worker <$> freshId -- identifier- <*> newEmptyMVar -- work request- <*> newEmptyMVar -- work complete- <*> newQ -- work stealing deque- <*> newMutVar 0 -- consecutive steal failure count- <*> createSystemRandom -- random generator for stealing- --- message (printf "fork %d on capability %d" (workerId worker) cap)- void $ mkWeakMVar (requestVar worker) (finaliseWorker worker)- void $ forkOn cap $ gangWorker i worker- return worker- newMVar ws----- | The main worker loop for a thread in the gang.------ Threads block on the MVar waiting for work requests, until told to exit.----gangWorker :: Int -> Worker -> IO ()-gangWorker threadId st@Worker{..} = do-- -- Wait for a request- req <- takeMVar requestVar-- case req of- ReqShutdown ->- putMVar resultVar () -- signal that we got the shutdown order-- ReqDo action -> do- action threadId -- Run the action we were given- putMVar resultVar () -- Signal that the action is complete- gangWorker threadId st -- Wait for more requests----- | Gain control of the gang and use it to do some work----gangIO :: Gang -> (Workers -> IO ()) -> IO ()-gangIO = withMVar---- | Issue work requests to the threads and wait until they complete----workerIO :: Workers -> (Int -> IO ()) -> IO ()-workerIO workers action = mask $ \restore -> do- main <- myThreadId-- -- Send requests to the threads- V.forM_ workers $ \Worker{..} -> do- writeMutVar consecutiveFailures 0- putMVar requestVar $ ReqDo (reflectExceptionsTo main . restore . action)-- -- Wait for all requests to complete- V.forM_ workers $ \Worker{..} -> takeMVar resultVar--reflectExceptionsTo :: ThreadId -> IO () -> IO ()-reflectExceptionsTo tid action =- catchNonThreadKilled action (throwTo tid)--catchNonThreadKilled :: IO a -> (SomeException -> IO a) -> IO a-catchNonThreadKilled action handler =- action `catch` \e ->- case fromException e of- Just ThreadKilled -> throwIO e- _ -> handler e----- | The finaliser for worker threads.------ Without this programs can complain about "Blocked indefinitely on an MVar"--- because worker threads are still blocked on the request MVars when the--- program ends. Whether the finalizer is called or not is very racey.------ We're relying on the comment in System.Mem.Weak that says:------ "If there are no other threads to run, the runtime system will check for--- runnable finalizers before declaring the system to be deadlocked."------ If we were creating and destroying the gang cleanly we wouldn't need this,--- but 'theGang' is created with a top-level unsafePerformIO. Hacks beget hacks--- beget hacks...----finaliseWorker :: Worker -> IO ()-finaliseWorker Worker{..} = do- message (printf "worker %d shutting down" workerId)- putMVar requestVar ReqShutdown- takeMVar resultVar----- | Check whether the work queues of all workers in a gang are empty----exhausted :: Workers -> IO Bool-exhausted workers =- V.and <$> V.mapM (\Worker{..} -> nullQ workpool) workers----- Debugging--- -----------{-# INLINE message #-}-message :: String -> IO ()-message msg = Debug.traceIO Debug.dump_sched ("gang: " ++ msg)-
src/Data/Array/Accelerate/LLVM/AST.hs view
@@ -5,33 +5,33 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.AST--- 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) -- module Data.Array.Accelerate.LLVM.AST ( + DelayedOpenAcc(..), PreOpenAccCommand(..), PreOpenAccSkeleton(..),-- PreAfun, PreOpenAfun(..),- PreFun, PreOpenFun(..),- PreExp, PreOpenExp(..),- Idx(..), Val(..), prj,+ UnzipIdx(..),+ HasInitialValue, ) where -import Data.Array.Accelerate.LLVM.State import Data.Array.Accelerate.LLVM.Execute.Async -import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.AST- ( PreOpenAfun(..), PreOpenExp(..), PreOpenFun(..), Idx(..), Val(..), PreAfun, PreFun, PreExp, prj )+import Data.Array.Accelerate.AST ( PreOpenAfun(..), HasArraysR(..), ArrayVar, ALeftHandSide, Exp, Direction, PrimBool, arrayR )+import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.Var+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type -- | Non-computational array program operations, parameterised over array@@ -39,67 +39,60 @@ -- data PreOpenAccCommand acc arch aenv a where - Avar :: Arrays arrs- => Idx aenv arrs+ Avar :: ArrayVar aenv arrs -> PreOpenAccCommand acc arch aenv arrs - Alet :: (Arrays bnd, Arrays body)- => acc arch aenv bnd- -> acc arch (aenv, bnd) body- -> PreOpenAccCommand acc arch aenv body+ Alet :: ALeftHandSide bnd aenv aenv'+ -> acc arch aenv bnd+ -> acc arch aenv' body+ -> PreOpenAccCommand acc arch aenv body - Alloc :: (Shape sh, Elt e)- => PreExp (acc arch) aenv sh- -> PreOpenAccCommand acc arch aenv (Array sh e)+ Alloc :: ArrayR (Array sh e)+ -> Exp aenv sh+ -> PreOpenAccCommand acc arch aenv (Array sh e) - Use :: Arrays arrs- => ArrRepr arrs- -> PreOpenAccCommand acc arch aenv arrs+ Use :: ArrayR (Array sh e)+ -> Array sh e+ -> PreOpenAccCommand acc arch aenv (Array sh e) - Unit :: Elt e- => PreExp (acc arch) aenv e- -> PreOpenAccCommand acc arch aenv (Scalar e)+ Unit :: TypeR e+ -> Exp aenv e+ -> PreOpenAccCommand acc arch aenv (Scalar e) - Atuple :: (Arrays arrs, IsAtuple arrs)- => Atuple (acc arch aenv) (TupleRepr arrs)- -> PreOpenAccCommand acc arch aenv arrs+ Apair :: acc arch aenv arrs1+ -> acc arch aenv arrs2+ -> PreOpenAccCommand acc arch aenv (arrs1, arrs2) - Aprj :: (Arrays arrs, IsAtuple arrs, Arrays a)- => TupleIdx (TupleRepr arrs) a- -> acc arch aenv arrs- -> PreOpenAccCommand acc arch aenv a+ Anil :: PreOpenAccCommand acc arch aenv () - Apply :: (Arrays as, Arrays bs)- => PreOpenAfun (acc arch) aenv (as -> bs)+ Apply :: ArraysR bs+ -> PreOpenAfun (acc arch) aenv (as -> bs) -> acc arch aenv as -> PreOpenAccCommand acc arch aenv bs - Aforeign :: (Arrays as, Arrays bs)- => String- -> (StreamR arch -> as -> LLVM arch bs)+ Aforeign :: ArraysR bs+ -> String+ -> (as -> Par arch (FutureR arch bs)) -> acc arch aenv as -> PreOpenAccCommand acc arch aenv bs - Acond :: Arrays arrs- => PreExp (acc arch) aenv Bool+ Acond :: Exp aenv PrimBool -> acc arch aenv arrs -> acc arch aenv arrs -> PreOpenAccCommand acc arch aenv arrs - Awhile :: Arrays arrs- => PreOpenAfun (acc arch) aenv (arrs -> Scalar Bool)+ Awhile :: PreOpenAfun (acc arch) aenv (arrs -> Scalar PrimBool) -> PreOpenAfun (acc arch) aenv (arrs -> arrs) -> acc arch aenv arrs -> PreOpenAccCommand acc arch aenv arrs - Reshape :: (Shape sh, Shape sh', Elt e)- => PreExp (acc arch) aenv sh- -> Idx aenv (Array sh' e)+ Reshape :: ShapeR sh+ -> Exp aenv sh+ -> ArrayVar aenv (Array sh' e) -> PreOpenAccCommand acc arch aenv (Array sh e) - Unzip :: (Elt tup, Elt e)- => TupleIdx (TupleRepr tup) e- -> Idx aenv (Array sh tup)+ Unzip :: UnzipIdx tup e+ -> ArrayVar aenv (Array sh tup) -> PreOpenAccCommand acc arch aenv (Array sh e) @@ -108,75 +101,135 @@ -- data PreOpenAccSkeleton acc arch aenv a where - Map :: (Shape sh, Elt e)- => PreExp (acc arch) aenv sh- -> PreOpenAccSkeleton acc arch aenv (Array sh e)+ -- Producers. The only way these terms can appear in the AST is if they+ -- are applied to a manifest array.+ --+ Map :: TypeR b+ -> acc arch aenv (Array sh a)+ -> PreOpenAccSkeleton acc arch aenv (Array sh b) - Generate :: (Shape sh, Elt e)- => PreExp (acc arch) aenv sh- -> PreOpenAccSkeleton acc arch aenv (Array sh e)+ Generate :: ArrayR (Array sh e)+ -> Exp aenv sh+ -> PreOpenAccSkeleton acc arch aenv (Array sh e) - Transform :: (Shape sh, Elt e)- => PreExp (acc arch) aenv sh- -> PreOpenAccSkeleton acc arch aenv (Array sh e)+ Transform :: ArrayR (Array sh' b)+ -> Exp aenv sh'+ -> acc arch aenv (Array sh a)+ -> PreOpenAccSkeleton acc arch aenv (Array sh' b) - Backpermute :: (Shape sh, Elt e)- => PreExp (acc arch) aenv sh- -> PreOpenAccSkeleton acc arch aenv (Array sh e)+ Backpermute :: ShapeR sh'+ -> Exp aenv sh'+ -> acc arch aenv (Array sh e)+ -> PreOpenAccSkeleton acc arch aenv (Array sh' e) - Fold :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array sh e)+ -- Consumers. These may have been applied to either manifest or delayed+ -- array data.+ --+ Fold :: HasInitialValue+ -> DelayedOpenAcc acc arch aenv (Array (sh, Int) e)+ -> PreOpenAccSkeleton acc arch aenv (Array sh e) - Fold1 :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array sh e)+ FoldSeg :: IntegralType i+ -> HasInitialValue+ -> DelayedOpenAcc acc arch aenv (Array (sh, Int) e)+ -> DelayedOpenAcc acc arch aenv (Segments i)+ -> PreOpenAccSkeleton acc arch aenv (Array (sh, Int) e) - FoldSeg :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreExp (acc arch) aenv (Z :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array (sh:.Int) e)+ Scan :: Direction+ -> HasInitialValue+ -> DelayedOpenAcc acc arch aenv (Array (sh, Int) e)+ -> PreOpenAccSkeleton acc arch aenv (Array (sh, Int) e) - Fold1Seg :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreExp (acc arch) aenv (Z :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array (sh:.Int) e)+ Scan' :: Direction+ -> DelayedOpenAcc acc arch aenv (Array (sh, Int) e)+ -> PreOpenAccSkeleton acc arch aenv (Array (sh, Int) e, Array sh e) - Scanl :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array (sh:.Int) e)+ Permute :: acc arch aenv (Array sh' e) -- target array (default values)+ -> DelayedOpenAcc acc arch aenv (Array sh e) -- source values+ -> PreOpenAccSkeleton acc arch aenv (Array sh' e) - Scanl1 :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array (sh:.Int) e)+ Stencil1 :: TypeR b+ -> sh -- stencil offset/halo size+ -> DelayedOpenAcc acc arch aenv (Array sh a)+ -> PreOpenAccSkeleton acc arch aenv (Array sh b) - Scanl' :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array (sh:.Int) e, Array sh e)+ Stencil2 :: TypeR c+ -> sh -- stencil offset/halo size+ -> DelayedOpenAcc acc arch aenv (Array sh a)+ -> DelayedOpenAcc acc arch aenv (Array sh b)+ -> PreOpenAccSkeleton acc arch aenv (Array sh c) - Scanr :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array (sh:.Int) e)+data UnzipIdx a b where+ UnzipId :: UnzipIdx a a+ UnzipPrj :: PairIdx a b -> UnzipIdx b c -> UnzipIdx a c+ UnzipUnit :: UnzipIdx a ()+ UnzipPair :: UnzipIdx a b1 -> UnzipIdx a b2 -> UnzipIdx a (b1, b2) - Scanr1 :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array (sh:.Int) e)+-- Denotes whether the fold or scan has an initial value.+-- When False, this is a fold1 or scan1.+--+type HasInitialValue = Bool - Scanr' :: (Shape sh, Elt e)- => PreExp (acc arch) aenv (sh :. Int)- -> PreOpenAccSkeleton acc arch aenv (Array (sh:.Int) e, Array sh e)+-- | Representation for array arguments.+--+-- If the argument is a delayed array (that is, it was fused into its+-- consumer) we only need to keep track of the extent of the argument. If+-- the argument is a manifest array, we recurse into the subterm.+--+data DelayedOpenAcc acc arch aenv a where+ Delayed :: ArrayR (Array sh e)+ -> Exp aenv sh+ -> DelayedOpenAcc acc arch aenv (Array sh e) - Permute :: (Shape sh, Shape sh', Elt e)- => PreExp (acc arch) aenv sh -- source- -> acc arch aenv (Array sh' e) -- default values- -> PreOpenAccSkeleton acc arch aenv (Array sh' e)+ Manifest :: ArraysR (Array sh e)+ -> acc arch aenv (Array sh e)+ -> DelayedOpenAcc acc arch aenv (Array sh e) - Stencil :: (Shape sh, Elt e)- => PreExp (acc arch) aenv sh- -> PreOpenAccSkeleton acc arch aenv (Array sh e)+instance HasArraysR (acc arch) => HasArraysR (PreOpenAccCommand acc arch) where+ {-# INLINEABLE arraysR #-}+ arraysR (Avar (Var repr _)) = TupRsingle repr+ arraysR (Alet _ _ a) = arraysR a+ arraysR (Alloc repr _) = TupRsingle repr+ arraysR (Use repr _) = TupRsingle repr+ arraysR (Unit tp _) = TupRsingle $ ArrayR ShapeRz tp+ arraysR (Apair a1 a2) = arraysR a1 `TupRpair` arraysR a2+ arraysR Anil = TupRunit+ arraysR (Apply repr _ _) = repr+ arraysR (Aforeign repr _ _ _) = repr+ arraysR (Acond _ a1 _) = arraysR a1+ arraysR (Awhile _ _ a) = arraysR a+ arraysR (Reshape shr _ (Var (ArrayR _ tp) _)) = TupRsingle $ ArrayR shr tp+ arraysR (Unzip idx (Var (ArrayR shr tp) _)) = TupRsingle $ ArrayR shr $ go idx tp+ where+ go :: UnzipIdx a b -> TypeR a -> TypeR b+ go UnzipId t = t+ go (UnzipPrj PairIdxLeft ix) (TupRpair t _) = go ix t+ go (UnzipPrj PairIdxRight ix) (TupRpair _ t) = go ix t+ go UnzipUnit _ = TupRunit+ go (UnzipPair ix1 ix2) t = go ix1 t `TupRpair` go ix2 t+ go _ _ = error "Time enough for life to unfold all the precious things life has in store." - Stencil2 :: (Shape sh, Elt e)- => PreExp (acc arch) aenv sh- -> PreExp (acc arch) aenv sh- -> PreOpenAccSkeleton acc arch aenv (Array sh e)+instance HasArraysR (acc arch) => HasArraysR (PreOpenAccSkeleton acc arch) where+ {-# INLINEABLE arraysR #-}+ arraysR (Map tp a) = let ArrayR shr _ = arrayR a+ in TupRsingle $ ArrayR shr tp+ arraysR (Generate repr _) = TupRsingle repr+ arraysR (Transform repr _ _) = TupRsingle repr+ arraysR (Backpermute shr _ a) = TupRsingle $ ArrayR shr $ arrayRtype $ arrayR a+ arraysR (Fold _ a) = let ArrayR (ShapeRsnoc shr) tp = arrayR a+ in TupRsingle $ ArrayR shr tp+ arraysR (FoldSeg _ _ a _) = arraysR a+ arraysR (Scan _ _ a) = arraysR a+ arraysR (Scan' _ a) = let ArrayR (ShapeRsnoc shr) tp = arrayR a+ in TupRsingle (ArrayR (ShapeRsnoc shr) tp) `TupRpair` TupRsingle (ArrayR shr tp)+ arraysR (Permute a _) = arraysR a+ arraysR (Stencil1 tp _ a) = let ArrayR shr _ = arrayR a+ in TupRsingle $ ArrayR shr tp+ arraysR (Stencil2 tp _ a _) = let ArrayR shr _ = arrayR a+ in TupRsingle $ ArrayR shr tp++instance HasArraysR (acc arch) => HasArraysR (DelayedOpenAcc acc arch) where+ {-# INLINEABLE arraysR #-}+ arraysR (Delayed repr _) = TupRsingle repr+ arraysR (Manifest repr _) = repr
− src/Data/Array/Accelerate/LLVM/Analysis/Match.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Data.Array.Accelerate.LLVM.Analysis.Match--- Copyright : [2016..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.Analysis.Match (-- module Data.Array.Accelerate.Analysis.Match,- module Data.Array.Accelerate.LLVM.Analysis.Match,--) where--import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar--import Data.Typeable----- Match reified shape types----matchShapeType- :: forall sh sh'. (Shape sh, Shape sh')- => sh- -> sh'- -> Maybe (sh :~: sh')-matchShapeType _ _- | Just Refl <- matchTupleType (eltType (undefined::sh)) (eltType (undefined::sh'))- = gcast Refl--matchShapeType _ _- = Nothing-
src/Data/Array/Accelerate/LLVM/Array/Data.hs view
@@ -1,15 +1,19 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.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) --@@ -17,35 +21,28 @@ module Data.Array.Accelerate.LLVM.Array.Data ( Remote(..),- newRemote,- useRemote, useRemoteAsync,- copyToRemote, copyToRemoteAsync,- copyToHost, copyToHostAsync,- copyToPeer, copyToPeerAsync,-- runIndexArray,- runArrays,- runArray,+ newRemote, newRemoteAsync,+ useRemote,+ copyToRemote,+ copyToHost,+ copyToPeer,+ indexRemote, - module Data.Array.Accelerate.Array.Data,+ runIndexArray, runIndexArrayAsync,+ runArray, runArrayAsync,+ runArrays, runArraysAsync, ) where --- accelerate import Data.Array.Accelerate.Array.Data-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.State import Data.Array.Accelerate.LLVM.Execute.Async --- standard library import Control.Monad ( liftM, liftM2 )-import Control.Monad.Trans-import Data.Typeable-import Foreign.C.Types-import Foreign.Ptr-import Foreign.Storable import Prelude @@ -53,389 +50,325 @@ -- | Allocate a new uninitialised array on the remote device. --- {-# INLINEABLE allocateRemote #-}- allocateRemote :: (Shape sh, Elt e) => sh -> LLVM arch (Array sh e)- allocateRemote sh = liftIO $ allocateArray sh+ allocateRemote :: ArrayR (Array sh e) -> sh -> Par arch (Array sh e) -- | Use the given immutable array on the remote device. Since the source- -- array is immutable, the allocator can evict and re-upload the data as- -- necessary without copy-back.+ -- array is immutable, the garbage collector can evict and re-upload the data+ -- as necessary without copy-back. --- {-# INLINEABLE useRemoteR #-}+ {-# INLINE useRemoteR #-} useRemoteR- :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e)- => Int -- ^ number of elements to copy- -> Maybe (StreamR arch) -- ^ execute synchronously w.r.t. this execution stream+ :: SingleType e+ -> Int -- ^ number of elements to copy -> ArrayData e -- ^ array payload- -> LLVM arch ()- useRemoteR _ _ _ = return ()+ -> Par arch (FutureR arch (ArrayData e))+ useRemoteR _ _ = newFull - -- | Upload a section of an array from the host to the remote device.+ -- | Upload an array from the host to the remote device. --- {-# INLINEABLE copyToRemoteR #-}+ {-# INLINE copyToRemoteR #-} copyToRemoteR- :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e)- => Int -- ^ index of first element to copy+ :: SingleType e -> Int -- ^ number of elements to copy- -> Maybe (StreamR arch) -- ^ execute synchronously w.r.t. this execution stream -> ArrayData e -- ^ array payload- -> LLVM arch ()- copyToRemoteR _ _ _ _ = return ()+ -> Par arch (FutureR arch (ArrayData e))+ copyToRemoteR _ _ = newFull - -- | Copy a section of an array from the remote device back to the host.+ -- | Copy an array from the remote device back to the host. --- {-# INLINEABLE copyToHostR #-}+ {-# INLINE copyToHostR #-} copyToHostR- :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e)- => Int -- ^ index of the first element to copy+ :: SingleType e -> Int -- ^ number of elements to copy- -> Maybe (StreamR arch) -- ^ execute synchronously w.r.t. this execution stream -> ArrayData e -- ^ array payload- -> LLVM arch ()- copyToHostR _ _ _ _ = return ()+ -> Par arch (FutureR arch (ArrayData e))+ copyToHostR _ _ = newFull -- | Copy a section of an array between two remote instances of the same type. -- This may be more efficient than copying to the host and then to the second- -- remote instance (e.g. DMA between two CUDA devices). The elements between- -- the given indices (inclusive left, exclusive right) are transferred.+ -- remote instance (e.g. DMA between two CUDA devices). --- {-# INLINEABLE copyToPeerR #-}+ {-# INLINE copyToPeerR #-} copyToPeerR- :: (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e)- => Int -- ^ index of the first element to copy+ :: arch -- ^ remote device to copy to+ -> SingleType e -> Int -- ^ number of elements to copy- -> arch -- ^ remote device to copy to- -> Maybe (StreamR arch) -- ^ execute synchronously w.r.t. this execution stream -> ArrayData e -- ^ array payload- -> LLVM arch ()- copyToPeerR _ _ _ _ _ = return ()+ -> Par arch (FutureR arch (ArrayData e))+ copyToPeerR _ _ _ = newFull - -- | Read a single element from the array at a given row-major index+ -- | Upload an immutable array from the host to the remote device,+ -- asynchronously. Since the source array is immutable, the garbage collector+ -- can evict and re-upload the data as necessary without copy-back. This may+ -- upload each array payload in a separate execution stream, thereby making us+ -- of multiple memcpy engines. --- {-# INLINEABLE indexRemote #-}- indexRemote :: Array sh e -> Int -> LLVM arch e- indexRemote (Array _ adata) i = return . toElt $! unsafeIndexArrayData adata i+ {-# INLINE useRemoteAsync #-}+ useRemoteAsync :: ArraysR arrs -> arrs -> Par arch (FutureArraysR arch arrs)+ useRemoteAsync repr arrs =+ runArraysAsync repr arrs $ \(ArrayR shr tp) arr ->+ let n = size shr (shape arr)+ in runArrayAsync tp arr $ \m tp' ad ->+ useRemoteR tp' (n*m) ad + -- | Upload an existing array to the remote device, asynchronously.+ --+ {-# INLINE copyToRemoteAsync #-}+ copyToRemoteAsync :: ArraysR arrs -> arrs -> Par arch (FutureArraysR arch arrs)+ copyToRemoteAsync reprs arrs =+ runArraysAsync reprs arrs $ \(ArrayR shr tp) arr ->+ let n = size shr (shape arr)+ in runArrayAsync tp arr $ \m tp' ad ->+ copyToRemoteR tp' (n*m) ad + -- | Copy an array from the remote device to the host, asynchronously+ --+ {-# INLINE copyToHostAsync #-}+ copyToHostAsync :: ArraysR arrs -> arrs -> Par arch (FutureArraysR arch arrs)+ copyToHostAsync reprs arrs =+ runArraysAsync reprs arrs $ \(ArrayR shr tp) arr ->+ let n = size shr (shape arr)+ in runArrayAsync tp arr $ \m tp' ad ->+ copyToHostR tp' (n*m) ad++ -- | Copy arrays between two remote instances. This may be more efficient than+ -- copying to the host and then to the second remote instance (e.g. by DMA+ -- between the two remote devices).+ --+ {-# INLINE copyToPeerAsync #-}+ copyToPeerAsync :: arch -> ArraysR arrs -> arrs -> Par arch (FutureArraysR arch arrs)+ copyToPeerAsync peer reprs arrs =+ runArraysAsync reprs arrs $ \(ArrayR shr tp) arr ->+ let n = size shr (shape arr)+ in runArrayAsync tp arr $ \m tp' ad ->+ copyToPeerR peer tp' (n*m) ad++ -- | Read a single element from the array at the given row-major index+ --+ {-# INLINE indexRemoteAsync #-}+ indexRemoteAsync+ :: TypeR e+ -> Array sh e+ -> Int+ -> Par arch (FutureR arch e)+ indexRemoteAsync tp (Array _ ad) i = newFull (indexArrayData tp ad i)++ -- | Create a new array from its representation on the host, and upload it to--- a new remote array.+-- the remote device. ---{-# INLINEABLE newRemote #-}+{-# INLINE newRemote #-} newRemote- :: (Remote arch, Shape sh, Elt e)- => sh+ :: Remote arch+ => ArrayR (Array sh e)+ -> sh -> (sh -> e)- -> LLVM arch (Array sh e)-newRemote sh f =- useRemote $! fromFunction sh f+ -> Par arch (Array sh e)+newRemote repr sh f =+ get =<< newRemoteAsync repr sh f +-- | Create a new array from its representation on the host, and upload it as+-- a new remote array, asynchronously.+--+{-# INLINE newRemoteAsync #-}+newRemoteAsync+ :: Remote arch+ => ArrayR (Array sh e)+ -> sh+ -> (sh -> e)+ -> Par arch (FutureR arch (Array sh e))+newRemoteAsync repr sh f =+ useRemoteAsync (TupRsingle repr) $! fromFunction repr sh f++ -- | Upload an immutable array from the host to the remote device. This is -- a synchronous operation in that it will not return until the transfer -- completes, but the individual array payloads will be uploaded concurrently if -- possible. ---{-# INLINEABLE useRemote #-}-useRemote :: (Remote arch, Arrays arrs) => arrs -> LLVM arch arrs-useRemote arrs = do- AsyncR _ a <- async (useRemoteAsync arrs)- get a----- | Upload an immutable array from the host to the remote device,--- asynchronously. This will upload each array payload in a separate execution--- stream, thereby making us of multiple memcpy engines (where available).----{-# INLINEABLE useRemoteAsync #-}-useRemoteAsync- :: (Remote arch, Arrays arrs)- => arrs- -> StreamR arch- -> LLVM arch (AsyncR arch arrs)-useRemoteAsync arrs stream = do- arrs' <- runArrays arrs $ \arr@Array{} ->- let n = size (shape arr)- in runArray arr $ \m ad -> do- s <- fork- useRemoteR (n*m) (Just s) ad- after stream =<< checkpoint s- join s- return ad- --- event <- checkpoint stream -- TLM: Assuming that adding events to a stream counts as things to wait for- return $! AsyncR event arrs'-+{-# INLINE useRemote #-}+useRemote :: Remote arch => ArraysR a -> a -> Par arch a+useRemote repr arrs =+ getArrays repr =<< useRemoteAsync repr arrs -- | Uploading existing arrays from the host to the remote device. This is -- synchronous with respect to the calling thread, but the individual array -- payloads may themselves be transferred concurrently. ---{-# INLINEABLE copyToRemote #-}-copyToRemote :: (Remote arch, Arrays a) => a -> LLVM arch a-copyToRemote arrs = do- AsyncR _ a <- async (copyToRemoteAsync arrs)- get a----- | Upload an existing array to the remote device, asynchronously.----{-# INLINEABLE copyToRemoteAsync #-}-copyToRemoteAsync- :: (Remote arch, Arrays a)- => a- -> StreamR arch- -> LLVM arch (AsyncR arch a)-copyToRemoteAsync arrs stream = do- arrs' <- runArrays arrs $ \arr@Array{} ->- let n = size (shape arr)- in runArray arr $ \m ad -> do- s <- fork- copyToRemoteR 0 (n*m) (Just s) ad- after stream =<< checkpoint s- join s- return ad- --- event <- checkpoint stream- return $! AsyncR event arrs'-+{-# INLINE copyToRemote #-}+copyToRemote :: Remote arch => ArraysR a -> a -> Par arch a+copyToRemote repr arrs =+ getArrays repr =<< copyToRemoteAsync repr arrs -- | Copy an array from the remote device to the host. This is synchronous with -- respect to the calling thread, but the individual array payloads may -- themselves be transferred concurrently. ---{-# INLINEABLE copyToHost #-}-copyToHost :: (Remote arch, Arrays a) => a -> LLVM arch a-copyToHost arrs = do- AsyncR _ a <- async (copyToHostAsync arrs)- get a----- | Copy an array from the remote device to the host, asynchronously----{-# INLINEABLE copyToHostAsync #-}-copyToHostAsync- :: (Remote arch, Arrays a)- => a- -> StreamR arch- -> LLVM arch (AsyncR arch a)-copyToHostAsync arrs stream = do- arrs' <- runArrays arrs $ \arr@Array{} ->- let n = size (shape arr)- in runArray arr $ \m ad -> do- s <- fork- copyToHostR 0 (n*m) (Just s) ad- after stream =<< checkpoint s- join s- return ad- --- event <- checkpoint stream- return $! AsyncR event arrs'-+{-# INLINE copyToHost #-}+copyToHost :: Remote arch => ArraysR a -> a -> Par arch a+copyToHost repr arrs =+ blockArrays repr =<< copyToHostAsync repr arrs -- | Copy arrays between two remote instances of the same type. This may be more -- efficient than copying to the host and then to the second remote instance -- (e.g. DMA between CUDA devices). ---{-# INLINEABLE copyToPeer #-}-copyToPeer :: (Remote arch, Arrays a) => arch -> a -> LLVM arch a-copyToPeer peer arrs = do- AsyncR _ a <- async (copyToPeerAsync peer arrs)- get a-+{-# INLINE copyToPeer #-}+copyToPeer :: Remote arch => arch -> ArraysR a -> a -> Par arch a+copyToPeer peer repr arrs =+ getArrays repr =<< copyToPeerAsync peer repr arrs --- | As 'copyToPeer', asynchronously.+-- | Read a single element from the remote array at the given row-major index.+-- This is synchronous with respect to both the host and remote device. ---{-# INLINEABLE copyToPeerAsync #-}-copyToPeerAsync- :: (Remote arch, Arrays a)- => arch- -> a- -> StreamR arch- -> LLVM arch (AsyncR arch a)-copyToPeerAsync peer arrs stream = do- arrs' <- runArrays arrs $ \arr@Array{} ->- let n = size (shape arr)- in runArray arr $ \m ad -> do- s <- fork- copyToPeerR 0 (n*m) peer (Just s) ad- after stream =<< checkpoint s- join s- return ad- --- event <- checkpoint stream- return $! AsyncR event arrs'+{-# INLINE indexRemote #-}+indexRemote :: Remote arch => TypeR e -> Array sh e -> Int -> Par arch e+indexRemote tp arr i =+ block =<< indexRemoteAsync tp arr i -- Helpers for traversing the Arrays data structure -- ------------------------------------------------ --- |Read a single element from an array at the given row-major index.+-- | Read a single element from an array at the given row-major index. ---{-# INLINEABLE runIndexArray #-}+{-# INLINE runIndexArray #-} runIndexArray :: forall m sh e. Monad m- => (forall e a. (ArrayElt e, ArrayPtrs e ~ Ptr a, Storable a, Typeable a, Typeable e) => ArrayData e -> Int -> m a)+ => (forall s. ArrayData s ~ ScalarArrayData s => Int -> SingleType s -> ArrayData s -> Int -> m (ArrayData s))+ -> TypeR e -> Array sh e -> Int -> m e-runIndexArray worker (Array _ adata) ix = toElt `liftM` indexR arrayElt adata ix+runIndexArray worker tp (Array _ adata) i = flip (indexArrayData tp) 0 <$> indexR tp adata where- indexR :: ArrayEltR a -> ArrayData a -> Int -> m a- indexR ArrayEltRunit _ _ = return ()- indexR ArrayEltRint ad i = worker ad i- indexR ArrayEltRint8 ad i = worker ad i- indexR ArrayEltRint16 ad i = worker ad i- indexR ArrayEltRint32 ad i = worker ad i- indexR ArrayEltRint64 ad i = worker ad i- indexR ArrayEltRword ad i = worker ad i- indexR ArrayEltRword8 ad i = worker ad i- indexR ArrayEltRword16 ad i = worker ad i- indexR ArrayEltRword32 ad i = worker ad i- indexR ArrayEltRword64 ad i = worker ad i- indexR ArrayEltRhalf ad i = worker ad i- indexR ArrayEltRfloat ad i = worker ad i- indexR ArrayEltRdouble ad i = worker ad i- indexR ArrayEltRchar ad i = worker ad i- indexR ArrayEltRcshort ad i = CShort `liftM` worker ad i- indexR ArrayEltRcushort ad i = CUShort `liftM` worker ad i- indexR ArrayEltRcint ad i = CInt `liftM` worker ad i- indexR ArrayEltRcuint ad i = CUInt `liftM` worker ad i- indexR ArrayEltRclong ad i = CLong `liftM` worker ad i- indexR ArrayEltRculong ad i = CULong `liftM` worker ad i- indexR ArrayEltRcllong ad i = CLLong `liftM` worker ad i- indexR ArrayEltRcullong ad i = CULLong `liftM` worker ad i- indexR ArrayEltRcchar ad i = CChar `liftM` worker ad i- indexR ArrayEltRcschar ad i = CSChar `liftM` worker ad i- indexR ArrayEltRcuchar ad i = CUChar `liftM` worker ad i- indexR ArrayEltRcfloat ad i = CFloat `liftM` worker ad i- indexR ArrayEltRcdouble ad i = CDouble `liftM` worker ad i- indexR ArrayEltRbool ad i = toBool `liftM` worker ad i- where- toBool 0 = False- toBool _ = True- --- indexR (ArrayEltRpair aeR1 aeR2) (AD_Pair ad1 ad2) i =- (,) <$> indexR aeR1 ad1 i- <*> indexR aeR2 ad2 i-- -- NOTE [indexArray for SIMD vector types]- --- -- These data types are stored contiguously in memory. Especially for- -- backends where data is stored in a separate memory space (i.e. GPUs) we- -- should copy all of those values in a single transaction, before unpacking- -- them to the appropriate Haskell value (and/or, also store these values- -- contiguously in Haskell land). @speed- --- indexR (ArrayEltRvec2 r) (AD_V2 ad) i =- let i' = 2*i- in V2 <$> indexR r ad i'- <*> indexR r ad (i'+1)-- indexR (ArrayEltRvec3 r) (AD_V3 ad) i =- let i' = 3*i- in V3 <$> indexR r ad i'- <*> indexR r ad (i'+1)- <*> indexR r ad (i'+2)-- indexR (ArrayEltRvec4 r) (AD_V4 ad) i =- let i' = 4*i- in V4 <$> indexR r ad i'- <*> indexR r ad (i'+1)- <*> indexR r ad (i'+2)- <*> indexR r ad (i'+3)+ indexR :: TypeR s -> ArrayData s -> m (ArrayData s)+ indexR TupRunit !_ = return ()+ indexR (TupRpair !t1 !t2) (!ad1, !ad2) = liftM2 (,) (indexR t1 ad1) (indexR t2 ad2)+ indexR (TupRsingle t) !ad+ | ScalarArrayDict w s <- scalarArrayDict t+ , SingleArrayDict <- singleArrayDict s+ = worker w s ad i - indexR (ArrayEltRvec8 r) (AD_V8 ad) i =- let i' = 8*i- in V8 <$> indexR r ad i'- <*> indexR r ad (i'+1)- <*> indexR r ad (i'+2)- <*> indexR r ad (i'+3)- <*> indexR r ad (i'+4)- <*> indexR r ad (i'+5)- <*> indexR r ad (i'+6)- <*> indexR r ad (i'+7)+{-# INLINE runIndexArrayAsync #-}+runIndexArrayAsync+ :: forall arch sh e. Async arch+ => (forall s. ArrayData s ~ ScalarArrayData s => Int -> SingleType s -> ArrayData s -> Int -> Par arch (FutureR arch (ArrayData s)))+ -> TypeR e+ -> Array sh e+ -> Int+ -> Par arch (FutureR arch e)+runIndexArrayAsync worker tp (Array _ adata) i = (flip (indexArrayData tp) 0) `liftF` indexR tp adata+ where+ indexR :: TypeR s -> ArrayData s -> Par arch (FutureR arch (ArrayData s))+ indexR TupRunit !_ = newFull ()+ indexR (TupRpair !t1 !t2) (!ad1, !ad2) = liftF2' (,) (indexR t1 ad1) (indexR t2 ad2)+ indexR (TupRsingle t) !ad+ | ScalarArrayDict w s <- scalarArrayDict t+ , SingleArrayDict <- singleArrayDict s+ = worker w s ad i - indexR (ArrayEltRvec16 r) (AD_V16 ad) i =- let i' = 16*i- in V16 <$> indexR r ad i'- <*> indexR r ad (i'+1)- <*> indexR r ad (i'+2)- <*> indexR r ad (i'+3)- <*> indexR r ad (i'+4)- <*> indexR r ad (i'+5)- <*> indexR r ad (i'+6)- <*> indexR r ad (i'+7)- <*> indexR r ad (i'+8)- <*> indexR r ad (i'+9)- <*> indexR r ad (i'+10)- <*> indexR r ad (i'+11)- <*> indexR r ad (i'+12)- <*> indexR r ad (i'+13)- <*> indexR r ad (i'+14)- <*> indexR r ad (i'+15)+ -- It is expected these transfers will be very small, so don't bother+ -- creating new execution streams for them+ liftF2' :: (a -> b -> c) -> Par arch (FutureR arch a) -> Par arch (FutureR arch b) -> Par arch (FutureR arch c)+ liftF2' f x y = do+ r <- new+ x' <- x+ y' <- y+ put r =<< liftM2 f (get x') (get y')+ return r -- | Generalised function to traverse the Arrays structure -- {-# INLINE runArrays #-} runArrays- :: forall m arrs. (Monad m, Arrays arrs)- => arrs- -> (forall sh e. Array sh e -> m (Array sh e))+ :: forall m arrs. Monad m+ => ArraysR arrs+ -> arrs+ -> (forall sh e. ArrayR (Array sh e) -> Array sh e -> m (Array sh e)) -> m arrs-runArrays arrs worker = toArr `liftM` runR (arrays arrs) (fromArr arrs)+runArrays reprs arrs worker = runR reprs arrs where runR :: ArraysR a -> a -> m a- runR ArraysRunit () = return ()- runR ArraysRarray arr = worker arr- runR (ArraysRpair aeR2 aeR1) (arrs2, arrs1) = liftM2 (,) (runR aeR2 arrs2) (runR aeR1 arrs1)+ runR TupRunit () = return ()+ runR (TupRsingle repr@ArrayR{}) arr = worker repr arr+ runR (TupRpair aeR2 aeR1) (arrs2, arrs1) = liftM2 (,) (runR aeR2 arrs2) (runR aeR1 arrs1) +{-# INLINE runArraysAsync #-}+runArraysAsync+ :: forall arch arrs. Async arch+ => ArraysR arrs+ -> arrs+ -> (forall sh e. ArrayR (Array sh e) -> Array sh e -> Par arch (FutureR arch (Array sh e)))+ -> Par arch (FutureArraysR arch arrs)+runArraysAsync reprs arrs worker = runR reprs arrs+ where+ runR :: ArraysR a -> a -> Par arch (FutureArraysR arch a)+ runR TupRunit () = return ()+ runR (TupRsingle repr@ArrayR{}) arr = worker repr arr+ runR (TupRpair aeR2 aeR1) (arrs2, arrs1) = (,) <$> runR aeR2 arrs2 <*> runR aeR1 arrs1 + -- | Generalised function to traverse the ArrayData structure with one -- additional argument -- {-# INLINE runArray #-} runArray :: forall m sh e. Monad m- => Array sh e- -> (forall e' p. (ArrayElt e', ArrayPtrs e' ~ Ptr p, Storable p, Typeable p, Typeable e') => Int -> ArrayData e' -> m (ArrayData e'))+ => TypeR e+ -> Array sh e+ -> (forall s. ArrayData s ~ ScalarArrayData s => Int -> SingleType s -> ScalarArrayData s -> m (ScalarArrayData s)) -> m (Array sh e)-runArray (Array sh adata) worker = Array sh `liftM` runR arrayElt adata 1+runArray tp (Array sh adata) worker = Array sh `liftM` runR tp adata where- runR :: ArrayEltR e' -> ArrayData e' -> Int -> m (ArrayData e')- runR ArrayEltRint ad n = worker n ad- runR ArrayEltRint8 ad n = worker n ad- runR ArrayEltRint16 ad n = worker n ad- runR ArrayEltRint32 ad n = worker n ad- runR ArrayEltRint64 ad n = worker n ad- runR ArrayEltRword ad n = worker n ad- runR ArrayEltRword8 ad n = worker n ad- runR ArrayEltRword16 ad n = worker n ad- runR ArrayEltRword32 ad n = worker n ad- runR ArrayEltRword64 ad n = worker n ad- runR ArrayEltRhalf ad n = worker n ad- runR ArrayEltRfloat ad n = worker n ad- runR ArrayEltRdouble ad n = worker n ad- runR ArrayEltRbool ad n = worker n ad- runR ArrayEltRchar ad n = worker n ad- runR ArrayEltRcshort ad n = worker n ad- runR ArrayEltRcushort ad n = worker n ad- runR ArrayEltRcint ad n = worker n ad- runR ArrayEltRcuint ad n = worker n ad- runR ArrayEltRclong ad n = worker n ad- runR ArrayEltRculong ad n = worker n ad- runR ArrayEltRcllong ad n = worker n ad- runR ArrayEltRcullong ad n = worker n ad- runR ArrayEltRcfloat ad n = worker n ad- runR ArrayEltRcdouble ad n = worker n ad- runR ArrayEltRcchar ad n = worker n ad- runR ArrayEltRcschar ad n = worker n ad- runR ArrayEltRcuchar ad n = worker n ad- runR (ArrayEltRvec2 ae) (AD_V2 ad) n = liftM AD_V2 (runR ae ad (n*2))- runR (ArrayEltRvec3 ae) (AD_V3 ad) n = liftM AD_V3 (runR ae ad (n*3))- runR (ArrayEltRvec4 ae) (AD_V4 ad) n = liftM AD_V4 (runR ae ad (n*4))- runR (ArrayEltRvec8 ae) (AD_V8 ad) n = liftM AD_V8 (runR ae ad (n*8))- runR (ArrayEltRvec16 ae) (AD_V16 ad) n = liftM AD_V16 (runR ae ad (n*16))- runR (ArrayEltRpair aeR2 aeR1) (AD_Pair ad2 ad1) n = liftM2 AD_Pair (runR aeR2 ad2 n) (runR aeR1 ad1 n)- runR ArrayEltRunit AD_Unit _ = return AD_Unit+ runR :: TypeR s -> ArrayData s -> m (ArrayData s)+ runR (TupRunit) !_ = return ()+ runR (TupRpair !t2 !t1) (!ad2, !ad1) = liftM2 (,) (runR t2 ad2) (runR t1 ad1)+ runR (TupRsingle !t) !ad+ | ScalarArrayDict w s <- scalarArrayDict t+ , SingleArrayDict <- singleArrayDict s+ = worker w s ad++{-# INLINE runArrayAsync #-}+runArrayAsync+ :: forall arch sh e. Async arch+ => TypeR e+ -> Array sh e+ -> (forall s. ArrayData s ~ ScalarArrayData s => Int -> SingleType s -> ScalarArrayData s -> Par arch (FutureR arch (ScalarArrayData s)))+ -> Par arch (FutureR arch (Array sh e))+runArrayAsync tp (Array sh adata) worker = Array sh `liftF` runR tp adata+ where+ runR :: forall s. TypeR s -> ArrayData s -> Par arch (FutureR arch (ArrayData s))+ runR (TupRunit) !_ = newFull ()+ runR (TupRpair !t2 !t1) (!ad2, !ad1) = liftF2 (,) (runR t2 ad2) (runR t1 ad1)+ runR (TupRsingle !t) !ad+ | ScalarArrayDict w s <- scalarArrayDict t+ , SingleArrayDict <- singleArrayDict s+ = worker w s ad++{-# INLINE liftF #-}+liftF :: Async arch+ => (a -> b)+ -> Par arch (FutureR arch a)+ -> Par arch (FutureR arch b)+liftF f x = do+ r <- new+ x' <- x+ fork $ put r . f =<< get x'+ return r++{-# INLINE liftF2 #-}+liftF2 :: Async arch+ => (a -> b -> c)+ -> Par arch (FutureR arch a)+ -> Par arch (FutureR arch b)+ -> Par arch (FutureR arch c)+liftF2 f x y = do+ r <- new+ x' <- spawn x+ y' <- spawn y+ fork $ put r =<< liftM2 f (get x') (get y')+ return r
src/Data/Array/Accelerate/LLVM/CodeGen.hs view
@@ -2,16 +2,16 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen--- 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) --@@ -19,116 +19,109 @@ module Data.Array.Accelerate.LLVM.CodeGen ( Skeleton(..), Intrinsic(..), KernelMetadata,- llvmOfOpenAcc,+ llvmOfPreOpenAcc, ) where --- accelerate-import Data.Array.Accelerate.AST hiding ( Val(..), prj, stencil )-import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )+import Data.Array.Accelerate.AST import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Representation.Stencil+import Data.Array.Accelerate.Trafo.Delayed import Data.Array.Accelerate.LLVM.Target 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.Intrinsic import Data.Array.Accelerate.LLVM.CodeGen.Module import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Permute import Data.Array.Accelerate.LLVM.CodeGen.Skeleton+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.Foreign+import Data.Array.Accelerate.LLVM.State --- standard library import Prelude hiding ( map, scanl, scanl1, scanr, scanr1 ) -- | Generate code for a given target architecture. ---{-# INLINEABLE llvmOfOpenAcc #-}-llvmOfOpenAcc- :: forall arch aenv arrs. (Target arch, Skeleton arch, Intrinsic arch, Foreign arch)- => arch- -> UID- -> DelayedOpenAcc aenv arrs+{-# INLINEABLE llvmOfPreOpenAcc #-}+llvmOfPreOpenAcc+ :: forall arch aenv arrs. (HasCallStack, Target arch, Skeleton arch, Intrinsic arch, Foreign arch)+ => UID+ -> PreOpenAcc DelayedOpenAcc aenv arrs -> Gamma aenv- -> Module arch aenv arrs-llvmOfOpenAcc _ _ Delayed{} _ = $internalError "llvmOfOpenAcc" "expected manifest array"-llvmOfOpenAcc arch uid (Manifest pacc) aenv = runLLVM $+ -> LLVM arch (Module arch aenv arrs)+llvmOfPreOpenAcc uid pacc aenv = evalCodeGen $ case pacc of -- Producers- Map f a -> map arch uid aenv (travF1 f) (travD a)- Generate _ f -> generate arch uid aenv (travF1 f)- Transform _ p f a -> transform arch uid aenv (travF1 p) (travF1 f) (travD a)- Backpermute _ p a -> backpermute arch uid aenv (travF1 p) (travD a)+ Map tp f (arrayR -> repr) -> map uid aenv repr tp (travF1 f)+ Generate repr _ f -> generate uid aenv repr (travF1 f)+ Transform repr2 _ p f (arrayR -> repr1) -> transform uid aenv repr1 repr2 (travF1 p) (travF1 f)+ Backpermute shr _ p (arrayR -> repr) -> backpermute uid aenv repr shr (travF1 p) -- Consumers- Fold f z a -> fold arch uid aenv (travF2 f) (travE z) (travD a)- Fold1 f a -> fold1 arch uid aenv (travF2 f) (travD a)- FoldSeg f z a s -> foldSeg arch uid aenv (travF2 f) (travE z) (travD a) (travD s)- Fold1Seg f a s -> fold1Seg arch uid aenv (travF2 f) (travD a) (travD s)- Scanl f z a -> scanl arch uid aenv (travF2 f) (travE z) (travD a)- Scanl' f z a -> scanl' arch uid aenv (travF2 f) (travE z) (travD a)- Scanl1 f a -> scanl1 arch uid aenv (travF2 f) (travD a)- Scanr f z a -> scanr arch uid aenv (travF2 f) (travE z) (travD a)- Scanr' f z a -> scanr' arch uid aenv (travF2 f) (travE z) (travD a)- Scanr1 f a -> scanr1 arch uid aenv (travF2 f) (travD a)- Permute f _ p a -> permute arch uid aenv (travPF f) (travF1 p) (travD a)- Stencil f b a -> stencil arch uid aenv (travF1 f) (travB b) (travD a)- Stencil2 f b1 a1 b2 a2 -> stencil2 arch uid aenv (travF2 f) (travB b1) (travD a1) (travB b2) (travD a2)+ Fold f z a -> fold uid aenv (reduceRank $ arrayR a) (travF2 f) (travE <$> z) (travD a)+ FoldSeg i f z a s -> foldSeg uid aenv (arrayR a) i (travF2 f) (travE <$> z) (travD a) (travD s)+ Scan d f z a -> scan uid aenv (arrayR a) d (travF2 f) (travE <$> z) (travD a)+ Scan' d f z a -> scan' uid aenv (arrayR a) d (travF2 f) (travE z) (travD a)+ Permute f (arrayR -> ArrayR shr _) p a -> permute uid aenv (arrayR a) shr (travPF f) (travF1 p) (travD a)+ Stencil s tp f b a -> stencil1 uid aenv s tp (travF1 f) (travB (stencilEltR s) b) (travD a)+ Stencil2 s1 s2 tp f b1 a1 b2 a2 -> stencil2 uid aenv s1 s2 tp (travF2 f) (travB (stencilEltR s1) b1) (travD a1) (travB (stencilEltR s2) b2) (travD a2) -- Non-computation forms: sadness- Alet{} -> unexpectedError- Avar{} -> unexpectedError- Apply{} -> unexpectedError- Acond{} -> unexpectedError- Awhile{} -> unexpectedError- Atuple{} -> unexpectedError- Aprj{} -> unexpectedError- Use{} -> unexpectedError- Unit{} -> unexpectedError- Aforeign{} -> unexpectedError- Reshape{} -> unexpectedError+ Alet{} -> unexpectedError+ Avar{} -> unexpectedError+ Apply{} -> unexpectedError+ Acond{} -> unexpectedError+ Awhile{} -> unexpectedError+ Apair{} -> unexpectedError+ Anil -> unexpectedError+ Use{} -> unexpectedError+ Unit{} -> unexpectedError+ Aforeign{} -> unexpectedError+ Reshape{} -> unexpectedError - Replicate{} -> fusionError- Slice{} -> fusionError- ZipWith{} -> fusionError+ Replicate{} -> fusionError+ Slice{} -> fusionError+ ZipWith{} -> fusionError where -- code generation for delayed arrays- travD :: DelayedOpenAcc aenv (Array sh e) -> IRDelayed arch aenv (Array sh e)- travD Manifest{} = $internalError "llvmOfOpenAcc" "expected delayed array"- travD Delayed{..} = IRDelayed (travE extentD) (travF1 indexD) (travF1 linearIndexD)+ travD :: DelayedOpenAcc aenv (Array sh e) -> MIRDelayed arch aenv (Array sh e)+ travD Delayed{..} = IRDelayedJust $ IRDelayed reprD (travE extentD) (travF1 indexD) (travF1 linearIndexD)+ travD (Manifest acc) = IRDelayedNothing $ arrayR acc -- scalar code generation- travF1 :: DelayedFun aenv (a -> b) -> IRFun1 arch aenv (a -> b)- travF1 f = llvmOfFun1 arch f aenv+ travF1 :: Fun aenv (a -> b) -> IRFun1 arch aenv (a -> b)+ travF1 f = llvmOfFun1 f aenv - travF2 :: DelayedFun aenv (a -> b -> c) -> IRFun2 arch aenv (a -> b -> c)- travF2 f = llvmOfFun2 arch f aenv+ travF2 :: Fun aenv (a -> b -> c) -> IRFun2 arch aenv (a -> b -> c)+ travF2 f = llvmOfFun2 f aenv - travPF :: DelayedFun aenv (e -> e -> e) -> IRPermuteFun arch aenv (e -> e -> e)- travPF f = llvmOfPermuteFun arch f aenv+ travPF :: Fun aenv (e -> e -> e) -> IRPermuteFun arch aenv (e -> e -> e)+ travPF f = llvmOfPermuteFun f aenv - travE :: DelayedExp aenv t -> IRExp arch aenv t- travE e = llvmOfOpenExp arch e Empty aenv+ travE :: Exp aenv t -> IRExp arch aenv t+ travE e = llvmOfOpenExp e Empty aenv - travB :: forall sh e.- PreBoundary DelayedOpenAcc aenv (Array sh e)+ travB :: TypeR e+ -> Boundary aenv (Array sh e) -> IRBoundary arch aenv (Array sh e)- travB Clamp = IRClamp- travB Mirror = IRMirror- travB Wrap = IRWrap- travB (Constant c) = IRConstant $ IR (constant (eltType (undefined::e)) c)- travB (Function f) = IRFunction $ travF1 f+ travB _ Clamp = IRClamp+ travB _ Mirror = IRMirror+ travB _ Wrap = IRWrap+ travB tp (Constant c) = IRConstant $ constant tp c+ travB _ (Function f) = IRFunction $ travF1 f -- sadness fusionError, unexpectedError :: error- fusionError = $internalError "llvmOfOpenAcc" $ "unexpected fusible material: " ++ showPreAccOp pacc- unexpectedError = $internalError "llvmOfOpenAcc" $ "unexpected array primitive: " ++ showPreAccOp pacc+ fusionError = internalError $ "unexpected fusible material: " ++ showPreAccOp pacc+ unexpectedError = internalError $ "unexpected array primitive: " ++ showPreAccOp pacc
src/Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs view
@@ -3,14 +3,16 @@ {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Arithmetic--- 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) --@@ -18,27 +20,13 @@ module Data.Array.Accelerate.LLVM.CodeGen.Arithmetic where --- standard/external libraries-import Prelude ( Eq, Num, Maybe(..), Either(..), ($), (==), (/), undefined, otherwise, flip, fromInteger )-import Control.Applicative-import Control.Monad-import Data.Bits ( finiteBitSize )-import Data.ByteString.Short ( ShortByteString )-import Data.Monoid-import Data.String-import Foreign.Storable ( sizeOf )-import Text.Printf-import qualified Data.Ord as Ord-import qualified Prelude as P---- accelerate+import Data.Array.Accelerate.AST ( PrimMaybe ) import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Tag+import Data.Array.Accelerate.Representation.Type --- accelerate-llvm import LLVM.AST.Type.Constant-import LLVM.AST.Type.Global+import LLVM.AST.Type.Function import LLVM.AST.Type.Instruction import LLVM.AST.Type.Instruction.Compare import LLVM.AST.Type.Name@@ -51,26 +39,40 @@ import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Type +import Control.Applicative+import Control.Monad+import Data.Bits ( finiteBitSize )+import Data.Bool ( Bool(..), otherwise )+import Data.ByteString.Short ( ShortByteString )+import Data.Constraint ( Dict(..) )+import Data.Monoid+import Data.String+import Foreign.Storable ( sizeOf )+import Prelude ( Eq, Num, Maybe(..), ($), (==), (/), undefined, flip, fromInteger )+import Text.Printf+import qualified Data.Ord as Ord+import qualified Prelude as P + -- Operations from Num -- ------------------- -add :: NumType a -> IR a -> IR a -> CodeGen (IR a)+add :: NumType a -> Operands a -> Operands a -> CodeGen arch (Operands a) add = binop Add -sub :: NumType a -> IR a -> IR a -> CodeGen (IR a)+sub :: NumType a -> Operands a -> Operands a -> CodeGen arch (Operands a) sub = binop Sub -mul :: NumType a -> IR a -> IR a -> CodeGen (IR a)+mul :: NumType a -> Operands a -> Operands a -> CodeGen arch (Operands a) mul = binop Mul -negate :: NumType a -> IR a -> CodeGen (IR a)+negate :: NumType a -> Operands a -> CodeGen arch (Operands a) negate t x = case t of IntegralNumType i | IntegralDict <- integralDict i -> mul t x (ir t (num t (P.negate 1))) FloatingNumType f | FloatingDict <- floatingDict f -> mul t x (ir t (num t (P.negate 1))) -abs :: forall a. NumType a -> IR a -> CodeGen (IR a)+abs :: forall arch a. NumType a -> Operands a -> CodeGen arch (Operands a) abs n x = case n of FloatingNumType f -> mathf "fabs" f x@@ -81,24 +83,24 @@ t = PrimType p in case finiteBitSize (undefined :: a) of- 64 -> call (Lam p (op n x) (Body t "llabs")) [NoUnwind, ReadNone]- _ -> call (Lam p (op n x) (Body t "abs")) [NoUnwind, ReadNone]+ 64 -> call (Lam p (op n x) (Body t Nothing "llabs")) [NoUnwind, ReadNone]+ _ -> call (Lam p (op n x) (Body t Nothing "abs")) [NoUnwind, ReadNone] -signum :: forall a. NumType a -> IR a -> CodeGen (IR a)+signum :: forall arch a. NumType a -> Operands a -> CodeGen arch (Operands a) signum t x = case t of IntegralNumType i | IntegralDict <- integralDict i , unsigned i -> do z <- neq (NumSingleType t) x (ir t (num t 0))- s <- instr (Ext boundedType (IntegralBoundedType i) (op scalarType z))+ s <- instr (BoolToInt i (unbool z)) return s -- -- http://graphics.stanford.edu/~seander/bithacks.html#CopyIntegerSign | IntegralDict <- integralDict i -> do let wsib = finiteBitSize (undefined::a) z <- neq (NumSingleType t) x (ir t (num t 0))- l <- instr (Ext boundedType (IntegralBoundedType i) (op scalarType z))+ l <- instr (BoolToInt i (unbool z)) r <- shiftRA i x (ir integralType (integral integralType (wsib P.- 1))) s <- bor i l r return s@@ -109,21 +111,21 @@ -> do l <- gt (NumSingleType t) x (ir f (floating f 0)) r <- lt (NumSingleType t) x (ir f (floating f 0))- u <- instr (IntToFP (Right nonNumType) f (op scalarType l))- v <- instr (IntToFP (Right nonNumType) f (op scalarType r))+ u <- instr (BoolToFP f (unbool l))+ v <- instr (BoolToFP f (unbool r)) s <- sub t u v return s -- Operations from Integral and Bits -- --------------------------------- -quot :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+quot :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a) quot = binop Quot -rem :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+rem :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a) rem = binop Rem -quotRem :: IntegralType a -> IR a -> IR a -> CodeGen (IR (a,a))+quotRem :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands (a,a)) quotRem t x y = do q <- quot t x y r <- rem t x y@@ -141,25 +143,25 @@ -- r <- sub (IntegralNumType t) x z return $ pair q r -idiv :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+idiv :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a) idiv i x y | unsigned i = quot i x y -- | IntegralDict <- integralDict i- , EltDict <- integralElt i+ , Dict <- integralElt i , zero <- ir i (integral i 0) , one <- ir i (integral i 1) , n <- IntegralNumType i , s <- NumSingleType n- = if gt s x zero `land` lt s y zero+ = if (tp, gt s x zero `land'` lt s y zero) then do a <- sub n x one b <- quot i a y c <- sub n b one return c else- if lt s x zero `land` gt s y zero+ if (tp, lt s x zero `land'` gt s y zero) then do a <- add n x one b <- quot i a y@@ -167,36 +169,40 @@ return c else quot i x y+ where+ tp = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType i -mod :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+mod :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a) mod i x y | unsigned i = rem i x y -- | IntegralDict <- integralDict i- , EltDict <- integralElt i+ , Dict <- integralElt i , zero <- ir i (integral i 0) , n <- IntegralNumType i , s <- NumSingleType n = do r <- rem i x y- if (gt s x zero `land` lt s y zero) `lor` (lt s x zero `land` gt s y zero)- then if neq s r zero+ if (tp, (gt s x zero `land'` lt s y zero) `lor'` (lt s x zero `land'` gt s y zero))+ then if (tp, neq s r zero) then add n r y else return zero else return r+ where+ tp = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType i -divMod :: IntegralType a -> IR a -> IR a -> CodeGen (IR (a,a))+divMod :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands (a,a)) divMod i x y | unsigned i = quotRem i x y -- | IntegralDict <- integralDict i- , EltDict <- integralElt i+ , Dict <- integralElt i , zero <- ir i (integral i 0) , one <- ir i (integral i 1) , n <- IntegralNumType i , s <- NumSingleType n- = if gt s x zero `land` lt s y zero+ = if (TupRpair tp tp, gt s x zero `land'` lt s y zero) then do a <- sub n x one b <- quotRem i a y@@ -205,7 +211,7 @@ e <- add n d one return $ pair c e else- if lt s x zero `land` gt s y zero+ if (TupRpair tp tp, lt s x zero `land'` gt s y zero) then do a <- add n x one b <- quotRem i a y@@ -215,43 +221,45 @@ return $ pair c e else quotRem i x y+ where+ tp = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType i -band :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+band :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a) band = binop BAnd -bor :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+bor :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a) bor = binop BOr -xor :: IntegralType a -> IR a -> IR a -> CodeGen (IR a)+xor :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a) xor = binop BXor -complement :: IntegralType a -> IR a -> CodeGen (IR a)+complement :: IntegralType a -> Operands a -> CodeGen arch (Operands a) complement t x | IntegralDict <- integralDict t = xor t x (ir t (integral t (P.negate 1))) -shiftL :: IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+shiftL :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a) shiftL t x i = do i' <- fromIntegral integralType (IntegralNumType t) i binop ShiftL t x i' -shiftR :: IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+shiftR :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a) shiftR t | signed t = shiftRA t | otherwise = shiftRL t -shiftRL :: IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+shiftRL :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a) shiftRL t x i = do i' <- fromIntegral integralType (IntegralNumType t) i r <- binop ShiftRL t x i' return r -shiftRA :: IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+shiftRA :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a) shiftRA t x i = do i' <- fromIntegral integralType (IntegralNumType t) i r <- binop ShiftRA t x i' return r -rotateL :: forall a. IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+rotateL :: forall arch a. IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a) rotateL t x i | IntegralDict <- integralDict t = do let wsib = finiteBitSize (undefined::a)@@ -263,42 +271,42 @@ c <- bor t a b return c -rotateR :: forall a. IntegralType a -> IR a -> IR Int -> CodeGen (IR a)+rotateR :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a) rotateR t x i = do i' <- negate numType i r <- rotateL t x i' return r -popCount :: forall a. IntegralType a -> IR a -> CodeGen (IR Int)+popCount :: forall arch a. IntegralType a -> Operands a -> CodeGen arch (Operands Int) popCount i x | IntegralDict <- integralDict i = do let ctpop = fromString $ printf "llvm.ctpop.i%d" (finiteBitSize (undefined::a)) p = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType i))) t = PrimType p --- c <- call (Lam p (op i x) (Body t ctpop)) [NoUnwind, ReadNone]+ c <- call (Lam p (op i x) (Body t Nothing ctpop)) [NoUnwind, ReadNone] r <- fromIntegral i numType c return r -countLeadingZeros :: forall a. IntegralType a -> IR a -> CodeGen (IR Int)+countLeadingZeros :: forall arch a. IntegralType a -> Operands a -> CodeGen arch (Operands Int) countLeadingZeros i x | IntegralDict <- integralDict i = do let clz = fromString $ printf "llvm.ctlz.i%d" (finiteBitSize (undefined::a)) p = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType i))) t = PrimType p --- c <- call (Lam p (op i x) (Lam primType (nonnum nonNumType False) (Body t clz))) [NoUnwind, ReadNone]+ c <- call (Lam p (op i x) (Lam primType (boolean False) (Body t Nothing clz))) [NoUnwind, ReadNone] r <- fromIntegral i numType c return r -countTrailingZeros :: forall a. IntegralType a -> IR a -> CodeGen (IR Int)+countTrailingZeros :: forall arch a. IntegralType a -> Operands a -> CodeGen arch (Operands Int) countTrailingZeros i x | IntegralDict <- integralDict i = do let clz = fromString $ printf "llvm.cttz.i%d" (finiteBitSize (undefined::a)) p = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType i))) t = PrimType p --- c <- call (Lam p (op i x) (Lam primType (nonnum nonNumType False) (Body t clz))) [NoUnwind, ReadNone]+ c <- call (Lam p (op i x) (Lam primType (boolean False) (Body t Nothing clz))) [NoUnwind, ReadNone] r <- fromIntegral i numType c return r @@ -306,64 +314,64 @@ -- Operators from Fractional and Floating -- -------------------------------------- -fdiv :: FloatingType a -> IR a -> IR a -> CodeGen (IR a)+fdiv :: FloatingType a -> Operands a -> Operands a -> CodeGen arch (Operands a) fdiv = binop Div -recip :: FloatingType a -> IR a -> CodeGen (IR a)+recip :: FloatingType a -> Operands a -> CodeGen arch (Operands a) recip t x | FloatingDict <- floatingDict t = fdiv t (ir t (floating t 1)) x -sin :: FloatingType a -> IR a -> CodeGen (IR a)+sin :: FloatingType a -> Operands a -> CodeGen arch (Operands a) sin = mathf "sin" -cos :: FloatingType a -> IR a -> CodeGen (IR a)+cos :: FloatingType a -> Operands a -> CodeGen arch (Operands a) cos = mathf "cos" -tan :: FloatingType a -> IR a -> CodeGen (IR a)+tan :: FloatingType a -> Operands a -> CodeGen arch (Operands a) tan = mathf "tan" -sinh :: FloatingType a -> IR a -> CodeGen (IR a)+sinh :: FloatingType a -> Operands a -> CodeGen arch (Operands a) sinh = mathf "sinh" -cosh :: FloatingType a -> IR a -> CodeGen (IR a)+cosh :: FloatingType a -> Operands a -> CodeGen arch (Operands a) cosh = mathf "cosh" -tanh :: FloatingType a -> IR a -> CodeGen (IR a)+tanh :: FloatingType a -> Operands a -> CodeGen arch (Operands a) tanh = mathf "tanh" -asin :: FloatingType a -> IR a -> CodeGen (IR a)+asin :: FloatingType a -> Operands a -> CodeGen arch (Operands a) asin = mathf "asin" -acos :: FloatingType a -> IR a -> CodeGen (IR a)+acos :: FloatingType a -> Operands a -> CodeGen arch (Operands a) acos = mathf "acos" -atan :: FloatingType a -> IR a -> CodeGen (IR a)+atan :: FloatingType a -> Operands a -> CodeGen arch (Operands a) atan = mathf "atan" -asinh :: FloatingType a -> IR a -> CodeGen (IR a)+asinh :: FloatingType a -> Operands a -> CodeGen arch (Operands a) asinh = mathf "asinh" -acosh :: FloatingType a -> IR a -> CodeGen (IR a)+acosh :: FloatingType a -> Operands a -> CodeGen arch (Operands a) acosh = mathf "acosh" -atanh :: FloatingType a -> IR a -> CodeGen (IR a)+atanh :: FloatingType a -> Operands a -> CodeGen arch (Operands a) atanh = mathf "atanh" -atan2 :: FloatingType a -> IR a -> IR a -> CodeGen (IR a)+atan2 :: FloatingType a -> Operands a -> Operands a -> CodeGen arch (Operands a) atan2 = mathf2 "atan2" -exp :: FloatingType a -> IR a -> CodeGen (IR a)+exp :: FloatingType a -> Operands a -> CodeGen arch (Operands a) exp = mathf "exp" -fpow :: FloatingType a -> IR a -> IR a -> CodeGen (IR a)+fpow :: FloatingType a -> Operands a -> Operands a -> CodeGen arch (Operands a) fpow = mathf2 "pow" -sqrt :: FloatingType a -> IR a -> CodeGen (IR a)+sqrt :: FloatingType a -> Operands a -> CodeGen arch (Operands a) sqrt = mathf "sqrt" -log :: FloatingType a -> IR a -> CodeGen (IR a)+log :: FloatingType a -> Operands a -> CodeGen arch (Operands a) log = mathf "log" -logBase :: forall a. FloatingType a -> IR a -> IR a -> CodeGen (IR a)+logBase :: forall arch a. FloatingType a -> Operands a -> Operands a -> CodeGen arch (Operands a) logBase t x@(op t -> base) y | FloatingDict <- floatingDict t = logBase' where match :: Eq t => Operand t -> Operand t -> Bool@@ -371,7 +379,7 @@ (ConstantOperand (ScalarConstant _ v)) = u == v match _ _ = False - logBase' :: (Num a, Eq a) => CodeGen (IR a)+ logBase' :: (Num a, Eq a) => CodeGen arch (Operands a) logBase' | match base (floating t 2) = mathf "log2" t y | match base (floating t 10) = mathf "log10" t y | otherwise@@ -383,32 +391,38 @@ -- Operators from RealFloat -- ------------------------ -isNaN :: FloatingType a -> IR a -> CodeGen (IR Bool)-isNaN f (op f -> x) = instr (FCmp f UNO x x)+isNaN :: FloatingType a -> Operands a -> CodeGen arch (Operands Bool)+isNaN f (op f -> x) = instr (IsNaN f x) -isInfinite :: FloatingType a -> IR a -> CodeGen (IR Bool)-isInfinite f x | FloatingDict <- floatingDict f = do- y <- mathf "fabs" f x- instr (FCmp f OEQ (op f y) (floating f (1/0)))+isInfinite :: forall arch a. FloatingType a -> Operands a -> CodeGen arch (Operands Bool)+isInfinite f x = do+ x' <- abs n x+ eq (NumSingleType n) infinity x'+ where+ n :: NumType a+ n = FloatingNumType f + infinity :: Operands a+ infinity | FloatingDict <- floatingDict f = ir f (floating f (1/0)) + -- Operators from RealFrac -- ----------------------- -truncate :: FloatingType a -> IntegralType b -> IR a -> CodeGen (IR b)+truncate :: FloatingType a -> IntegralType b -> Operands a -> CodeGen arch (Operands b) truncate tf ti (op tf -> x) = instr (FPToInt tf ti x) -round :: FloatingType a -> IntegralType b -> IR a -> CodeGen (IR b)+round :: FloatingType a -> IntegralType b -> Operands a -> CodeGen arch (Operands b) round tf ti x = do i <- mathf "round" tf x truncate tf ti i -floor :: FloatingType a -> IntegralType b -> IR a -> CodeGen (IR b)+floor :: FloatingType a -> IntegralType b -> Operands a -> CodeGen arch (Operands b) floor tf ti x = do i <- mathf "floor" tf x truncate tf ti i -ceiling :: FloatingType a -> IntegralType b -> IR a -> CodeGen (IR b)+ceiling :: FloatingType a -> IntegralType b -> Operands a -> CodeGen arch (Operands b) ceiling tf ti x = do i <- mathf "ceil" tf x truncate tf ti i@@ -417,93 +431,77 @@ -- Relational and Equality operators -- --------------------------------- -cmp :: Ordering -> SingleType a -> IR a -> IR a -> CodeGen (IR Bool)+cmp :: Ordering -> SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool) cmp p dict (op dict -> x) (op dict -> y) = instr (Cmp dict p x y) -lt :: SingleType a -> IR a -> IR a -> CodeGen (IR Bool)+lt :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool) lt = cmp LT -gt :: SingleType a -> IR a -> IR a -> CodeGen (IR Bool)+gt :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool) gt = cmp GT -lte :: SingleType a -> IR a -> IR a -> CodeGen (IR Bool)+lte :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool) lte = cmp LE -gte :: SingleType a -> IR a -> IR a -> CodeGen (IR Bool)+gte :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool) gte = cmp GE -eq :: SingleType a -> IR a -> IR a -> CodeGen (IR Bool)+eq :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool) eq = cmp EQ -neq :: SingleType a -> IR a -> IR a -> CodeGen (IR Bool)+neq :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool) neq = cmp NE -max :: SingleType a -> IR a -> IR a -> CodeGen (IR a)+max :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands a) max ty x y | NumSingleType (FloatingNumType f) <- ty = mathf2 "fmax" f x y- | otherwise = do c <- op singleType <$> gte ty x y+ | otherwise = do c <- unbool <$> gte ty x y binop (flip Select c) ty x y -min :: SingleType a -> IR a -> IR a -> CodeGen (IR a)+min :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands a) min ty x y | NumSingleType (FloatingNumType f) <- ty = mathf2 "fmin" f x y- | otherwise = do c <- op singleType <$> lte ty x y+ | otherwise = do c <- unbool <$> lte ty x y binop (flip Select c) ty x y -- Logical operators -- -------------------land :: CodeGen (IR Bool) -> CodeGen (IR Bool) -> CodeGen (IR Bool)-land x y =- if x- then y- else return $ ir scalarType (scalar scalarType False)--lor :: CodeGen (IR Bool) -> CodeGen (IR Bool) -> CodeGen (IR Bool)-lor x y =- if x- then return $ ir scalarType (scalar scalarType True)- else y+--+-- Note that these implementations are strict in both arguments. The short+-- circuiting (&&) and (||) operators in the language are not evaluated+-- using these functions, but defined in terms of if-then-else.+--+land :: Operands Bool -> Operands Bool -> CodeGen arch (Operands Bool)+land (OP_Bool x) (OP_Bool y) = instr (LAnd x y) --- These implementations are strict in both arguments.-land' :: IR Bool -> IR Bool -> CodeGen (IR Bool)-land' (op scalarType -> x) (op scalarType -> y)- = instr (LAnd x y)+lor :: Operands Bool -> Operands Bool -> CodeGen arch (Operands Bool)+lor (OP_Bool x) (OP_Bool y) = instr (LOr x y) -lor' :: IR Bool -> IR Bool -> CodeGen (IR Bool)-lor' (op scalarType -> x) (op scalarType -> y)- = instr (LOr x y)+lnot :: Operands Bool -> CodeGen arch (Operands Bool)+lnot (OP_Bool x) = instr (LNot x) -lnot :: IR Bool -> CodeGen (IR Bool)-lnot (op scalarType -> x) = instr (LNot x)+-- Utilities for implementing bounds checks+land' :: CodeGen arch (Operands Bool) -> CodeGen arch (Operands Bool) -> CodeGen arch (Operands Bool)+land' x y = do+ a <- x+ b <- y+ land a b +lor' :: CodeGen arch (Operands Bool) -> CodeGen arch (Operands Bool) -> CodeGen arch (Operands Bool)+lor' x y = do+ a <- x+ b <- y+ lor a b -- Type conversions -- ---------------- -ord :: IR Char -> CodeGen (IR Int)-ord (op scalarType -> x) =- case finiteBitSize (undefined :: Int) of- 32 -> instr (BitCast scalarType x)- 64 -> instr (Trunc boundedType boundedType x)- _ -> $internalError "ord" "I don't know what architecture I am"--chr :: IR Int -> CodeGen (IR Char)-chr (op integralType -> x) =- case finiteBitSize (undefined :: Int) of- 32 -> instr (BitCast scalarType x)- 64 -> instr (Ext boundedType boundedType x)- _ -> $internalError "chr" "I don't know what architecture I am"--boolToInt :: IR Bool -> CodeGen (IR Int)-boolToInt x = instr (Ext boundedType boundedType (op scalarType x))--fromIntegral :: forall a b. IntegralType a -> NumType b -> IR a -> CodeGen (IR b)+fromIntegral :: forall arch a b. IntegralType a -> NumType b -> Operands a -> CodeGen arch (Operands b) fromIntegral i1 n (op i1 -> x) = case n of FloatingNumType f- -> instr (IntToFP (Left i1) f x)+ -> instr (IntToFP i1 f x) IntegralNumType (i2 :: IntegralType b) | IntegralDict <- integralDict i1@@ -517,11 +515,11 @@ Ord.GT -> instr (Trunc (IntegralBoundedType i1) (IntegralBoundedType i2) x) Ord.LT -> instr (Ext (IntegralBoundedType i1) (IntegralBoundedType i2) x) -toFloating :: forall a b. NumType a -> FloatingType b -> IR a -> CodeGen (IR b)+toFloating :: forall arch a b. NumType a -> FloatingType b -> Operands a -> CodeGen arch (Operands b) toFloating n1 f2 (op n1 -> x) = case n1 of IntegralNumType i1- -> instr (IntToFP (Left i1) f2 x)+ -> instr (IntToFP i1 f2 x) FloatingNumType (f1 :: FloatingType a) | FloatingDict <- floatingDict f1@@ -535,70 +533,83 @@ Ord.GT -> instr (FTrunc f1 f2 x) Ord.LT -> instr (FExt f1 f2 x) -bitcast :: ScalarType (EltRepr a) -> ScalarType (EltRepr b) -> IR a -> CodeGen (IR b)-bitcast ta tb (IR x) = IR <$> go ta tb x- where- go :: ScalarType a -> ScalarType b -> Operands a -> CodeGen (Operands b)- go ta' tb' x'- | Just Refl <- matchScalarType ta' tb' = return x'- | otherwise = ir' tb' <$> instr' (BitCast tb' (op' ta' x'))+bitcast :: ScalarType a -> ScalarType b -> Operands a -> CodeGen arch (Operands b)+bitcast ta tb x+ | Just Refl <- matchScalarType ta tb = return x+ | otherwise = instr (BitCast tb (op ta x)) -- Utility functions -- ----------------- -fst :: IR (a, b) -> IR a-fst (IR (OP_Pair (OP_Pair OP_Unit x) _)) = IR x+fst :: Operands (a, b) -> Operands a+fst (OP_Pair x _) = x -snd :: IR (a, b) -> IR b-snd (IR (OP_Pair _ y)) = IR y+snd :: Operands (a, b) -> Operands b+snd (OP_Pair _ y) = y -pair :: IR a -> IR b -> IR (a, b)-pair (IR x) (IR y) = IR $ OP_Pair (OP_Pair OP_Unit x) y+pair :: Operands a -> Operands b -> Operands (a, b)+pair x y = OP_Pair x y -unpair :: IR (a, b) -> (IR a, IR b)-unpair x = (fst x, snd x)+unpair :: Operands (a, b) -> (Operands a, Operands b)+unpair (OP_Pair x y) = (x, y) -uncurry :: (IR a -> IR b -> c) -> IR (a, b) -> c-uncurry f (unpair -> (x,y)) = f x y+uncurry :: (Operands a -> Operands b -> c) -> Operands (a, b) -> c+uncurry f (OP_Pair x y) = f x y +unbool :: Operands Bool -> Operand Bool+unbool (OP_Bool x) = x -binop :: IROP dict => (dict a -> Operand a -> Operand a -> Instruction a) -> dict a -> IR a -> IR a -> CodeGen (IR a)+binop :: IROP dict => (dict a -> Operand a -> Operand a -> Instruction a) -> dict a -> Operands a -> Operands a -> CodeGen arch (Operands a) binop f dict (op dict -> x) (op dict -> y) = instr (f dict x y) -fst3 :: IR (a, b, c) -> IR a-fst3 (IR (OP_Pair (OP_Pair (OP_Pair OP_Unit x) _) _)) = IR x+fst3 :: Operands (Tup3 a b c) -> Operands a+fst3 (OP_Pair (OP_Pair (OP_Pair OP_Unit x) _) _) = x -snd3 :: IR (a, b, c) -> IR b-snd3 (IR (OP_Pair (OP_Pair _ y) _)) = IR y+snd3 :: Operands (Tup3 a b c) -> Operands b+snd3 (OP_Pair (OP_Pair _ y) _) = y -thd3 :: IR (a, b, c) -> IR c-thd3 (IR (OP_Pair _ z)) = IR z+thd3 :: Operands (Tup3 a b c) -> Operands c+thd3 (OP_Pair _ z) = z -trip :: IR a -> IR b -> IR c -> IR (a, b, c)-trip (IR x) (IR y) (IR z) = IR $ OP_Pair (OP_Pair (OP_Pair OP_Unit x) y) z+trip :: Operands a -> Operands b -> Operands c -> Operands (Tup3 a b c)+trip x y z = OP_Pair (OP_Pair (OP_Pair OP_Unit x) y) z -untrip :: IR (a, b, c) -> (IR a, IR b, IR c)+untrip :: Operands (Tup3 a b c) -> (Operands a, Operands b, Operands c) untrip t = (fst3 t, snd3 t, thd3 t) -- | Lift a constant value into an constant in the intermediate representation. -- {-# INLINABLE lift #-}-lift :: IsScalar a => a -> IR a-lift x = ir scalarType (scalar scalarType x)+lift :: TypeR a -> a -> Operands a+lift tp v = constant tp v +{-# INLINE liftInt #-}+liftInt :: Int -> Operands Int+liftInt = lift $ TupRsingle scalarTypeInt +{-# INLINE liftInt32 #-}+liftInt32 :: Int32 -> Operands Int32+liftInt32 = lift $ TupRsingle scalarTypeInt32++{-# INLINE liftWord32 #-}+liftWord32 :: Word32 -> Operands Word32+liftWord32 = lift $ TupRsingle scalarTypeWord32++{-# INLINE liftBool #-}+liftBool :: Bool -> Operands Bool+liftBool x = OP_Bool (boolean x)+ -- | Standard if-then-else expression -- ifThenElse- :: Elt a- => CodeGen (IR Bool)- -> CodeGen (IR a)- -> CodeGen (IR a)- -> CodeGen (IR a)-ifThenElse test yes no = do+ :: (TypeR a, CodeGen arch (Operands Bool))+ -> CodeGen arch (Operands a)+ -> CodeGen arch (Operands a)+ -> CodeGen arch (Operands a)+ifThenElse (tp, test) yes no = do ifThen <- newBlock "if.then" ifElse <- newBlock "if.else" ifExit <- newBlock "if.exit"@@ -616,12 +627,52 @@ fb <- br ifExit setBlock ifExit- phi [(tv, tb), (fv, fb)]+ phi tp [(tv, tb), (fv, fb)] +caseof+ :: TypeR a+ -> CodeGen arch (Operands TAG)+ -> [(TAG, CodeGen arch (Operands a))]+ -> Maybe (CodeGen arch (Operands a))+ -> CodeGen arch (Operands a)+caseof tR tag xs x = do+ exit <- newBlock "switch.exit"+ def <- newBlock "switch.default"+ cases <- forM xs (\(t,e) -> (t,e,) <$> newBlock (printf "switch.l%d" t))++ _ <- beginBlock "switch.entry"+ p <- tag+ _ <- switch p def [(t,b) | (t,_,b) <- cases]++ -- Generate basic blocks for each equation+ vs <- forM cases $ \(_,body,label) -> do+ setBlock label+ r <- body+ b <- br exit+ return (r,b)++ -- Basic block for the default case+ v <- do+ setBlock def+ r <- case x of+ Nothing ->+ let go :: TypeR a -> Operands a+ go TupRunit = OP_Unit+ go (TupRsingle t) = ir t (undef t)+ go (TupRpair a b) = OP_Pair (go a) (go b)+ in return (go tR)+ Just default_ -> default_+ b <- br exit+ return (r,b)++ setBlock exit+ phi tR (v:vs)++ -- Execute the body only if the first argument evaluates to True ---when :: CodeGen (IR Bool) -> CodeGen () -> CodeGen ()+when :: CodeGen arch (Operands Bool) -> CodeGen arch () -> CodeGen arch () when test doit = do body <- newBlock "when.body" exit <- newBlock "when.exit"@@ -638,7 +689,7 @@ -- Execute the body only if the first argument evaluates to False ---unless :: CodeGen (IR Bool) -> CodeGen () -> CodeGen ()+unless :: CodeGen arch (Operands Bool) -> CodeGen arch () -> CodeGen arch () unless test doit = do body <- newBlock "unless.body" exit <- newBlock "unless.exit"@@ -661,32 +712,36 @@ -- -- TLM: We should really be able to construct functions of any arity. ---mathf :: ShortByteString -> FloatingType t -> IR t -> CodeGen (IR t)+mathf :: ShortByteString -> FloatingType t -> Operands t -> CodeGen arch (Operands t) mathf n f (op f -> x) = do let s = ScalarPrimType (SingleScalarType (NumSingleType (FloatingNumType f))) t = PrimType s -- name <- lm f n- r <- call (Lam s x (Body t name)) [NoUnwind, ReadOnly]+ r <- call (Lam s x (Body t Nothing name)) [NoUnwind, ReadOnly] return r -mathf2 :: ShortByteString -> FloatingType t -> IR t -> IR t -> CodeGen (IR t)+mathf2 :: ShortByteString -> FloatingType t -> Operands t -> Operands t -> CodeGen arch (Operands t) mathf2 n f (op f -> x) (op f -> y) = do let s = ScalarPrimType (SingleScalarType (NumSingleType (FloatingNumType f))) t = PrimType s -- name <- lm f n- r <- call (Lam s x (Lam s y (Body t name))) [NoUnwind, ReadOnly]+ r <- call (Lam s x (Lam s y (Body t Nothing name))) [NoUnwind, ReadOnly] return r -lm :: FloatingType t -> ShortByteString -> CodeGen Label+lm :: FloatingType t -> ShortByteString -> CodeGen arch Label lm t n = intrinsic $ case t of TypeHalf{} -> n<>"f" -- XXX: check TypeFloat{} -> n<>"f"- TypeCFloat{} -> n<>"f" TypeDouble{} -> n- TypeCDouble{} -> n++isJust :: Operands (PrimMaybe a) -> CodeGen arch (Operands Bool)+isJust (OP_Pair l _) = instr (IntToBool integralType (op integralType l))++fromJust :: Operands (PrimMaybe a) -> CodeGen arch (Operands a)+fromJust (OP_Pair _ (OP_Pair OP_Unit r)) = return r
src/Data/Array/Accelerate/LLVM/CodeGen/Array.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Array--- 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) --@@ -20,7 +21,8 @@ ) where import Control.Applicative-import Prelude hiding ( read )+import Prelude hiding ( read )+import Data.Bits import LLVM.AST.Type.AddrSpace import LLVM.AST.Type.Instruction@@ -28,54 +30,234 @@ import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation -import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Ptr import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.LLVM.CodeGen.Constant -- | Read a value from an array at the given index -- {-# INLINEABLE readArray #-}-readArray :: forall int sh e. IsIntegral int => IRArray (Array sh e) -> IR int -> CodeGen (IR e)-readArray (IRArray _ (IR adata) addrspace volatility) (op integralType -> ix) =- IR <$> readArrayData addrspace volatility ix (eltType (undefined::e)) adata+readArray+ :: IntegralType int+ -> IRArray (Array sh e)+ -> Operands int+ -> CodeGen arch (Operands e)+readArray int (IRArray (ArrayR _ tp) _ adata addrspace volatility) (op int -> ix) =+ readArrayData addrspace volatility int ix tp adata -readArrayData :: AddrSpace -> Volatility -> Operand int -> TupleType t -> Operands t -> CodeGen (Operands t)-readArrayData as v ix = read+readArrayData+ :: AddrSpace+ -> Volatility+ -> IntegralType int+ -> Operand int+ -> TypeR e+ -> Operands e+ -> CodeGen arch (Operands e)+readArrayData a v i ix = read where- read :: TupleType t -> Operands t -> CodeGen (Operands t)- read TypeRunit OP_Unit = return OP_Unit- read (TypeRpair t2 t1) (OP_Pair a2 a1) = OP_Pair <$> read t2 a2 <*> read t1 a1- read (TypeRscalar t) (asPtr as . op' t -> arr) = ir' t <$> readArrayPrim t v arr ix+ read :: TypeR e -> Operands e -> CodeGen arch (Operands e)+ read TupRunit OP_Unit = return OP_Unit+ read (TupRpair t2 t1) (OP_Pair a2 a1) = OP_Pair <$> read t2 a2 <*> read t1 a1+ read (TupRsingle e) (asPtr a . op e -> arr) = ir e <$> readArrayPrim a v e i arr ix -readArrayPrim :: ScalarType e -> Volatility -> Operand (Ptr e) -> Operand int -> CodeGen (Operand e)-readArrayPrim t v arr ix = do- p <- instr' $ GetElementPtr arr [ix]- x <- instr' $ Load t v p+readArrayPrim+ :: AddrSpace+ -> Volatility+ -> ScalarType e+ -> IntegralType int+ -> Operand (Ptr e)+ -> Operand int+ -> CodeGen arch (Operand e)+readArrayPrim a v e i arr ix = do+ p <- getElementPtr a e i arr ix+ x <- load a e v p return x -- | Write a value into an array at the given index -- {-# INLINEABLE writeArray #-}-writeArray :: forall int sh e. IsIntegral int => IRArray (Array sh e) -> IR int -> IR e -> CodeGen ()-writeArray (IRArray _ (IR adata) addrspace volatility) (op integralType -> ix) (IR val) =- writeArrayData addrspace volatility ix (eltType (undefined::e)) adata val+writeArray+ :: IntegralType int+ -> IRArray (Array sh e)+ -> Operands int+ -> Operands e+ -> CodeGen arch ()+writeArray int (IRArray (ArrayR _ tp) _ adata addrspace volatility) (op int -> ix) val =+ writeArrayData addrspace volatility int ix tp adata val -writeArrayData :: AddrSpace -> Volatility -> Operand int -> TupleType t -> Operands t -> Operands t -> CodeGen ()-writeArrayData as v ix = write+writeArrayData+ :: AddrSpace+ -> Volatility+ -> IntegralType int+ -> Operand int+ -> TypeR e+ -> Operands e+ -> Operands e+ -> CodeGen arch ()+writeArrayData a v i ix = write where- write :: TupleType e -> Operands e -> Operands e -> CodeGen ()- write TypeRunit OP_Unit OP_Unit = return ()- write (TypeRpair t2 t1) (OP_Pair a2 a1) (OP_Pair v2 v1) = write t1 a1 v1 >> write t2 a2 v2- write (TypeRscalar t) (asPtr as . op' t -> arr) (op' t -> val) = writeArrayPrim v arr ix val+ write :: TypeR e -> Operands e -> Operands e -> CodeGen arch ()+ write TupRunit OP_Unit OP_Unit = return ()+ write (TupRpair t2 t1) (OP_Pair a2 a1) (OP_Pair v2 v1) = write t1 a1 v1 >> write t2 a2 v2+ write (TupRsingle e) (asPtr a . op e -> arr) (op e -> val) = writeArrayPrim a v e i arr ix val -writeArrayPrim :: Volatility -> Operand (Ptr e) -> Operand int -> Operand e -> CodeGen ()-writeArrayPrim v arr i x = do- p <- instr' $ GetElementPtr arr [i]- _ <- do_ $ Store v p x+writeArrayPrim+ :: AddrSpace+ -> Volatility+ -> ScalarType e+ -> IntegralType int+ -> Operand (Ptr e)+ -> Operand int+ -> Operand e+ -> CodeGen arch ()+writeArrayPrim a v e i arr ix x = do+ p <- getElementPtr a e i arr ix+ _ <- store a v e p x return ()+++-- | A wrapper around the GetElementPtr instruction, which correctly+-- computes the pointer offset for non-power-of-two SIMD types+--+getElementPtr+ :: AddrSpace+ -> ScalarType e+ -> IntegralType int+ -> Operand (Ptr e)+ -> Operand int+ -> CodeGen arch (Operand (Ptr e))+getElementPtr _ SingleScalarType{} _ arr ix = instr' $ GetElementPtr arr [ix]+getElementPtr a (VectorScalarType v) i arr ix+ | VectorType n _ <- v+ , IntegralDict <- integralDict i+ = if popCount n == 1+ then instr' $ GetElementPtr arr [ix]+ else do+ -- Note the initial zero into to the GEP instruction. It is not+ -- really recommended to use GEP to index into vector elements, but+ -- is not forcefully disallowed (at this time)+ ix' <- instr' $ Mul (IntegralNumType i) ix (integral i (fromIntegral n))+ p' <- instr' $ GetElementPtr arr [integral i 0, ix']+ p <- instr' $ PtrCast (PtrPrimType (ScalarPrimType (VectorScalarType v)) a) p'+ return p+++-- | A wrapper around the Load instruction, which splits non-power-of-two+-- SIMD types into a sequence of smaller reads.+--+-- Note: [Non-power-of-two loads and stores]+--+-- Splitting this operation a sequence of smaller power-of-two stores does+-- not work because those instructions may (will) violate alignment+-- restrictions, causing a general protection fault. So, we simply+-- implement those stores as a sequence of stores for each individual+-- element.+--+-- We could do runtime checks for what the pointer alignment is and perform+-- a vector store when we align on the right boundary, but I'm not sure the+-- extra complexity is worth it.+--+load :: AddrSpace+ -> ScalarType e+ -> Volatility+ -> Operand (Ptr e)+ -> CodeGen arch (Operand e)+load addrspace e v p+ | SingleScalarType{} <- e = instr' $ Load e v p+ | VectorScalarType s <- e+ , VectorType n base <- s+ , m <- fromIntegral n+ = if popCount m == 1+ then instr' $ Load e v p+ else do+ p' <- instr' $ PtrCast (PtrPrimType (ScalarPrimType (SingleScalarType base)) addrspace) p+ --+ let go i w+ | i >= m = return w+ | otherwise = do+ q <- instr' $ GetElementPtr p' [integral integralType i]+ r <- instr' $ Load (SingleScalarType base) v q+ w' <- instr' $ InsertElement i w r+ go (i+1) w'+ --+ go 0 (undef e)+++-- | A wrapper around the Store instruction, which splits non-power-of-two+-- SIMD types into a sequence of smaller writes.+--+-- See: [Non-power-of-two loads and stores]+--+store :: AddrSpace+ -> Volatility+ -> ScalarType e+ -> Operand (Ptr e)+ -> Operand e+ -> CodeGen arch ()+store addrspace volatility e p v+ | SingleScalarType{} <- e = do_ $ Store volatility p v+ | VectorScalarType s <- e+ , VectorType n base <- s+ , m <- fromIntegral n+ = if popCount m == 1+ then do_ $ Store volatility p v+ else do+ p' <- instr' $ PtrCast (PtrPrimType (ScalarPrimType (SingleScalarType base)) addrspace) p+ --+ let go i+ | i >= m = return ()+ | otherwise = do+ x <- instr' $ ExtractElement i v+ q <- instr' $ GetElementPtr p' [integral integralType i]+ _ <- instr' $ Store volatility q x+ go (i+1)+ go 0++{--+ let+ go :: forall arch n t. SingleType t -> Int32 -> Operand (Ptr t) -> Operand (Vec n t) -> CodeGen arch ()+ go t offset ptr' val'+ | offset >= size = return ()+ | otherwise = do+ let remaining = size - offset+ this = setBit 0 (finiteBitSize remaining - countLeadingZeros remaining - 1)++ vec' = VectorType (fromIntegral this) t+ ptr_vec' = PtrPrimType (ScalarPrimType (VectorScalarType vec')) addrspace++ repack :: Int32 -> Operand (Vec m t) -> CodeGen arch (Operand (Vec m t))+ repack j u+ | j >= this = return u+ | otherwise = do+ x <- instr' $ ExtractElement (offset + j) val'+ v <- instr' $ InsertElement j u x+ repack (j+1) v++ if remaining == 1+ then do+ x <- instr' $ ExtractElement offset val'+ _ <- instr' $ Store volatility ptr' x+ return ()++ else do+ v <- repack 0 $ undef (VectorScalarType vec')+ p <- instr' $ PtrCast ptr_vec' ptr'+ _ <- instr' $ Store volatility p v++ q <- instr' $ GetElementPtr ptr' [integral integralType this]+ go t (offset + this) q val'++ ptr' <- instr' $ PtrCast (PtrPrimType (ScalarPrimType (SingleScalarType base)) addrspace) ptr+ go base 0 ptr' val++ where+ VectorType (fromIntegral -> size) base = vec+--}
src/Data/Array/Accelerate/LLVM/CodeGen/Base.hs view
@@ -1,13 +1,16 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.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) --@@ -21,10 +24,11 @@ -- Arrays irArray, mutableArray,+ delayedArray, -- Functions & parameters call,- scalarParameter, ptrParameter,+ parameter, scalarParameter, ptrParameter, envParam, arrayParam, @@ -32,21 +36,24 @@ import LLVM.AST.Type.AddrSpace import LLVM.AST.Type.Constant+import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Function import LLVM.AST.Type.Global+import LLVM.AST.Type.InlineAssembly import LLVM.AST.Type.Instruction import LLVM.AST.Type.Instruction.Volatile import LLVM.AST.Type.Name import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation -import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Array.Sugar--import Data.Array.Accelerate.LLVM.CodeGen.Downcast import Data.Array.Accelerate.LLVM.CodeGen.Environment import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar+import Data.Array.Accelerate.Representation.Array ( Array, ArrayR(..) )+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import {-# SOURCE #-} Data.Array.Accelerate.LLVM.CodeGen.Exp import qualified LLVM.AST.Global as LLVM @@ -60,11 +67,11 @@ -- References -- ---------- -local :: ScalarType a -> Name a -> IR a-local t x = ir t (LocalReference (PrimType (ScalarPrimType t)) x)+local :: TypeR a -> Name a -> Operands a+local tp n = travTypeToOperands tp (\t i -> LocalReference (PrimType (ScalarPrimType t)) (rename n i)) -global :: ScalarType a -> Name a -> IR a-global t x = ir t (ConstantOperand (GlobalReference (PrimType (ScalarPrimType t)) x))+global :: TypeR a -> Name a -> Operands a+global tp n = travTypeToOperands tp (\t i -> ConstantOperand (GlobalReference (PrimType (ScalarPrimType t)) (rename n i))) -- Generating names for things@@ -73,88 +80,114 @@ -- | Names of array data components -- arrayName :: Name (Array sh e) -> Int -> Name e' -- for the i-th component of the ArrayData-arrayName (Name n) i = Name (n <> fromString (printf ".ad%d" i))-arrayName (UnName n) i = arrayName (fromString (show n)) i+arrayName (Name n) i = Name (n <> fromString (printf ".ad%d" i))+arrayName (UnName n) i = Name ( fromString (printf "%d.ad%d" n i)) -- | Names of shape components -- shapeName :: Name (Array sh e) -> Int -> Name sh' -- for the i-th component of the shape structure-shapeName (Name n) i = Name (n <> fromString (printf ".sh%d" i))-shapeName (UnName n) i = shapeName (fromString (show n)) i+shapeName (Name n) i = Name (n <> fromString (printf ".sh%d" i))+shapeName (UnName n) i = Name ( fromString (printf "%d.sh%d" n i)) +-- | Names combined with traversing+--+rename :: Name t -> Int -> Name t' -- for the i-th component of the named variable+rename (Name n) i = Name (n <> fromString (printf "%d" i))+rename (UnName n) i = Name ( fromString (printf "%d.%d" n i))++ -- | Names of array data elements -- {-# INLINEABLE irArray #-} irArray- :: forall sh e. (Shape sh, Elt e)- => Name (Array sh e)+ :: ArrayR (Array sh e)+ -> Name (Array sh e) -> IRArray (Array sh e)-irArray n- = IRArray (travTypeToIR (undefined::sh) (\t i -> LocalReference (PrimType (ScalarPrimType t)) (shapeName n i)))- (travTypeToIR (undefined::e) (\t i -> LocalReference (PrimType (ScalarPrimType t)) (arrayName n i)))+irArray repr@(ArrayR shr tp) n+ = IRArray repr+ (travTypeToOperands (shapeType shr) (\t i -> LocalReference (PrimType (ScalarPrimType t)) (shapeName n i)))+ (travTypeToOperands tp (\t i -> LocalReference (PrimType (ScalarPrimType t)) (arrayName n i))) defaultAddrSpace NonVolatile - -- | Generate typed local names for array data components as well as function -- parameters to bind those names -- {-# INLINEABLE mutableArray #-} mutableArray- :: forall sh e. (Shape sh, Elt e)- => Name (Array sh e)+ :: ArrayR (Array sh e)+ -> Name (Array sh e) -> (IRArray (Array sh e), [LLVM.Parameter])-mutableArray name =- ( irArray name- , arrayParam name )+mutableArray repr name =+ ( irArray repr name+ , arrayParam repr name ) +-- | Generate a delayed array representation for input arrays which come in+-- either delayed (fused) or manifest representation.+--+{-# INLINEABLE delayedArray #-}+delayedArray+ :: Name (Array sh e)+ -> MIRDelayed arch aenv (Array sh e)+ -> (IRDelayed arch aenv (Array sh e), [LLVM.Parameter])+delayedArray name = \case+ IRDelayedJust a -> (a, [])+ IRDelayedNothing repr ->+ let (arr, param) = mutableArray repr name+ in ( IRDelayed { delayedRepr = repr+ , delayedExtent = return (irArrayShape arr)+ , delayedIndex = IRFun1 (indexArray arr)+ , delayedLinearIndex = IRFun1 (linearIndexArray arr)+ }+ , param+ ) {-# INLINEABLE travTypeToList #-} travTypeToList- :: forall t a. Elt t- => t {- dummy -}+ :: forall tp a.+ TypeR tp -> (forall s. ScalarType s -> Int -> a) -> [a]-travTypeToList t f = snd $ go (eltType t) 0+travTypeToList tp f = snd $ go tp 0 where -- DANGER: [1] must traverse in the same order as [2]- go :: TupleType s -> Int -> (Int, [a])- go TypeRunit i = (i, [])- go (TypeRscalar t') i = (i+1, [f t' i])- go (TypeRpair t2 t1) i = let (i1, r1) = go t1 i- (i2, r2) = go t2 i1- in- (i2, r2 ++ r1)+ go :: TypeR s -> Int -> (Int, [a])+ go TupRunit i = (i, [])+ go (TupRsingle t') i = (i+1, [f t' i])+ go (TupRpair t2 t1) i = let (i1, r1) = go t1 i+ (i2, r2) = go t2 i1+ in+ (i2, r2 ++ r1) -travTypeToIR- :: Elt t- => t {- dummy -}+{-# INLINEABLE travTypeToOperands #-}+travTypeToOperands+ :: TypeR t -> (forall s. ScalarType s -> Int -> Operand s)- -> IR t-travTypeToIR t f = IR . snd $ go (eltType t) 0+ -> Operands t+travTypeToOperands tp f = snd $ go tp 0 where -- DANGER: [2] must traverse in the same order as [1]- go :: TupleType s -> Int -> (Int, Operands s)- go TypeRunit i = (i, OP_Unit)- go (TypeRscalar t') i = (i+1, ir' t' $ f t' i)- go (TypeRpair t2 t1) i = let (i1, r1) = go t1 i- (i2, r2) = go t2 i1- in- (i2, OP_Pair r2 r1)+ go :: TypeR s -> Int -> (Int, Operands s)+ go TupRunit i = (i, OP_Unit)+ go (TupRsingle t') i = (i+1, ir t' $ f t' i)+ go (TupRpair t2 t1) i = let (i1, r1) = go t1 i+ (i2, r2) = go t2 i1+ in+ (i2, OP_Pair r2 r1) --- travTypeToIRPtr+-- travTypeToOperandsPtr -- :: forall t. Elt t -- => AddrSpace -- -> t {- dummy -} -- -> (forall s. ScalarType s -> Int -> Operand (Ptr s))--- -> IR (Ptr t)--- travTypeToIRPtr as t f = IR . snd $ go (eltType t) 0+-- -> Operands (Ptr t)+-- travTypeToOperandsPtr as t f = snd $ go (eltType @t) 0 -- where -- -- DANGER: [2] must traverse in the same order as [1] -- -- go :: TypeR s -> Int -> (Int, Operands (Ptr s)) -- go :: TypeR (EltRepr s) -> Int -> (Int, Operands (EltRepr (Ptr s))) -- TLM: ugh ): -- go TypeRunit i = (i, OP_Unit)--- go (TypeRscalar t') i = (i+1, ir' (PtrPrimType t' as) $ f t' i)+-- go (TypeRscalar t') i = (i+1, ir (PtrPrimType t' as) $ f t' i) -- go (TypeRpair t2 t1) i = let (i1, r1) = go t1 i -- (i2, r2) = go t2 i1 -- in@@ -167,15 +200,22 @@ -- | Call a global function. The function declaration is inserted into the -- symbol table. ---call :: GlobalFunction args t -> [FunctionAttribute] -> CodeGen (IR t)+call :: GlobalFunction args t -> [FunctionAttribute] -> CodeGen arch (Operands t) call f attrs = do let decl = (downcast f) { LLVM.functionAttributes = downcast attrs' } attrs' = map Right attrs+ --+ go :: GlobalFunction args t -> Function (Either InlineAssembly Label) args t+ go (Body t k l) = Body t k (Right l)+ go (Lam t x l) = Lam t x (go l) -- declare decl- instr (Call f attrs')+ instr (Call (go f) attrs') +parameter :: TypeR t -> Name t -> [LLVM.Parameter]+parameter tp n = travTypeToList tp (\s i -> scalarParameter s (rename n i))+ scalarParameter :: ScalarType t -> Name t -> LLVM.Parameter scalarParameter t x = downcast (Parameter (ScalarPrimType t) x) @@ -188,21 +228,21 @@ -- accessed by the function. -- envParam :: forall aenv. Gamma aenv -> [LLVM.Parameter]-envParam aenv = concatMap (\(Label n, Idx' v) -> toParam v (Name n)) (IM.elems aenv)+envParam aenv = concatMap (\(Label n, Idx' repr _) -> toParam repr (Name n)) (IM.elems aenv) where- toParam :: forall sh e. (Shape sh, Elt e) => Idx aenv (Array sh e) -> Name (Array sh e) -> [LLVM.Parameter]- toParam _ name = arrayParam name+ toParam :: ArrayR (Array sh e) -> Name (Array sh e) -> [LLVM.Parameter]+ toParam repr name = arrayParam repr name -- | Generate function parameters for an Array with given base name. -- {-# INLINEABLE arrayParam #-} arrayParam- :: forall sh e. (Shape sh, Elt e)- => Name (Array sh e)+ :: ArrayR (Array sh e)+ -> Name (Array sh e) -> [LLVM.Parameter]-arrayParam name = ad ++ sh+arrayParam (ArrayR shr tp) name = ad ++ sh where- ad = travTypeToList (undefined :: e) (\t i -> ptrParameter t (arrayName name i))- sh = travTypeToList (undefined :: sh) (\t i -> scalarParameter t (shapeName name i))+ ad = travTypeToList tp (\t i -> ptrParameter t (arrayName name i))+ sh = travTypeToList (shapeType shr) (\t i -> scalarParameter t (shapeName name i))
src/Data/Array/Accelerate/LLVM/CodeGen/Constant.hs view
@@ -2,10 +2,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Constant--- 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) --@@ -13,21 +13,24 @@ module Data.Array.Accelerate.LLVM.CodeGen.Constant ( primConst,- constant, scalar, single, vector, num, integral, floating, nonnum,+ constant, scalar, single, vector, num, integral, floating, boolean, undef, ) where import Data.Array.Accelerate.AST ( PrimConst(..) )-import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type import LLVM.AST.Type.Constant import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation +import Data.Primitive.Vec + -- | Primitive constant values -- primConst :: PrimConst t -> t@@ -37,11 +40,9 @@ primMinBound :: BoundedType a -> a primMinBound (IntegralBoundedType t) | IntegralDict <- integralDict t = minBound-primMinBound (NonNumBoundedType t) | NonNumDict <- nonNumDict t = minBound primMaxBound :: BoundedType a -> a primMaxBound (IntegralBoundedType t) | IntegralDict <- integralDict t = maxBound-primMaxBound (NonNumBoundedType t) | NonNumDict <- nonNumDict t = maxBound primPi :: FloatingType a -> a primPi t | FloatingDict <- floatingDict t = pi@@ -49,10 +50,10 @@ -- | A constant value ---constant :: TupleType a -> a -> Operands a-constant TypeRunit () = OP_Unit-constant (TypeRpair ta tb) (a,b) = OP_Pair (constant ta a) (constant tb b)-constant (TypeRscalar t) a = ir' t (scalar t a)+constant :: TypeR a -> a -> Operands a+constant TupRunit () = OP_Unit+constant (TupRpair ta tb) (a,b) = OP_Pair (constant ta a) (constant tb b)+constant (TupRsingle t) a = ir t (scalar t a) scalar :: ScalarType a -> a -> Operand a scalar t = ConstantOperand . ScalarConstant t@@ -60,7 +61,7 @@ single :: SingleType a -> a -> Operand a single t = scalar (SingleScalarType t) -vector :: VectorType (v a) -> (v a) -> Operand (v a)+vector :: VectorType (Vec n a) -> (Vec n a) -> Operand (Vec n a) vector t = scalar (VectorScalarType t) num :: NumType a -> a -> Operand a@@ -72,8 +73,8 @@ floating :: FloatingType a -> a -> Operand a floating t = num (FloatingNumType t) -nonnum :: NonNumType a -> a -> Operand a-nonnum t = single (NonNumSingleType t)+boolean :: Bool -> Operand Bool+boolean = ConstantOperand . BooleanConstant -- | The string 'undef' can be used anywhere a constant is expected, and
− src/Data/Array/Accelerate/LLVM/CodeGen/Downcast.hs
@@ -1,549 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ParallelListComp #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Data.Array.Accelerate.LLVM.CodeGen.Downcast--- Copyright : [2015..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.CodeGen.Downcast (-- Downcast(..)--) where--import Prelude hiding ( Ordering(..), const )-import Data.Bits-import Foreign.C.Types--import Data.Array.Accelerate.AST ( tupleIdxToInt )-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Type--import Data.Array.Accelerate.LLVM.CodeGen.Type-import qualified Data.Array.Accelerate.LLVM.CodeGen.Constant as Const--import LLVM.AST.Type.Constant-import LLVM.AST.Type.Flags-import LLVM.AST.Type.Global-import LLVM.AST.Type.Instruction-import LLVM.AST.Type.Instruction.Atomic-import LLVM.AST.Type.Instruction.Compare-import LLVM.AST.Type.Instruction.Volatile-import LLVM.AST.Type.Metadata-import LLVM.AST.Type.Name-import LLVM.AST.Type.Operand-import LLVM.AST.Type.Representation-import LLVM.AST.Type.Terminator-import qualified LLVM.AST.Type.Instruction.RMW as RMW--import qualified LLVM.AST.Attribute as L-import qualified LLVM.AST.AddrSpace as L-import qualified LLVM.AST.CallingConvention as L-import qualified LLVM.AST.Constant as LC-import qualified LLVM.AST.Float as L-import qualified LLVM.AST.FloatingPointPredicate as FP-import qualified LLVM.AST.Global as L-import qualified LLVM.AST.Instruction as L-import qualified LLVM.AST.IntegerPredicate as IP-import qualified LLVM.AST.Name as L-import qualified LLVM.AST.Operand as LO-import qualified LLVM.AST.RMWOperation as LA-import qualified LLVM.AST.Type as L-#if MIN_VERSION_llvm_hs_pure(6,1,0)-#else-import qualified LLVM.AST.Type.Metadata as LM-#endif----- | Convert a value from our representation of the LLVM AST which uses--- Haskell-level types, into the llvm-general representation where types are--- represented only at the value level. We use the type-level information to--- generate the appropriate value-level types.----class Downcast typed untyped where- downcast :: typed -> untyped--instance Downcast a a' => Downcast [a] [a'] where- downcast = map downcast--instance Downcast a a' => Downcast (Maybe a) (Maybe a') where- downcast Nothing = Nothing- downcast (Just x) = Just (downcast x)--instance (Downcast a a', Downcast b b') => Downcast (a,b) (a',b') where- downcast (a,b) = (downcast a, downcast b)--instance (Downcast a a', Downcast b b') => Downcast (Either a b) (Either a' b') where- downcast (Left a) = Left (downcast a)- downcast (Right b) = Right (downcast b)----- LLVM.General.AST.Type.Flags--- -----------------------------nsw :: Bool-nsw = False--nuw :: Bool-nuw = False--fmf :: FastMathFlags-#if MIN_VERSION_llvm_hs_pure(6,0,0)-fmf = FastMathFlags- { allowReassoc = True- , noNaNs = True- , noInfs = True- , noSignedZeros = True- , allowReciprocal = True- , allowContract = True- , approxFunc = True- }-#else-fmf = UnsafeAlgebra -- allow everything-#endif--md :: L.InstructionMetadata-md = []---instance Downcast NUW Bool where- downcast NoUnsignedWrap = True- downcast UnsignedWrap = False--instance Downcast NSW Bool where- downcast NoSignedWrap = True- downcast SignedWrap = False--instance Downcast FastMathFlags L.FastMathFlags where- downcast = id----- LLVM.General.AST.Type.Name--- ----------------------------instance Downcast (Name a) L.Name where- downcast (Name s) = L.Name s- downcast (UnName n) = L.UnName n----- LLVM.General.AST.Type.Instruction--- -----------------------------------tailcall :: Maybe L.TailCallKind-tailcall = Nothing---- Instructions--instance Downcast (Instruction a) L.Instruction where- downcast (Add t x y) =- case t of- IntegralNumType{} -> L.Add nsw nuw (downcast x) (downcast y) md- FloatingNumType{} -> L.FAdd fmf (downcast x) (downcast y) md- downcast (Sub t x y) =- case t of- IntegralNumType{} -> L.Sub nsw nuw (downcast x) (downcast y) md- FloatingNumType{} -> L.FSub fmf (downcast x) (downcast y) md- downcast (Mul t x y) =- case t of- IntegralNumType{} -> L.Mul nsw nuw (downcast x) (downcast y) md- FloatingNumType{} -> L.FMul fmf (downcast x) (downcast y) md- downcast (Quot t x y)- | signed t = L.SDiv False (downcast x) (downcast y) md- | otherwise = L.UDiv False (downcast x) (downcast y) md- downcast (Rem t x y)- | signed t = L.SRem (downcast x) (downcast y) md- | otherwise = L.URem (downcast x) (downcast y) md- downcast (Div _ x y) = L.FDiv fmf (downcast x) (downcast y) md- downcast (ShiftL _ x i) = L.Shl nsw nuw (downcast x) (downcast i) md- downcast (ShiftRL _ x i) = L.LShr False (downcast x) (downcast i) md- downcast (ShiftRA _ x i) = L.AShr False (downcast x) (downcast i) md- downcast (BAnd _ x y) = L.And (downcast x) (downcast y) md- downcast (LAnd x y) = L.And (downcast x) (downcast y) md- downcast (BOr _ x y) = L.Or (downcast x) (downcast y) md- downcast (LOr x y) = L.Or (downcast x) (downcast y) md- downcast (BXor _ x y) = L.Xor (downcast x) (downcast y) md- downcast (LNot x) = L.Xor (downcast x) (downcast (Const.scalar scalarType True)) md-- downcast (ExtractElement v tix vec) = L.ExtractElement (downcast vec) (downcast tix') md- where- tix' :: Operand Int32- tix' = Const.integral integralType $ sizeOfVec v - fromIntegral (tupleIdxToInt tix) - 1-- sizeOfVec :: VectorType v -> Int32- sizeOfVec Vector2Type{} = 2- sizeOfVec Vector3Type{} = 3- sizeOfVec Vector4Type{} = 4- sizeOfVec Vector8Type{} = 8- sizeOfVec Vector16Type{} = 16-- downcast (InsertElement tix vec x) = L.InsertElement (downcast vec) (downcast x) (downcast tix') md- where- tix' :: Operand Int32- tix' = Const.integral integralType tix-- downcast (ExtractValue _ tix tup) = L.ExtractValue (downcast tup) [fromIntegral $ sizeOfTuple - tupleIdxToInt tix - 1] md- where- sizeOfTuple- | PrimType p <- typeOf tup- , StructPrimType t <- p- = go t- | otherwise- = $internalError "downcast" "unexpected operand type to ExtractValue"- --- go :: TupleType t -> Int- go (TypeRpair t _) = 1 + go t- go _ = 0-- downcast (Load _ v p) = L.Load (downcast v) (downcast p) Nothing 0 md- downcast (Store v p x) = L.Store (downcast v) (downcast p) (downcast x) Nothing 0 md- downcast (GetElementPtr n i) = L.GetElementPtr False (downcast n) (downcast i) md -- TLM: in bounds??- downcast (Fence a) = L.Fence (downcast a) md- downcast (CmpXchg _ v p x y a m) = L.CmpXchg (downcast v) (downcast p) (downcast x) (downcast y) (downcast a) (downcast m) md- downcast (AtomicRMW t v op p x a) = L.AtomicRMW (downcast v) (downcast (t,op)) (downcast p) (downcast x) (downcast a) md- downcast (Trunc _ t x) = L.Trunc (downcast x) (downcast t) md- downcast (FTrunc _ t x) = L.FPTrunc (downcast x) (downcast t) md- downcast (Ext t t' x)- | signed t = L.SExt (downcast x) (downcast t') md- | otherwise = L.ZExt (downcast x) (downcast t') md- downcast (FExt _ t x) = L.FPExt (downcast x) (downcast t) md- downcast (FPToInt _ t x)- | signed t = L.FPToSI (downcast x) (downcast t) md- | otherwise = L.FPToUI (downcast x) (downcast t) md- downcast (IntToFP t t' x)- | either signed signed t = L.SIToFP (downcast x) (downcast t') md- | otherwise = L.UIToFP (downcast x) (downcast t') md- downcast (BitCast t x) = L.BitCast (downcast x) (downcast t) md- downcast (PtrCast t x) = L.BitCast (downcast x) (downcast t) md- downcast (Phi t incoming) = L.Phi (downcast t) (downcast incoming) md- downcast (Select _ p x y) = L.Select (downcast p) (downcast x) (downcast y) md- downcast (Call f attrs) = L.Call tailcall L.C [] (downcast f) (downcast f) (downcast attrs) md- downcast (FCmp _ p x y) =- let- fp UNO = FP.UNO- fp OEQ = FP.OEQ- in- L.FCmp (fp p) (downcast x) (downcast y) md-- downcast (Cmp t p x y) =- let- fp EQ = FP.OEQ- fp NE = FP.ONE- fp LT = FP.OLT- fp LE = FP.OLE- fp GT = FP.OGT- fp GE = FP.OGE- --- si EQ = IP.EQ- si NE = IP.NE- si LT = IP.SLT- si LE = IP.SLE- si GT = IP.SGT- si GE = IP.SGE- --- ui EQ = IP.EQ- ui NE = IP.NE- ui LT = IP.ULT- ui LE = IP.ULE- ui GT = IP.UGT- ui GE = IP.UGE- in- case t of- NumSingleType FloatingNumType{} -> L.FCmp (fp p) (downcast x) (downcast y) md- _ | signed t -> L.ICmp (si p) (downcast x) (downcast y) md- | otherwise -> L.ICmp (ui p) (downcast x) (downcast y) md--instance Downcast Volatility Bool where- downcast Volatile = True- downcast NonVolatile = False--instance Downcast Synchronisation L.SynchronizationScope where- downcast SingleThread = L.SingleThread-#if MIN_VERSION_llvm_hs_pure(5,0,0)- downcast CrossThread = L.System-#else- downcast CrossThread = L.CrossThread-#endif--instance Downcast MemoryOrdering L.MemoryOrdering where- downcast Unordered = L.Unordered- downcast Monotonic = L.Monotonic- downcast Acquire = L.Acquire- downcast Release = L.Release- downcast AcquireRelease = L.AcquireRelease- downcast SequentiallyConsistent = L.SequentiallyConsistent--instance Downcast (IntegralType t, RMW.RMWOperation) LA.RMWOperation where- downcast (_, RMW.Exchange) = LA.Xchg- downcast (_, RMW.Add) = LA.Add- downcast (_, RMW.Sub) = LA.Sub- downcast (_, RMW.And) = LA.And- downcast (_, RMW.Or) = LA.Or- downcast (_, RMW.Xor) = LA.Xor- downcast (_, RMW.Nand) = LA.Nand- downcast (t, RMW.Min)- | signed t = LA.Min- | otherwise = LA.UMin- downcast (t, RMW.Max)- | signed t = LA.Max- | otherwise = LA.UMax--instance (Downcast (i a) i') => Downcast (Named i a) (L.Named i') where- downcast (x := op) = downcast x L.:= downcast op- downcast (Do op) = L.Do (downcast op)--instance Downcast a b => Downcast (L.Named a) (L.Named b) where- downcast (l L.:= r) = l L.:= downcast r- downcast (L.Do x) = L.Do (downcast x)----- LLVM.General.AST.Type.Constant--- --------------------------------instance Downcast (Constant a) LC.Constant where- downcast (UndefConstant t) = LC.Undef (downcast t)- downcast (GlobalReference t n) = LC.GlobalReference (downcast t) (downcast n)- downcast (ScalarConstant t x) = scalar t x- where- scalar :: ScalarType s -> s -> LC.Constant- scalar (SingleScalarType s) = single s- scalar (VectorScalarType s) = vector s-- single :: SingleType s -> s -> LC.Constant- single (NumSingleType s) = num s- single (NonNumSingleType s) = nonnum s-- vector :: VectorType s -> s -> LC.Constant- vector (Vector2Type s) (V2 a b) = LC.Vector [single s a, single s b]- vector (Vector3Type s) (V3 a b c) = LC.Vector [single s a, single s b, single s c]- vector (Vector4Type s) (V4 a b c d) = LC.Vector [single s a, single s b, single s c, single s d]- vector (Vector8Type s) (V8 a b c d e f g h) =- LC.Vector [ single s a, single s b, single s c, single s d- , single s e, single s f, single s g, single s h ]- vector (Vector16Type s) (V16 a b c d e f g h i j k l m n o p) =- LC.Vector [ single s a, single s b, single s c, single s d- , single s e, single s f, single s g, single s h- , single s i, single s j, single s k, single s l- , single s m, single s n, single s o, single s p ]-- num :: NumType s -> s -> LC.Constant- num (IntegralNumType s) v- | IntegralDict <- integralDict s- = LC.Int (L.typeBits (downcast s)) (fromIntegral v)- num (FloatingNumType s) v- = LC.Float- $ case s of- TypeFloat{} -> L.Single v- TypeDouble{} -> L.Double v- TypeCDouble{} | CDouble u <- v -> L.Double u- TypeCFloat{} | CFloat u <- v -> L.Single u- TypeHalf{} | Half (CUShort u) <- v -> L.Half u-- nonnum :: NonNumType s -> s -> LC.Constant- nonnum s v- = LC.Int (L.typeBits (downcast s))- $ case s of- TypeBool{} -> fromIntegral (fromEnum v)- TypeChar{} -> fromIntegral (fromEnum v)- TypeCChar{} -> fromIntegral (fromEnum v)- TypeCUChar{} -> fromIntegral (fromEnum v)- TypeCSChar{} -> fromIntegral (fromEnum v)----- LLVM.General.AST.Type.Operand--- -------------------------------instance Downcast (Operand a) LO.Operand where- downcast (LocalReference t n) = LO.LocalReference (downcast t) (downcast n)- downcast (ConstantOperand c) = LO.ConstantOperand (downcast c)----- LLVM.General.AST.Type.Metadata--- --------------------------------instance Downcast Metadata LO.Operand where- downcast = LO.MetadataOperand . downcast--instance Downcast Metadata LO.Metadata where- downcast (MetadataStringOperand s) = LO.MDString s- downcast (MetadataConstantOperand o) = LO.MDValue (LO.ConstantOperand o)- downcast (MetadataNodeOperand n) = LO.MDNode (downcast n)--#if MIN_VERSION_llvm_hs_pure(6,1,0)-instance Downcast MetadataNode (LO.MDRef LO.MDNode) where- downcast (MetadataNode n) = LO.MDInline (downcast n)- downcast (MetadataNodeReference r) = LO.MDRef r--instance Downcast [Maybe Metadata] LO.MDNode where- downcast = LO.MDTuple . map downcast-#else-instance Downcast MetadataNode LO.MetadataNode where- downcast (MetadataNode n) = LO.MetadataNode (downcast n)- downcast (MetadataNodeReference r) = LO.MetadataNodeReference r-#endif------ LLVM.General.AST.Type.Terminator--- ----------------------------------instance Downcast (Terminator a) L.Terminator where- downcast Ret = L.Ret Nothing md- downcast (RetVal x) = L.Ret (Just (downcast x)) md- downcast (Br l) = L.Br (downcast l) md- downcast (CondBr p t f) = L.CondBr (downcast p) (downcast t) (downcast f) md- downcast (Switch p d a) = L.Switch (downcast p) (downcast d) (downcast a) md----- LLVM.General.AST.Type.Name--- ----------------------------instance Downcast Label L.Name where- downcast (Label l) = L.Name l----- LLVM.General.AST.Type.Global--- ------------------------------instance Downcast (Parameter a) L.Parameter where- downcast (Parameter t x) = L.Parameter (downcast t) (downcast x) attrs- where- attrs | PtrPrimType{} <- t = [L.NoAlias, L.NoCapture] -- TLM: alignment?- | otherwise = []---- Function -> callable operands (for Call instruction)----instance Downcast (GlobalFunction args t) LO.CallableOperand where- downcast f- = let trav :: GlobalFunction args t -> ([L.Type], L.Type, L.Name)- trav (Body t n) = ([], downcast t, downcast n)- trav (Lam t _ l) = let (t',r, n) = trav l- in (downcast t : t', r, n)-- (args, result, name) = trav f- ty = L.PointerType (L.FunctionType result args False) (L.AddrSpace 0)- in- Right (LO.ConstantOperand (LC.GlobalReference ty name))--instance Downcast (GlobalFunction args t) [(LO.Operand, [L.ParameterAttribute])] where- downcast Body{} = []- downcast (Lam _ x l) = (downcast x, []) : downcast l---- Function -> global declaration----instance Downcast (GlobalFunction args t) L.Global where- downcast f- = let trav :: GlobalFunction args t -> ([L.Type], L.Type, L.Name)- trav (Body t n) = ([], downcast t, downcast n)- trav (Lam t _ l) = let (t',r, n) = trav l- in (downcast t : t', r, n)-- (args, result, name) = trav f- params = [ L.Parameter t (L.UnName i) [] | t <- args | i <- [0..] ]- in- L.functionDefaults { L.name = name- , L.returnType = result- , L.parameters = (params,False)- }--instance Downcast FunctionAttribute L.FunctionAttribute where- downcast NoReturn = L.NoReturn- downcast NoUnwind = L.NoUnwind- downcast ReadOnly = L.ReadOnly- downcast ReadNone = L.ReadNone- downcast AlwaysInline = L.AlwaysInline- downcast NoDuplicate = L.NoDuplicate- downcast Convergent = L.Convergent--instance Downcast GroupID L.GroupID where- downcast (GroupID n) = L.GroupID n----- LLVM.General.AST.Type.Representation--- --------------------------------------instance Downcast (Type a) L.Type where- downcast VoidType = L.VoidType- downcast (PrimType t) = downcast t--instance Downcast (PrimType a) L.Type where- downcast (ScalarPrimType t) = downcast t- downcast (PtrPrimType t a) = L.PointerType (downcast t) a- downcast (ArrayPrimType n t) = L.ArrayType n (downcast t)- downcast (StructPrimType t) = L.StructureType False (go t)- where- go :: TupleType t -> [L.Type]- go TypeRunit = []- go (TypeRscalar s) = [downcast s]- go (TypeRpair ta tb) = go ta ++ go tb---- Data.Array.Accelerate.Type--- ----------------------------instance Downcast (ScalarType a) L.Type where- downcast (SingleScalarType t) = downcast t- downcast (VectorScalarType t) = downcast t--instance Downcast (SingleType a) L.Type where- downcast (NumSingleType t) = downcast t- downcast (NonNumSingleType t) = downcast t--instance Downcast (VectorType a) L.Type where- downcast (Vector2Type t) = L.VectorType 2 (downcast t)- downcast (Vector3Type t) = L.VectorType 3 (downcast t)- downcast (Vector4Type t) = L.VectorType 4 (downcast t)- downcast (Vector8Type t) = L.VectorType 8 (downcast t)- downcast (Vector16Type t) = L.VectorType 16 (downcast t)--instance Downcast (BoundedType t) L.Type where- downcast (IntegralBoundedType t) = downcast t- downcast (NonNumBoundedType t) = downcast t--instance Downcast (NumType a) L.Type where- downcast (IntegralNumType t) = downcast t- downcast (FloatingNumType t) = downcast t--instance Downcast (IntegralType a) L.Type where- downcast TypeInt{} = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Int)) |] )- downcast TypeInt8{} = L.IntegerType 8- downcast TypeInt16{} = L.IntegerType 16- downcast TypeInt32{} = L.IntegerType 32- downcast TypeInt64{} = L.IntegerType 64- downcast TypeWord{} = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Word)) |] )- downcast TypeWord8{} = L.IntegerType 8- downcast TypeWord16{} = L.IntegerType 16- downcast TypeWord32{} = L.IntegerType 32- downcast TypeWord64{} = L.IntegerType 64- downcast TypeCShort{} = L.IntegerType 16- downcast TypeCUShort{} = L.IntegerType 16- downcast TypeCInt{} = L.IntegerType 32- downcast TypeCUInt{} = L.IntegerType 32- downcast TypeCLong{} = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: CLong)) |] )- downcast TypeCULong{} = L.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: CULong)) |] )- downcast TypeCLLong{} = L.IntegerType 64- downcast TypeCULLong{} = L.IntegerType 64--instance Downcast (FloatingType a) L.Type where- downcast TypeHalf{} = L.FloatingPointType L.HalfFP- downcast TypeFloat{} = L.FloatingPointType L.FloatFP- downcast TypeDouble{} = L.FloatingPointType L.DoubleFP- downcast TypeCFloat{} = L.FloatingPointType L.FloatFP- downcast TypeCDouble{} = L.FloatingPointType L.DoubleFP--instance Downcast (NonNumType a) L.Type where- downcast TypeBool{} = L.IntegerType 1- downcast TypeChar{} = L.IntegerType 32- downcast TypeCChar{} = L.IntegerType 8- downcast TypeCSChar{} = L.IntegerType 8- downcast TypeCUChar{} = L.IntegerType 8-
src/Data/Array/Accelerate/LLVM/CodeGen/Environment.hs view
@@ -1,13 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Environment--- 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) --@@ -20,15 +18,19 @@ import Text.Printf import qualified Data.IntMap as IM -import Data.Array.Accelerate.AST ( Idx(..), idxToInt )+import Data.Array.Accelerate.AST ( ArrayVar )+import Data.Array.Accelerate.AST.Idx ( Idx(..), idxToInt )+import Data.Array.Accelerate.AST.Var ( Var(..) ) import Data.Array.Accelerate.Error ( internalError )-import Data.Array.Accelerate.Array.Sugar ( Array, Shape, Elt )+import Data.Array.Accelerate.Representation.Array ( Array, ArrayR(..) ) import Data.Array.Accelerate.LLVM.CodeGen.IR import LLVM.AST.Type.Name +import GHC.Stack + -- Scalar environment -- ================== @@ -36,18 +38,15 @@ -- level as a heterogenous snoc list, and on the type level as nested tuples. -- data Val env where- Empty :: Val ()- Push :: Val env -> IR t -> Val (env, t)+ Empty :: Val ()+ Push :: Val env -> Operands t -> Val (env, t) -- | Projection of a value from the valuation environment using a de Bruijn -- index. ---prj :: Idx env t -> Val env -> IR t+prj :: Idx env t -> Val env -> Operands t prj ZeroIdx (Push _ v) = v prj (SuccIdx ix) (Push val _) = prj ix val-#if __GLASGOW_HASKELL__ < 800-prj _ _ = $internalError "prj" "inconsistent valuation"-#endif -- Array environment@@ -64,16 +63,16 @@ type Gamma aenv = IntMap (Label, Idx' aenv) data Idx' aenv where- Idx' :: (Shape sh, Elt e) => Idx aenv (Array sh e) -> Idx' aenv+ Idx' :: ArrayR (Array sh e) -> Idx aenv (Array sh e) -> Idx' aenv -- Projection of a value from the array environment using a de Bruijn index. -- This returns a pair of operands to access the shape and array data -- respectively. ---aprj :: Idx aenv t -> Gamma aenv -> Name t+aprj :: HasCallStack => Idx aenv t -> Gamma aenv -> Name t aprj ix aenv = case IM.lookup (idxToInt ix) aenv of- Nothing -> $internalError "aprj" "free variable not registered"+ Nothing -> internalError "free variable not registered" Just (Label n,_) -> Name n @@ -88,6 +87,6 @@ -- | A free variable ---freevar :: (Shape sh, Elt e) => Idx aenv (Array sh e) -> IntMap (Idx' aenv)-freevar ix = IM.singleton (idxToInt ix) (Idx' ix)+freevar :: ArrayVar aenv a -> IntMap (Idx' aenv)+freevar (Var repr@ArrayR{} ix) = IM.singleton (idxToInt ix) (Idx' repr ix)
src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs view
@@ -1,17 +1,18 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Exp--- 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) --@@ -19,26 +20,18 @@ module Data.Array.Accelerate.LLVM.CodeGen.Exp where -import Control.Applicative hiding ( Const )-import Control.Monad-import Data.Proxy-import Data.Typeable-import Text.Printf-import Prelude hiding ( exp, any )-import qualified Data.IntMap as IM--import Data.Array.Accelerate.AST hiding ( Val(..), prj )+import Data.Array.Accelerate.AST+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar hiding ( Foreign, toTuple, shape, intersect, union )-import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) ) import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Representation.Array ( Array, arrayRshape )+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Slice+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Representation.Vec import Data.Array.Accelerate.Type-import qualified Data.Array.Accelerate.Array.Sugar as A--import LLVM.AST.Type.Instruction-import LLVM.AST.Type.Operand+import qualified Data.Array.Accelerate.Sugar.Foreign as A import Data.Array.Accelerate.LLVM.CodeGen.Array import Data.Array.Accelerate.LLVM.CodeGen.Base@@ -47,510 +40,348 @@ import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar-import Data.Array.Accelerate.LLVM.CodeGen.Type hiding ( typeOf ) import Data.Array.Accelerate.LLVM.Foreign import qualified Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A import qualified Data.Array.Accelerate.LLVM.CodeGen.Loop as L +import Data.Primitive.Vec +import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Operand ( Operand )++import Control.Applicative hiding ( Const )+import Control.Monad+import Prelude hiding ( exp, any )+import qualified Data.IntMap as IM++import GHC.TypeNats++ -- Scalar expressions -- ================== {-# INLINEABLE llvmOfFun1 #-} llvmOfFun1- :: Foreign arch- => arch- -> DelayedFun aenv (a -> b)+ :: (HasCallStack, Foreign arch)+ => Fun aenv (a -> b) -> Gamma aenv -> IRFun1 arch aenv (a -> b)-llvmOfFun1 arch (Lam (Body body)) aenv = IRFun1 $ \x -> llvmOfOpenExp arch body (Empty `Push` x) aenv-llvmOfFun1 _ _ _ = $internalError "llvmOfFun1" "impossible evaluation"+llvmOfFun1 (Lam lhs (Body body)) aenv = IRFun1 $ \x -> llvmOfOpenExp body (Empty `pushE` (lhs, x)) aenv+llvmOfFun1 _ _ = internalError "impossible evaluation" {-# INLINEABLE llvmOfFun2 #-} llvmOfFun2- :: Foreign arch- => arch- -> DelayedFun aenv (a -> b -> c)+ :: (HasCallStack, Foreign arch)+ => Fun aenv (a -> b -> c) -> Gamma aenv -> IRFun2 arch aenv (a -> b -> c)-llvmOfFun2 arch (Lam (Lam (Body body))) aenv = IRFun2 $ \x y -> llvmOfOpenExp arch body (Empty `Push` x `Push` y) aenv-llvmOfFun2 _ _ _ = $internalError "llvmOfFun2" "impossible evaluation"+llvmOfFun2 (Lam lhs1 (Lam lhs2 (Body body))) aenv = IRFun2 $ \x y -> llvmOfOpenExp body (Empty `pushE` (lhs1, x) `pushE` (lhs2, y)) aenv+llvmOfFun2 _ _ = internalError "impossible evaluation" --- | Convert an open scalar expression into a sequence of LLVM IR instructions.+-- | Convert an open scalar expression into a sequence of LLVM Operands instructions. -- Code is generated in depth first order, and uses a monad to collect the -- sequence of instructions used to construct basic blocks. -- {-# INLINEABLE llvmOfOpenExp #-} llvmOfOpenExp- :: forall arch env aenv _t. Foreign arch- => arch- -> DelayedOpenExp env aenv _t+ :: forall arch env aenv _t. (HasCallStack, Foreign arch)+ => OpenExp env aenv _t -> Val env -> Gamma aenv -> IROpenExp arch env aenv _t-llvmOfOpenExp arch top env aenv = cvtE top+llvmOfOpenExp top env aenv = cvtE top where- cvtM :: DelayedOpenAcc aenv (Array sh e) -> IRManifest arch aenv (Array sh e)- cvtM (Manifest (Avar ix)) = IRManifest ix- cvtM _ = $internalError "llvmOfOpenExp" "expected manifest array variable" - cvtF1 :: DelayedOpenFun env aenv (a -> b) -> IROpenFun1 arch env aenv (a -> b)- cvtF1 (Lam (Body body)) = IRFun1 $ \x -> llvmOfOpenExp arch body (env `Push` x) aenv- cvtF1 _ = $internalError "cvtF1" "impossible evaluation"+ cvtF1 :: OpenFun env aenv (a -> b) -> IROpenFun1 arch env aenv (a -> b)+ cvtF1 (Lam lhs (Body body)) = IRFun1 $ \x -> llvmOfOpenExp body (env `pushE` (lhs, x)) aenv+ cvtF1 _ = internalError "impossible evaluation" - cvtE :: forall t. DelayedOpenExp env aenv t -> IROpenExp arch env aenv t+ cvtE :: forall t. OpenExp env aenv t -> IROpenExp arch env aenv t cvtE exp = case exp of- Let bnd body -> do x <- cvtE bnd- llvmOfOpenExp arch body (env `Push` x) aenv- Var ix -> return $ prj ix env- Const c -> return $ IR (constant (eltType (undefined::t)) c)- PrimConst c -> return $ IR (constant (eltType (undefined::t)) (fromElt (primConst c)))+ Let lhs bnd body -> do x <- cvtE bnd+ llvmOfOpenExp body (env `pushE` (lhs, x)) aenv+ Evar (Var _ ix) -> return $ prj ix env+ Const tp c -> return $ ir tp $ scalar tp c+ PrimConst c -> let tp = (SingleScalarType $ primConstType c)+ in return $ ir tp $ scalar tp $ primConst c PrimApp f x -> primFun f x- Undef -> return undefE- IndexNil -> return indexNil- IndexAny -> return indexAny- IndexCons sh sz -> indexCons <$> cvtE sh <*> cvtE sz- IndexHead ix -> indexHead <$> cvtE ix- IndexTail ix -> indexTail <$> cvtE ix- Prj ix tup -> prjT ix =<< cvtE tup- Tuple tup -> cvtT tup- Foreign asm f x -> foreignE asm f =<< cvtE x- Cond c t e -> A.ifThenElse (cvtE c) (cvtE t) (cvtE e)+ Undef tp -> return $ ir tp $ undef tp+ Nil -> return $ OP_Unit+ Pair e1 e2 -> join $ pair <$> cvtE e1 <*> cvtE e2+ VecPack vecr e -> vecPack vecr =<< cvtE e+ VecUnpack vecr e -> vecUnpack vecr =<< cvtE e+ Foreign tp asm f x -> foreignE tp asm f =<< cvtE x+ Case tag xs mx -> A.caseof (expType (snd (head xs))) (cvtE tag) [(t,cvtE e) | (t,e) <- xs] (fmap cvtE mx)+ Cond c t e -> cond (expType t) (cvtE c) (cvtE t) (cvtE e) IndexSlice slice slix sh -> indexSlice slice <$> cvtE slix <*> cvtE sh IndexFull slice slix sh -> indexFull slice <$> cvtE slix <*> cvtE sh- ToIndex sh ix -> join $ intOfIndex <$> cvtE sh <*> cvtE ix- FromIndex sh ix -> join $ indexOfInt <$> cvtE sh <*> cvtE ix- Index acc ix -> index (cvtM acc) =<< cvtE ix- LinearIndex acc ix -> linearIndex (cvtM acc) =<< cvtE ix- ShapeSize sh -> shapeSize =<< cvtE sh- Shape acc -> return $ shape (cvtM acc)- Intersect sh1 sh2 -> join $ intersect <$> cvtE sh1 <*> cvtE sh2- Union sh1 sh2 -> join $ union <$> cvtE sh1 <*> cvtE sh2- While c f x -> while (cvtF1 c) (cvtF1 f) (cvtE x)- Coerce x -> coerce =<< cvtE x-- indexNil :: IR Z- indexNil = IR (constant (eltType Z) (fromElt Z))-- indexAny :: forall sh. Shape sh => IR (Any sh)- indexAny = let any = Any :: Any sh- in IR (constant (eltType any) (fromElt any))-- undefE :: forall t. Elt t => IR t- undefE = IR $ go (eltType (undefined::t))- where- go :: TupleType s -> Operands s- go TypeRunit = OP_Unit- go (TypeRscalar t) = ir' t (undef t)- go (TypeRpair a b) = OP_Pair (go a) (go b)+ ToIndex shr sh ix -> join $ intOfIndex shr <$> cvtE sh <*> cvtE ix+ FromIndex shr sh ix -> join $ indexOfInt shr <$> cvtE sh <*> cvtE ix+ Index acc ix -> index acc =<< cvtE ix+ LinearIndex acc ix -> linearIndex acc =<< cvtE ix+ ShapeSize shr sh -> shapeSize shr =<< cvtE sh+ Shape acc -> return $ shape acc+ While c f x -> while (expType x) (cvtF1 c) (cvtF1 f) (cvtE x)+ Coerce t1 t2 x -> coerce t1 t2 =<< cvtE x - indexSlice :: SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)- -> IR slix- -> IR sh- -> IR sl- indexSlice slice (IR slix) (IR sh) = IR $ restrict slice slix sh- where- restrict :: SliceIndex slix sl co sh -> Operands slix -> Operands sh -> Operands sl- restrict SliceNil OP_Unit OP_Unit = OP_Unit- restrict (SliceAll sliceIdx) (OP_Pair slx OP_Unit) (OP_Pair sl sz) =- let sl' = restrict sliceIdx slx sl- in OP_Pair sl' sz- restrict (SliceFixed sliceIdx) (OP_Pair slx _i) (OP_Pair sl _sz) =- restrict sliceIdx slx sl+ indexSlice :: SliceIndex slix sl co sh -> Operands slix -> Operands sh -> Operands sl+ indexSlice SliceNil OP_Unit OP_Unit = OP_Unit+ indexSlice (SliceAll sliceIdx) (OP_Pair slx OP_Unit) (OP_Pair sl sz) =+ let sl' = indexSlice sliceIdx slx sl+ in OP_Pair sl' sz+ indexSlice (SliceFixed sliceIdx) (OP_Pair slx _i) (OP_Pair sl _sz) =+ indexSlice sliceIdx slx sl - indexFull :: SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)- -> IR slix- -> IR sl- -> IR sh- indexFull slice (IR slix) (IR sh) = IR $ extend slice slix sh- where- extend :: SliceIndex slix sl co sh -> Operands slix -> Operands sl -> Operands sh- extend SliceNil OP_Unit OP_Unit = OP_Unit- extend (SliceAll sliceIdx) (OP_Pair slx OP_Unit) (OP_Pair sl sz) =- let sh' = extend sliceIdx slx sl- in OP_Pair sh' sz- extend (SliceFixed sliceIdx) (OP_Pair slx sz) sl =- let sh' = extend sliceIdx slx sl- in OP_Pair sh' sz+ indexFull :: SliceIndex slix sl co sh -> Operands slix -> Operands sl -> Operands sh+ indexFull SliceNil OP_Unit OP_Unit = OP_Unit+ indexFull (SliceAll sliceIdx) (OP_Pair slx OP_Unit) (OP_Pair sl sz) =+ let sh' = indexFull sliceIdx slx sl+ in OP_Pair sh' sz+ indexFull (SliceFixed sliceIdx) (OP_Pair slx sz) sl =+ let sh' = indexFull sliceIdx slx sl+ in OP_Pair sh' sz - prjT :: forall t e. (Elt t, IsTuple t, Elt e) => TupleIdx (TupleRepr t) e -> IR t -> CodeGen (IR e)- prjT tix (IR tup) =- case eltType (undefined::t) of- TypeRscalar (VectorScalarType v) -> goV tix v tup- t -> goT tix t tup+ vecPack :: forall n single tuple. (HasCallStack, KnownNat n) => VecR n single tuple -> Operands tuple -> CodeGen arch (Operands (Vec n single))+ vecPack vecr tuple = ir tp <$> go vecr n tuple where- -- for unzipped tuples- goT :: TupleIdx s e -> TupleType t' -> Operands t' -> CodeGen (IR e)- goT (SuccTupIdx ix) (TypeRpair t _) (OP_Pair x _) = goT ix t x- goT ZeroTupIdx (TypeRpair _ t) (OP_Pair _ x)- | Just Refl <- matchTupleType t (eltType (undefined::e))- = return $ IR x- goT _ _ _- = $internalError "prjT/tup" "inconsistent valuation"-- -- for SIMD vectors- goV :: forall (v :: * -> *) a. TupleIdx (ProdRepr t) e -> VectorType (v a) -> Operands (v a) -> CodeGen (IR e)- goV vix v (op' v -> vec)- | Just Refl <- matchProdR (prod Proxy (undefined::t)) (vecProdR v)- , Just Refl <- matchVecT (eltType (undefined::e)) (vecElemT v)- = instr $ ExtractElement v vix vec- goV _ _ _- = $internalError "prjT/vec" "inconsistent valuation"-- matchVecT :: TupleType (EltRepr e) -> TupleType a -> Maybe (e :~: a)- matchVecT e v- | Just Refl <- matchTupleType e v = gcast Refl- | otherwise = Nothing-- vecElemT :: VectorType (v a) -> TupleType a- vecElemT (Vector2Type a) = TypeRscalar (SingleScalarType a)- vecElemT (Vector3Type a) = TypeRscalar (SingleScalarType a)- vecElemT (Vector4Type a) = TypeRscalar (SingleScalarType a)- vecElemT (Vector8Type a) = TypeRscalar (SingleScalarType a)- vecElemT (Vector16Type a) = TypeRscalar (SingleScalarType a)-- matchProdR :: ProdR Elt a -> ProdR Elt b -> Maybe (a :~: b)- matchProdR ProdRunit ProdRunit = Just Refl- matchProdR pa@(ProdRsnoc a) pb@(ProdRsnoc b)- | Just Refl <- matchProdR a b- , Just Refl <- matchTop pa pb- = Just Refl- where- matchTop :: forall ta tb a b. (Elt a, Elt b) => ProdR Elt (ta,a) -> ProdR Elt (tb,b) -> Maybe (a :~: b)- matchTop _ _- | Just Refl <- matchTupleType (eltType (undefined::a)) (eltType (undefined::b)) = gcast Refl- | otherwise = Nothing- matchProdR _ _- = Nothing+ go :: VecR n' single tuple' -> Int -> Operands tuple' -> CodeGen arch (Operand (Vec n single))+ go (VecRnil _) 0 OP_Unit = return $ undef $ VectorScalarType tp+ go (VecRnil _) _ OP_Unit = internalError "index mismatch"+ go (VecRsucc vecr') i (OP_Pair xs x) = do+ vec <- go vecr' (i - 1) xs+ instr' $ InsertElement (fromIntegral i - 1) vec (op singleTp x) - vecProdR :: VectorType v -> ProdR Elt (ProdRepr v)- vecProdR (Vector2Type e) | EltDict :: EltDict a <- singleElt e = prod Proxy (undefined::V2 a)- vecProdR (Vector3Type e) | EltDict :: EltDict a <- singleElt e = prod Proxy (undefined::V3 a)- vecProdR (Vector4Type e) | EltDict :: EltDict a <- singleElt e = prod Proxy (undefined::V4 a)- vecProdR (Vector8Type e) | EltDict :: EltDict a <- singleElt e = prod Proxy (undefined::V8 a)- vecProdR (Vector16Type e) | EltDict :: EltDict a <- singleElt e = prod Proxy (undefined::V16 a)+ singleTp :: SingleType single -- GHC 8.4 cannot infer this type for some reason+ tp@(VectorType n singleTp) = vecRvector vecr - cvtT :: forall t. (Elt t, IsTuple t) => Tuple (DelayedOpenExp env aenv) (TupleRepr t) -> CodeGen (IR t)- cvtT tup =- case eltType (undefined::t) of- TypeRscalar (VectorScalarType v) -> IR <$> goV v tup- t -> IR <$> goT t tup+ vecUnpack :: forall n single tuple. (HasCallStack, KnownNat n) => VecR n single tuple -> Operands (Vec n single) -> CodeGen arch (Operands tuple)+ vecUnpack vecr (OP_Vec vec) = go vecr n where- -- for unzipped tuples- goT :: TupleType t' -> Tuple (DelayedOpenExp env aenv) tup -> CodeGen (Operands t')- goT TypeRunit NilTup- = return OP_Unit- goT (TypeRpair ta tb) (SnocTup a (b :: DelayedOpenExp env aenv b))- -- We must assert that the reified type 'tb' of 'b' is actually- -- equivalent to the type of 'b'. This can not fail, but is necessary- -- because 'tb' observes the representation type of surface type 'b'.- | Just Refl <- matchTupleType tb (eltType (undefined::b))- = do a' <- goT ta a- IR b' <- cvtE b- return $ OP_Pair a' b'- goT _ _- = $internalError "cvtT/tup"- $ unlines [ "impossible evaluation"- , " possible solution: ensure that the 'EltRepr' and 'ProdRepr' instances of your data type are consistent." ]+ go :: VecR n' single tuple' -> Int -> CodeGen arch (Operands tuple')+ go (VecRnil _) 0 = return $ OP_Unit+ go (VecRnil _) _ = internalError "index mismatch"+ go (VecRsucc vecr') i = do+ xs <- go vecr' (i - 1)+ x <- instr' $ ExtractElement (fromIntegral i - 1) vec+ return $ OP_Pair xs (ir singleTp x) - -- for packed SIMD vectors- goV :: forall (v :: * -> *) a. VectorType (v a) -> Tuple (DelayedOpenExp env aenv) (TupleRepr t) -> CodeGen (Operands (v a))- goV v ts = ir' v . snd <$> pack ts- where- pack :: Tuple (DelayedOpenExp env aenv) tup -> CodeGen (Int32, Operand (v a))- pack NilTup- = return (0, undef (VectorScalarType v))- pack (SnocTup t x)- | Just Refl <- matchExpType x- = do- x' <- cvtE x- (i, vec) <- pack t- vec' <- instr' $ InsertElement i vec (op a x')- return (i+1, vec')- where- matchExpType :: forall s. Elt s => DelayedOpenExp env aenv s -> Maybe (s :~: a)- matchExpType _- | Just Refl <- matchTupleType (eltType (undefined::s)) (TypeRscalar (SingleScalarType a)) = gcast Refl- | otherwise = Nothing- pack _- = $internalError "cvtT/vec" "impossible evaluation"+ singleTp :: SingleType single -- GHC 8.4 cannot infer this type for some reason+ VectorType n singleTp = vecRvector vecr - a :: SingleType a- a = case v of- Vector2Type t -> t- Vector3Type t -> t- Vector4Type t -> t- Vector8Type t -> t- Vector16Type t -> t+ linearIndex :: ArrayVar aenv (Array sh e) -> Operands Int -> IROpenExp arch env aenv e+ linearIndex (Var repr v) = linearIndexArray (irArray repr (aprj v aenv)) - linearIndex :: (Shape sh, Elt e) => IRManifest arch aenv (Array sh e) -> IR Int -> CodeGen (IR e)- linearIndex (IRManifest v) ix =- readArray (irArray (aprj v aenv)) ix+ index :: ArrayVar aenv (Array sh e) -> Operands sh -> IROpenExp arch env aenv e+ index (Var repr v) = indexArray (irArray repr (aprj v aenv)) - index :: (Shape sh, Elt e) => IRManifest arch aenv (Array sh e) -> IR sh -> CodeGen (IR e)- index (IRManifest v) ix =- let arr = irArray (aprj v aenv)- in readArray arr =<< intOfIndex (irArrayShape arr) ix+ shape :: ArrayVar aenv (Array sh e) -> Operands sh+ shape (Var repr v) = irArrayShape (irArray repr (aprj v aenv)) - shape :: (Shape sh, Elt e) => IRManifest arch aenv (Array sh e) -> IR sh- shape (IRManifest v) = irArrayShape (irArray (aprj v aenv))+ pair :: Operands t1 -> Operands t2 -> IROpenExp arch env aenv (t1, t2)+ pair a b = return $ OP_Pair a b - shapeSize :: forall sh. Shape sh => IR sh -> CodeGen (IR Int)- shapeSize (IR extent) = go (eltType (undefined::sh)) extent- where- go :: TupleType t -> Operands t -> CodeGen (IR Int)- go TypeRunit OP_Unit- = return $ IR (constant (eltType (undefined :: Int)) 1)- go (TypeRpair tsh t) (OP_Pair sh sz)- | Just Refl <- matchTupleType t (eltType (undefined::Int))- = do- a <- go tsh sh- b <- A.mul numType a (IR sz)- return b- go (TypeRscalar t) (op' t -> i)- | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)- = return $ ir t i- go _ _- = $internalError "shapeSize" "expected shape with Int components"+ bool :: IROpenExp arch env aenv PrimBool+ -> IROpenExp arch env aenv Bool+ bool p = instr . IntToBool integralType . op integralType =<< p - intersect :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR sh)- intersect (IR extent1) (IR extent2) = IR <$> go (eltType (undefined::sh)) extent1 extent2- where- go :: TupleType t -> Operands t -> Operands t -> CodeGen (Operands t)- go TypeRunit OP_Unit OP_Unit- = return OP_Unit- go (TypeRscalar t) sh1 sh2- | Just Refl <- matchScalarType t (scalarType :: ScalarType Int) -- TLM: GHC hang if this is omitted- = do IR x <- A.min (singleType :: SingleType Int) (IR sh1) (IR sh2)- return x- go (TypeRpair tsh tsz) (OP_Pair sh1 sz1) (OP_Pair sh2 sz2)- = do- sz' <- go tsz sz1 sz2- sh' <- go tsh sh1 sh2- return $ OP_Pair sh' sz'- go _ _ _- = $internalError "intersect" "expected shape with Int components"+ primbool :: IROpenExp arch env aenv Bool+ -> IROpenExp arch env aenv PrimBool+ primbool b = instr . BoolToInt integralType . A.unbool =<< b - union :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR sh)- union (IR extent1) (IR extent2) = IR <$> go (eltType (undefined::sh)) extent1 extent2- where- go :: TupleType t -> Operands t -> Operands t -> CodeGen (Operands t)- go TypeRunit OP_Unit OP_Unit- = return OP_Unit- go (TypeRscalar t) sh1 sh2- | Just Refl <- matchScalarType t (scalarType :: ScalarType Int) -- TLM: GHC hang if this is omitted- = do IR x <- A.max (singleType :: SingleType Int) (IR sh1) (IR sh2)- return x- go (TypeRpair tsh tsz) (OP_Pair sh1 sz1) (OP_Pair sh2 sz2)- = do- sz' <- go tsz sz1 sz2- sh' <- go tsh sh1 sh2- return $ OP_Pair sh' sz'- go _ _ _- = $internalError "union" "expected shape with Int components"+ cond :: TypeR a+ -> IROpenExp arch env aenv PrimBool+ -> IROpenExp arch env aenv a+ -> IROpenExp arch env aenv a+ -> IROpenExp arch env aenv a+ cond tp p t e =+ A.ifThenElse (tp, bool p) t e - while :: Elt a- => IROpenFun1 arch env aenv (a -> Bool)+ while :: TypeR a+ -> IROpenFun1 arch env aenv (a -> PrimBool) -> IROpenFun1 arch env aenv (a -> a) -> IROpenExp arch env aenv a -> IROpenExp arch env aenv a- while p f x =- L.while (app1 p) (app1 f) =<< x+ while tp p f x =+ L.while tp (bool . app1 p) (app1 f) =<< x - foreignE :: (Elt a, Elt b, Foreign arch, A.Foreign asm)- => asm (a -> b)- -> DelayedFun () (a -> b)- -> IR a+ land :: Operands PrimBool+ -> Operands PrimBool+ -> IROpenExp arch env aenv PrimBool+ land x y = do+ x' <- instr (IntToBool integralType (op integralType x))+ y' <- instr (IntToBool integralType (op integralType y))+ primbool (A.land x' y')++ lor :: Operands PrimBool+ -> Operands PrimBool+ -> IROpenExp arch env aenv PrimBool+ lor x y = do+ x' <- instr (IntToBool integralType (op integralType x))+ y' <- instr (IntToBool integralType (op integralType y))+ primbool (A.lor x' y')++ foreignE :: A.Foreign asm+ => TypeR b+ -> asm (a -> b)+ -> Fun () (a -> b)+ -> Operands a -> IRExp arch () b- foreignE asm no x =- case foreignExp arch asm of- Just f -> app1 f x- Nothing | Lam (Body b) <- no -> llvmOfOpenExp arch b (Empty `Push` x) IM.empty- _ -> error "when a grid's misaligned with another behind / that's a moiré..."+ foreignE _ asm no x =+ case foreignExp asm of+ Just f -> app1 f x+ Nothing | Lam lhs (Body b) <- no -> llvmOfOpenExp b (Empty `pushE` (lhs, x)) IM.empty+ _ -> error "when a grid's misaligned with another behind / that's a moiré..." - coerce :: forall a b. (Elt a, Elt b) => IR a -> CodeGen (IR b)- coerce (IR as) = IR <$> go (eltType (undefined::a)) (eltType (undefined::b)) as- where- go :: TupleType s -> TupleType t -> Operands s -> CodeGen (Operands t)- go TypeRunit TypeRunit OP_Unit = return OP_Unit- go (TypeRpair s1 s2) (TypeRpair t1 t2) (OP_Pair x1 x2) = OP_Pair <$> go s1 t1 x1 <*> go s2 t2 x2- go (TypeRscalar s) (TypeRscalar t) x- | Just Refl <- matchScalarType s t = return x- | otherwise = ir' t <$> instr' (BitCast t (op' s x))- --- go (TypeRpair TypeRunit s) t@TypeRscalar{} (OP_Pair OP_Unit x) = go s t x- go s@TypeRscalar{} (TypeRpair TypeRunit t) x = OP_Pair OP_Unit <$> go s t x- go _ _ _- = error $ printf "could not coerce type `%s' to `%s'"- (show (typeOf (undefined::a)))- (show (typeOf (undefined::b)))+ coerce :: ScalarType a -> ScalarType b -> Operands a -> IROpenExp arch env aenv b+ coerce s t x+ | Just Refl <- matchScalarType s t = return $ x+ | otherwise = ir t <$> instr' (BitCast t (op s x)) - primFun :: Elt r- => PrimFun (a -> r)- -> DelayedOpenExp env aenv a- -> CodeGen (IR r)+ primFun :: PrimFun (a -> r)+ -> OpenExp env aenv a+ -> IROpenExp arch env aenv r primFun f x =- let- -- The Accelerate language and its code generator are hyper-strict.- -- However, we must not eagerly evaluate the arguments to logical- -- operations (&&*) and (||*) so that they can short-circuit. Since we- -- only have unary functions, this is a little tricky for us.- --- -- 'inl' and 'inr' attempt to destruct the incoming AST so that we can- -- evaluate the left or right components of a pair individually. It- -- should be noted that there are other cases which can evaluate to- -- pairs; 'Constant', 'Let' and 'Var', for example, but these cases- -- are (probably) not applicable in this context.- --- inl :: (Elt a, Elt b) => DelayedOpenExp env aenv (a,b) -> IROpenExp arch env aenv a- inl (Tuple (SnocTup (SnocTup NilTup a) _)) = cvtE a- inl t = cvtE $ Prj (SuccTupIdx ZeroTupIdx) t-- inr :: (Elt a, Elt b) => DelayedOpenExp env aenv (a,b) -> IROpenExp arch env aenv b- inr (Tuple (SnocTup _ b)) = cvtE b- inr t = cvtE $ Prj ZeroTupIdx t- in case f of- PrimAdd t -> A.uncurry (A.add t) =<< cvtE x- PrimSub t -> A.uncurry (A.sub t) =<< cvtE x- PrimMul t -> A.uncurry (A.mul t) =<< cvtE x- PrimNeg t -> A.negate t =<< cvtE x- PrimAbs t -> A.abs t =<< cvtE x- PrimSig t -> A.signum t =<< cvtE x- PrimQuot t -> A.uncurry (A.quot t) =<< cvtE x- PrimRem t -> A.uncurry (A.rem t) =<< cvtE x- PrimQuotRem t -> A.uncurry (A.quotRem t) =<< cvtE x- PrimIDiv t -> A.uncurry (A.idiv t) =<< cvtE x- PrimMod t -> A.uncurry (A.mod t) =<< cvtE x- PrimDivMod t -> A.uncurry (A.divMod t) =<< cvtE x- PrimBAnd t -> A.uncurry (A.band t) =<< cvtE x- PrimBOr t -> A.uncurry (A.bor t) =<< cvtE x- PrimBXor t -> A.uncurry (A.xor t) =<< cvtE x- PrimBNot t -> A.complement t =<< cvtE x- PrimBShiftL t -> A.uncurry (A.shiftL t) =<< cvtE x- PrimBShiftR t -> A.uncurry (A.shiftR t) =<< cvtE x- PrimBRotateL t -> A.uncurry (A.rotateL t) =<< cvtE x- PrimBRotateR t -> A.uncurry (A.rotateR t) =<< cvtE x- PrimPopCount t -> A.popCount t =<< cvtE x- PrimCountLeadingZeros t -> A.countLeadingZeros t =<< cvtE x- PrimCountTrailingZeros t -> A.countTrailingZeros t =<< cvtE x- PrimFDiv t -> A.uncurry (A.fdiv t) =<< cvtE x- PrimRecip t -> A.recip t =<< cvtE x- PrimSin t -> A.sin t =<< cvtE x- PrimCos t -> A.cos t =<< cvtE x- PrimTan t -> A.tan t =<< cvtE x- PrimSinh t -> A.sinh t =<< cvtE x- PrimCosh t -> A.cosh t =<< cvtE x- PrimTanh t -> A.tanh t =<< cvtE x- PrimAsin t -> A.asin t =<< cvtE x- PrimAcos t -> A.acos t =<< cvtE x- PrimAtan t -> A.atan t =<< cvtE x- PrimAsinh t -> A.asinh t =<< cvtE x- PrimAcosh t -> A.acosh t =<< cvtE x- PrimAtanh t -> A.atanh t =<< cvtE x- PrimAtan2 t -> A.uncurry (A.atan2 t) =<< cvtE x- PrimExpFloating t -> A.exp t =<< cvtE x- PrimFPow t -> A.uncurry (A.fpow t) =<< cvtE x- PrimSqrt t -> A.sqrt t =<< cvtE x- PrimLog t -> A.log t =<< cvtE x- PrimLogBase t -> A.uncurry (A.logBase t) =<< cvtE x- PrimTruncate ta tb -> A.truncate ta tb =<< cvtE x- PrimRound ta tb -> A.round ta tb =<< cvtE x- PrimFloor ta tb -> A.floor ta tb =<< cvtE x- PrimCeiling ta tb -> A.ceiling ta tb =<< cvtE x- PrimIsNaN t -> A.isNaN t =<< cvtE x- PrimIsInfinite t -> A.isInfinite t =<< cvtE x- PrimLt t -> A.uncurry (A.lt t) =<< cvtE x- PrimGt t -> A.uncurry (A.gt t) =<< cvtE x- PrimLtEq t -> A.uncurry (A.lte t) =<< cvtE x- PrimGtEq t -> A.uncurry (A.gte t) =<< cvtE x- PrimEq t -> A.uncurry (A.eq t) =<< cvtE x- PrimNEq t -> A.uncurry (A.neq t) =<< cvtE x- PrimMax t -> A.uncurry (A.max t) =<< cvtE x- PrimMin t -> A.uncurry (A.min t) =<< cvtE x- PrimLAnd -> A.land (inl x) (inr x) -- short circuit- PrimLOr -> A.lor (inl x) (inr x) -- short circuit- PrimLNot -> A.lnot =<< cvtE x- PrimOrd -> A.ord =<< cvtE x- PrimChr -> A.chr =<< cvtE x- PrimBoolToInt -> A.boolToInt =<< cvtE x- PrimFromIntegral ta tb -> A.fromIntegral ta tb =<< cvtE x- PrimToFloating ta tb -> A.toFloating ta tb =<< cvtE x+ PrimAdd t -> A.uncurry (A.add t) =<< cvtE x+ PrimSub t -> A.uncurry (A.sub t) =<< cvtE x+ PrimMul t -> A.uncurry (A.mul t) =<< cvtE x+ PrimNeg t -> A.negate t =<< cvtE x+ PrimAbs t -> A.abs t =<< cvtE x+ PrimSig t -> A.signum t =<< cvtE x+ PrimQuot t -> A.uncurry (A.quot t) =<< cvtE x+ PrimRem t -> A.uncurry (A.rem t) =<< cvtE x+ PrimQuotRem t -> A.uncurry (A.quotRem t) =<< cvtE x+ PrimIDiv t -> A.uncurry (A.idiv t) =<< cvtE x+ PrimMod t -> A.uncurry (A.mod t) =<< cvtE x+ PrimDivMod t -> A.uncurry (A.divMod t) =<< cvtE x+ PrimBAnd t -> A.uncurry (A.band t) =<< cvtE x+ PrimBOr t -> A.uncurry (A.bor t) =<< cvtE x+ PrimBXor t -> A.uncurry (A.xor t) =<< cvtE x+ PrimBNot t -> A.complement t =<< cvtE x+ PrimBShiftL t -> A.uncurry (A.shiftL t) =<< cvtE x+ PrimBShiftR t -> A.uncurry (A.shiftR t) =<< cvtE x+ PrimBRotateL t -> A.uncurry (A.rotateL t) =<< cvtE x+ PrimBRotateR t -> A.uncurry (A.rotateR t) =<< cvtE x+ PrimPopCount t -> A.popCount t =<< cvtE x+ PrimCountLeadingZeros t -> A.countLeadingZeros t =<< cvtE x+ PrimCountTrailingZeros t -> A.countTrailingZeros t =<< cvtE x+ PrimFDiv t -> A.uncurry (A.fdiv t) =<< cvtE x+ PrimRecip t -> A.recip t =<< cvtE x+ PrimSin t -> A.sin t =<< cvtE x+ PrimCos t -> A.cos t =<< cvtE x+ PrimTan t -> A.tan t =<< cvtE x+ PrimSinh t -> A.sinh t =<< cvtE x+ PrimCosh t -> A.cosh t =<< cvtE x+ PrimTanh t -> A.tanh t =<< cvtE x+ PrimAsin t -> A.asin t =<< cvtE x+ PrimAcos t -> A.acos t =<< cvtE x+ PrimAtan t -> A.atan t =<< cvtE x+ PrimAsinh t -> A.asinh t =<< cvtE x+ PrimAcosh t -> A.acosh t =<< cvtE x+ PrimAtanh t -> A.atanh t =<< cvtE x+ PrimAtan2 t -> A.uncurry (A.atan2 t) =<< cvtE x+ PrimExpFloating t -> A.exp t =<< cvtE x+ PrimFPow t -> A.uncurry (A.fpow t) =<< cvtE x+ PrimSqrt t -> A.sqrt t =<< cvtE x+ PrimLog t -> A.log t =<< cvtE x+ PrimLogBase t -> A.uncurry (A.logBase t) =<< cvtE x+ PrimTruncate ta tb -> A.truncate ta tb =<< cvtE x+ PrimRound ta tb -> A.round ta tb =<< cvtE x+ PrimFloor ta tb -> A.floor ta tb =<< cvtE x+ PrimCeiling ta tb -> A.ceiling ta tb =<< cvtE x+ PrimMax t -> A.uncurry (A.max t) =<< cvtE x+ PrimMin t -> A.uncurry (A.min t) =<< cvtE x+ PrimFromIntegral ta tb -> A.fromIntegral ta tb =<< cvtE x+ PrimToFloating ta tb -> A.toFloating ta tb =<< cvtE x+ PrimLAnd -> A.uncurry land =<< cvtE x+ PrimLOr -> A.uncurry lor =<< cvtE x+ PrimIsNaN t -> primbool $ A.isNaN t =<< cvtE x+ PrimIsInfinite t -> primbool $ A.isInfinite t =<< cvtE x+ PrimLt t -> primbool $ A.uncurry (A.lt t) =<< cvtE x+ PrimGt t -> primbool $ A.uncurry (A.gt t) =<< cvtE x+ PrimLtEq t -> primbool $ A.uncurry (A.lte t) =<< cvtE x+ PrimGtEq t -> primbool $ A.uncurry (A.gte t) =<< cvtE x+ PrimEq t -> primbool $ A.uncurry (A.eq t) =<< cvtE x+ PrimNEq t -> primbool $ A.uncurry (A.neq t) =<< cvtE x+ PrimLNot -> primbool $ A.lnot =<< bool (cvtE x) -- no missing patterns, whoo! -- | Extract the head of an index ---indexHead :: IR (sh :. sz) -> IR sz-indexHead (IR (OP_Pair _ sz)) = IR sz+indexHead :: Operands (sh, sz) -> Operands sz+indexHead (OP_Pair _ sz) = sz -- | Extract the tail of an index ---indexTail :: IR (sh :. sz) -> IR sh-indexTail (IR (OP_Pair sh _)) = IR sh+indexTail :: Operands (sh, sz) -> Operands sh+indexTail (OP_Pair sh _) = sh -- | Construct an index from the head and tail ---indexCons :: IR sh -> IR sz -> IR (sh :. sz)-indexCons (IR sh) (IR sz) = IR (OP_Pair sh sz)+indexCons :: Operands sh -> Operands sz -> Operands (sh, sz)+indexCons sh sz = OP_Pair sh sz +-- | Number of elements contained within a shape+--+shapeSize :: ShapeR sh -> Operands sh -> CodeGen arch (Operands Int)+shapeSize ShapeRz OP_Unit+ = return $ A.liftInt 1+shapeSize (ShapeRsnoc shr) (OP_Pair sh sz)+ = case shr of+ ShapeRz -> return sz+ _ -> do+ a <- shapeSize shr sh+ b <- A.mul numType a sz+ return b -- | Convert a multidimensional array index into a linear index ---intOfIndex :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR Int)-intOfIndex (IR extent) (IR index) = cvt (eltType (undefined::sh)) extent index- where- cvt :: TupleType t -> Operands t -> Operands t -> CodeGen (IR Int)- cvt TypeRunit OP_Unit OP_Unit- = return $ IR (constant (eltType (undefined :: Int)) 0)-- cvt (TypeRpair tsh t) (OP_Pair sh sz) (OP_Pair ix i)- | Just Refl <- matchTupleType t (eltType (undefined::Int))- -- If we short-circuit the last dimension, we can avoid inserting- -- a multiply by zero and add of the result.- = case matchTupleType tsh (eltType (undefined::Z)) of- Just Refl -> return (IR i)- Nothing -> do- a <- cvt tsh sh ix- b <- A.mul numType a (IR sz)- c <- A.add numType b (IR i)- return c-- cvt (TypeRscalar t) _ (op' t -> i)- | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)- = return $ ir t i-- cvt _ _ _- = $internalError "intOfIndex" "expected shape with Int components"+intOfIndex :: ShapeR sh -> Operands sh -> Operands sh -> CodeGen arch (Operands Int)+intOfIndex ShapeRz OP_Unit OP_Unit+ = return $ A.liftInt 0+intOfIndex (ShapeRsnoc shr) (OP_Pair sh sz) (OP_Pair ix i)+ -- If we short-circuit the last dimension, we can avoid inserting+ -- a multiply by zero and add of the result.+ = case shr of+ ShapeRz -> return i+ _ -> do+ a <- intOfIndex shr sh ix+ b <- A.mul numType a sz+ c <- A.add numType b i+ return c -- | Convert a linear index into into a multidimensional index ---indexOfInt :: forall sh. Shape sh => IR sh -> IR Int -> CodeGen (IR sh)-indexOfInt (IR extent) index = IR <$> cvt (eltType (undefined::sh)) extent index- where- cvt :: TupleType t -> Operands t -> IR Int -> CodeGen (Operands t)- cvt TypeRunit OP_Unit _- = return OP_Unit+indexOfInt :: ShapeR sh -> Operands sh -> Operands Int -> CodeGen arch (Operands sh)+indexOfInt ShapeRz OP_Unit _+ = return OP_Unit+indexOfInt (ShapeRsnoc shr) (OP_Pair sh sz) i+ = do+ i' <- A.quot integralType i sz+ -- If we assume the index is in range, there is no point computing+ -- the remainder of the highest dimension since (i < sz) must hold+ r <- case shr of+ ShapeRz -> return i -- TODO: in debug mode assert (i < sz)+ _ -> A.rem integralType i sz+ sh' <- indexOfInt shr sh i'+ return $ OP_Pair sh' r - cvt (TypeRpair tsh tsz) (OP_Pair sh sz) i- | Just Refl <- matchTupleType tsz (eltType (undefined::Int))- = do- i' <- A.quot integralType i (IR sz)- -- If we assume the index is in range, there is no point computing- -- the remainder of the highest dimension since (i < sz) must hold- IR r <- case matchTupleType tsh (eltType (undefined::Z)) of- Just Refl -> return i -- TODO: in debug mode assert (i < sz)- Nothing -> A.rem integralType i (IR sz)- sh' <- cvt tsh sh i'- return $ OP_Pair sh' r+-- | Read an element at a multidimensional index+--+indexArray :: IRArray (Array sh e) -> Operands sh -> IROpenExp arch env aenv e+indexArray arr ix = linearIndexArray arr =<< intOfIndex (arrayRshape $ irArrayRepr arr) (irArrayShape arr) ix - cvt (TypeRscalar t) _ (IR i)- | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)- = return i+-- | Read an element at a linear index+--+linearIndexArray :: IRArray (Array sh e) -> Operands Int -> IROpenExp arch env aenv e+linearIndexArray = readArray TypeInt - cvt _ _ _- = $internalError "indexOfInt" "expected shape with Int components"+pushE :: Val env -> (ELeftHandSide t env env', Operands t) -> Val env'+pushE env (LeftHandSideSingle _ , e) = env `Push` e+pushE env (LeftHandSideWildcard _, _) = env+pushE env (LeftHandSidePair l1 l2, (OP_Pair e1 e2)) = pushE env (l1, e1) `pushE` (l2, e2)
+ src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs-boot view
@@ -0,0 +1,20 @@+-- |+-- Module : Data.Array.Accelerate.LLVM.CodeGen.Exp-boot+-- Copyright : [2015..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.CodeGen.Exp+ where++import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Sugar++indexArray :: IRArray (Array sh e) -> Operands sh -> IROpenExp arch env aenv e+linearIndexArray :: IRArray (Array sh e) -> Operands Int -> IROpenExp arch env aenv e+
src/Data/Array/Accelerate/LLVM/CodeGen/IR.hs view
@@ -1,21 +1,22 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.IR--- 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) -- module Data.Array.Accelerate.LLVM.CodeGen.IR ( - IR(..), Operands(..),+ Operands(..), IROP(..), ) where@@ -24,95 +25,57 @@ import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Error+import Data.Primitive.Vec import qualified Data.ByteString.Short as B --- | The datatype 'IR' represents the LLVM IR producing a value of type 'a'.--- Note that the operands comprising this value are stored in representation--- type.----data IR t where- IR :: Operands (EltRepr t)- -> IR t- -- We use a data family to represent sequences of LLVM (scalar) operands -- representing a single Accelerate type. Using a data family rather than a type -- family means that Operands is bijective. -- data family Operands e :: *-data instance Operands () = OP_Unit-data instance Operands Int = OP_Int (Operand Int)-data instance Operands Int8 = OP_Int8 (Operand Int8)-data instance Operands Int16 = OP_Int16 (Operand Int16)-data instance Operands Int32 = OP_Int32 (Operand Int32)-data instance Operands Int64 = OP_Int64 (Operand Int64)-data instance Operands Word = OP_Word (Operand Word)-data instance Operands Word8 = OP_Word8 (Operand Word8)-data instance Operands Word16 = OP_Word16 (Operand Word16)-data instance Operands Word32 = OP_Word32 (Operand Word32)-data instance Operands Word64 = OP_Word64 (Operand Word64)-data instance Operands CShort = OP_CShort (Operand CShort)-data instance Operands CUShort = OP_CUShort (Operand CUShort)-data instance Operands CInt = OP_CInt (Operand CInt)-data instance Operands CUInt = OP_CUInt (Operand CUInt)-data instance Operands CLong = OP_CLong (Operand CLong)-data instance Operands CULong = OP_CULong (Operand CULong)-data instance Operands CLLong = OP_CLLong (Operand CLLong)-data instance Operands CULLong = OP_CULLong (Operand CULLong)-data instance Operands Half = OP_Half (Operand Half)-data instance Operands Float = OP_Float (Operand Float)-data instance Operands Double = OP_Double (Operand Double)-data instance Operands CFloat = OP_CFloat (Operand CFloat)-data instance Operands CDouble = OP_CDouble (Operand CDouble)-data instance Operands Bool = OP_Bool (Operand Bool)-data instance Operands Char = OP_Char (Operand Char)-data instance Operands CChar = OP_CChar (Operand CChar)-data instance Operands CSChar = OP_CSChar (Operand CSChar)-data instance Operands CUChar = OP_CUChar (Operand CUChar)-data instance Operands (V2 a) = OP_V2 (Operand (V2 a))-data instance Operands (V3 a) = OP_V3 (Operand (V3 a))-data instance Operands (V4 a) = OP_V4 (Operand (V4 a))-data instance Operands (V8 a) = OP_V8 (Operand (V8 a))-data instance Operands (V16 a) = OP_V16 (Operand (V16 a))-data instance Operands (a,b) = OP_Pair (Operands a) (Operands b)+data instance Operands () = OP_Unit+data instance Operands Int = OP_Int (Operand Int)+data instance Operands Int8 = OP_Int8 (Operand Int8)+data instance Operands Int16 = OP_Int16 (Operand Int16)+data instance Operands Int32 = OP_Int32 (Operand Int32)+data instance Operands Int64 = OP_Int64 (Operand Int64)+data instance Operands Word = OP_Word (Operand Word)+data instance Operands Word8 = OP_Word8 (Operand Word8)+data instance Operands Word16 = OP_Word16 (Operand Word16)+data instance Operands Word32 = OP_Word32 (Operand Word32)+data instance Operands Word64 = OP_Word64 (Operand Word64)+data instance Operands Half = OP_Half (Operand Half)+data instance Operands Float = OP_Float (Operand Float)+data instance Operands Double = OP_Double (Operand Double)+data instance Operands Bool = OP_Bool (Operand Bool)+data instance Operands (Vec n a) = OP_Vec (Operand (Vec n a))+data instance Operands (a,b) = OP_Pair (Operands a) (Operands b) -- | Given some evidence that 'IR a' represents a scalar type, it can be -- converted between the IR and Operand data types. -- class IROP dict where- op :: dict a -> IR a -> Operand a- ir :: dict a -> Operand a -> IR a- --- op' :: dict a -> Operands a -> Operand a- ir' :: dict a -> Operand a -> Operands a+ op :: HasCallStack => dict a -> Operands a -> Operand a+ ir :: HasCallStack => dict a -> Operand a -> Operands a instance IROP Type where- op VoidType _ = LocalReference VoidType (Name B.empty) -- TLM: ???- op (PrimType t) x = op t x-- ir VoidType _ = IR OP_Unit- ir (PrimType t) x = ir t x- --- ir' VoidType _ = OP_Unit- ir' (PrimType t) x = ir' t x+ ir VoidType _ = OP_Unit+ ir (PrimType t) x = ir t x - op' VoidType _ = LocalReference VoidType (Name B.empty) -- TLM: ???- op' (PrimType t) x = op' t x+ op VoidType _ = LocalReference VoidType (Name B.empty)+ op (PrimType t) x = op t x instance IROP PrimType where- op (ScalarPrimType t) = op t- op t = $internalError "op" ("unhandled type: " ++ show t)- ir (ScalarPrimType t) = ir t- ir t = $internalError "ir" ("unhandeld type: " ++ show t)- --- op' (ScalarPrimType t) = op' t- op' t = $internalError "op'" ("unhandled type: " ++ show t)- ir' (ScalarPrimType t) = ir' t- ir' t = $internalError "ir'" ("unhandled type: " ++ show t)+ op (ScalarPrimType t) = op t+ op BoolPrimType = \case OP_Bool x -> x+ op t = internalError ("unhandled type: " ++ show t)+ ir (ScalarPrimType t) = ir t+ ir BoolPrimType = OP_Bool+ ir t = internalError ("unhandled type: " ++ show t) instance IROP ScalarType where op (SingleScalarType t) = op t@@ -120,183 +83,98 @@ ir (SingleScalarType t) = ir t ir (VectorScalarType t) = ir t - op' (SingleScalarType t) = op' t- op' (VectorScalarType t) = op' t-- ir' (SingleScalarType t) = ir' t- ir' (VectorScalarType t) = ir' t- instance IROP SingleType where- op (NumSingleType t) = op t- op (NonNumSingleType t) = op t- ir (NumSingleType t) = ir t- ir (NonNumSingleType t) = ir t- --- op' (NumSingleType t) = op' t- op' (NonNumSingleType t) = op' t- ir' (NumSingleType t) = ir' t- ir' (NonNumSingleType t) = ir' t+ op (NumSingleType t) = op t+ ir (NumSingleType t) = ir t instance IROP VectorType where- op Vector2Type{} (IR (OP_V2 x)) = x- op Vector3Type{} (IR (OP_V3 x)) = x- op Vector4Type{} (IR (OP_V4 x)) = x- op Vector8Type{} (IR (OP_V8 x)) = x- op Vector16Type{} (IR (OP_V16 x)) = x- --- ir Vector2Type{} = IR . OP_V2- ir Vector3Type{} = IR . OP_V3- ir Vector4Type{} = IR . OP_V4- ir Vector8Type{} = IR . OP_V8- ir Vector16Type{} = IR . OP_V16- --- op' Vector2Type{} (OP_V2 x) = x- op' Vector3Type{} (OP_V3 x) = x- op' Vector4Type{} (OP_V4 x) = x- op' Vector8Type{} (OP_V8 x) = x- op' Vector16Type{} (OP_V16 x) = x- --- ir' Vector2Type{} = OP_V2- ir' Vector3Type{} = OP_V3- ir' Vector4Type{} = OP_V4- ir' Vector8Type{} = OP_V8- ir' Vector16Type{} = OP_V16+ op (VectorType _ v) = single v+ where+ single :: SingleType t -> Operands (Vec n t) -> Operand (Vec n t)+ single (NumSingleType t) = num t + num :: NumType t -> Operands (Vec n t) -> Operand (Vec n t)+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType t -> Operands (Vec n t) -> Operand (Vec n t)+ integral TypeInt (OP_Vec x) = x+ integral TypeInt8 (OP_Vec x) = x+ integral TypeInt16 (OP_Vec x) = x+ integral TypeInt32 (OP_Vec x) = x+ integral TypeInt64 (OP_Vec x) = x+ integral TypeWord (OP_Vec x) = x+ integral TypeWord8 (OP_Vec x) = x+ integral TypeWord16 (OP_Vec x) = x+ integral TypeWord32 (OP_Vec x) = x+ integral TypeWord64 (OP_Vec x) = x++ floating :: FloatingType t -> Operands (Vec n t) -> Operand (Vec n t)+ floating TypeHalf (OP_Vec x) = x+ floating TypeFloat (OP_Vec x) = x+ floating TypeDouble (OP_Vec x) = x++ ir (VectorType _ v) = single v+ where+ single :: SingleType t -> Operand (Vec n t) -> Operands (Vec n t)+ single (NumSingleType t) = num t++ num :: NumType t -> Operand (Vec n t) -> Operands (Vec n t)+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType t -> Operand (Vec n t) -> Operands (Vec n t)+ integral TypeInt = OP_Vec+ integral TypeInt8 = OP_Vec+ integral TypeInt16 = OP_Vec+ integral TypeInt32 = OP_Vec+ integral TypeInt64 = OP_Vec+ integral TypeWord = OP_Vec+ integral TypeWord8 = OP_Vec+ integral TypeWord16 = OP_Vec+ integral TypeWord32 = OP_Vec+ integral TypeWord64 = OP_Vec++ floating :: FloatingType t -> Operand (Vec n t) -> Operands (Vec n t)+ floating TypeHalf = OP_Vec+ floating TypeFloat = OP_Vec+ floating TypeDouble = OP_Vec+ instance IROP NumType where op (IntegralNumType t) = op t op (FloatingNumType t) = op t ir (IntegralNumType t) = ir t ir (FloatingNumType t) = ir t- --- op' (IntegralNumType t) = op' t- op' (FloatingNumType t) = op' t- ir' (IntegralNumType t) = ir' t- ir' (FloatingNumType t) = ir' t instance IROP IntegralType where- op TypeInt{} (IR (OP_Int x)) = x- op TypeInt8{} (IR (OP_Int8 x)) = x- op TypeInt16{} (IR (OP_Int16 x)) = x- op TypeInt32{} (IR (OP_Int32 x)) = x- op TypeInt64{} (IR (OP_Int64 x)) = x- op TypeWord{} (IR (OP_Word x)) = x- op TypeWord8{} (IR (OP_Word8 x)) = x- op TypeWord16{} (IR (OP_Word16 x)) = x- op TypeWord32{} (IR (OP_Word32 x)) = x- op TypeWord64{} (IR (OP_Word64 x)) = x- op TypeCShort{} (IR (OP_CShort x)) = x- op TypeCUShort{} (IR (OP_CUShort x)) = x- op TypeCInt{} (IR (OP_CInt x)) = x- op TypeCUInt{} (IR (OP_CUInt x)) = x- op TypeCLong{} (IR (OP_CLong x)) = x- op TypeCULong{} (IR (OP_CULong x)) = x- op TypeCLLong{} (IR (OP_CLLong x)) = x- op TypeCULLong{} (IR (OP_CULLong x)) = x- --- ir TypeInt{} = IR . OP_Int- ir TypeInt8{} = IR . OP_Int8- ir TypeInt16{} = IR . OP_Int16- ir TypeInt32{} = IR . OP_Int32- ir TypeInt64{} = IR . OP_Int64- ir TypeWord{} = IR . OP_Word- ir TypeWord8{} = IR . OP_Word8- ir TypeWord16{} = IR . OP_Word16- ir TypeWord32{} = IR . OP_Word32- ir TypeWord64{} = IR . OP_Word64- ir TypeCShort{} = IR . OP_CShort- ir TypeCUShort{} = IR . OP_CUShort- ir TypeCInt{} = IR . OP_CInt- ir TypeCUInt{} = IR . OP_CUInt- ir TypeCLong{} = IR . OP_CLong- ir TypeCULong{} = IR . OP_CULong- ir TypeCLLong{} = IR . OP_CLLong- ir TypeCULLong{} = IR . OP_CULLong- --- op' TypeInt{} (OP_Int x) = x- op' TypeInt8{} (OP_Int8 x) = x- op' TypeInt16{} (OP_Int16 x) = x- op' TypeInt32{} (OP_Int32 x) = x- op' TypeInt64{} (OP_Int64 x) = x- op' TypeWord{} (OP_Word x) = x- op' TypeWord8{} (OP_Word8 x) = x- op' TypeWord16{} (OP_Word16 x) = x- op' TypeWord32{} (OP_Word32 x) = x- op' TypeWord64{} (OP_Word64 x) = x- op' TypeCShort{} (OP_CShort x) = x- op' TypeCUShort{} (OP_CUShort x) = x- op' TypeCInt{} (OP_CInt x) = x- op' TypeCUInt{} (OP_CUInt x) = x- op' TypeCLong{} (OP_CLong x) = x- op' TypeCULong{} (OP_CULong x) = x- op' TypeCLLong{} (OP_CLLong x) = x- op' TypeCULLong{} (OP_CULLong x) = x+ op TypeInt (OP_Int x) = x+ op TypeInt8 (OP_Int8 x) = x+ op TypeInt16 (OP_Int16 x) = x+ op TypeInt32 (OP_Int32 x) = x+ op TypeInt64 (OP_Int64 x) = x+ op TypeWord (OP_Word x) = x+ op TypeWord8 (OP_Word8 x) = x+ op TypeWord16 (OP_Word16 x) = x+ op TypeWord32 (OP_Word32 x) = x+ op TypeWord64 (OP_Word64 x) = x --- ir' TypeInt{} = OP_Int- ir' TypeInt8{} = OP_Int8- ir' TypeInt16{} = OP_Int16- ir' TypeInt32{} = OP_Int32- ir' TypeInt64{} = OP_Int64- ir' TypeWord{} = OP_Word- ir' TypeWord8{} = OP_Word8- ir' TypeWord16{} = OP_Word16- ir' TypeWord32{} = OP_Word32- ir' TypeWord64{} = OP_Word64- ir' TypeCShort{} = OP_CShort- ir' TypeCUShort{} = OP_CUShort- ir' TypeCInt{} = OP_CInt- ir' TypeCUInt{} = OP_CUInt- ir' TypeCLong{} = OP_CLong- ir' TypeCULong{} = OP_CULong- ir' TypeCLLong{} = OP_CLLong- ir' TypeCULLong{} = OP_CULLong+ ir TypeInt = OP_Int+ ir TypeInt8 = OP_Int8+ ir TypeInt16 = OP_Int16+ ir TypeInt32 = OP_Int32+ ir TypeInt64 = OP_Int64+ ir TypeWord = OP_Word+ ir TypeWord8 = OP_Word8+ ir TypeWord16 = OP_Word16+ ir TypeWord32 = OP_Word32+ ir TypeWord64 = OP_Word64 instance IROP FloatingType where- op TypeHalf{} (IR (OP_Half x)) = x- op TypeFloat{} (IR (OP_Float x)) = x- op TypeDouble{} (IR (OP_Double x)) = x- op TypeCFloat{} (IR (OP_CFloat x)) = x- op TypeCDouble{} (IR (OP_CDouble x)) = x- --- ir TypeHalf{} = IR . OP_Half- ir TypeFloat{} = IR . OP_Float- ir TypeDouble{} = IR . OP_Double- ir TypeCFloat{} = IR . OP_CFloat- ir TypeCDouble{} = IR . OP_CDouble- --- op' TypeHalf{} (OP_Half x) = x- op' TypeFloat{} (OP_Float x) = x- op' TypeDouble{} (OP_Double x) = x- op' TypeCFloat{} (OP_CFloat x) = x- op' TypeCDouble{} (OP_CDouble x) = x- --- ir' TypeHalf{} = OP_Half- ir' TypeFloat{} = OP_Float- ir' TypeDouble{} = OP_Double- ir' TypeCFloat{} = OP_CFloat- ir' TypeCDouble{} = OP_CDouble--instance IROP NonNumType where- op TypeBool{} (IR (OP_Bool x)) = x- op TypeChar{} (IR (OP_Char x)) = x- op TypeCChar{} (IR (OP_CChar x)) = x- op TypeCSChar{} (IR (OP_CSChar x)) = x- op TypeCUChar{} (IR (OP_CUChar x)) = x- --- ir TypeBool{} = IR . OP_Bool- ir TypeChar{} = IR . OP_Char- ir TypeCChar{} = IR . OP_CChar- ir TypeCSChar{} = IR . OP_CSChar- ir TypeCUChar{} = IR . OP_CUChar- --- op' TypeBool{} (OP_Bool x) = x- op' TypeChar{} (OP_Char x) = x- op' TypeCChar{} (OP_CChar x) = x- op' TypeCSChar{} (OP_CSChar x) = x- op' TypeCUChar{} (OP_CUChar x) = x+ op TypeHalf (OP_Half x) = x+ op TypeFloat (OP_Float x) = x+ op TypeDouble (OP_Double x) = x --- ir' TypeBool{} = OP_Bool- ir' TypeChar{} = OP_Char- ir' TypeCChar{} = OP_CChar- ir' TypeCSChar{} = OP_CSChar- ir' TypeCUChar{} = OP_CUChar+ ir TypeHalf = OP_Half+ ir TypeFloat = OP_Float+ ir TypeDouble = OP_Double
src/Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Intrinsic--- 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) --@@ -39,8 +40,8 @@ -- sqrt -> llvm.sqrt.f64 -- class Intrinsic arch where- intrinsicForTarget :: arch -> HashMap ShortByteString Label- intrinsicForTarget _ = llvmIntrinsic+ intrinsicForTarget :: HashMap ShortByteString Label+ intrinsicForTarget = llvmIntrinsic llvmIntrinsic :: HashMap ShortByteString Label
src/Data/Array/Accelerate/LLVM/CodeGen/Loop.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Loop--- 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) --@@ -13,90 +14,95 @@ module Data.Array.Accelerate.LLVM.CodeGen.Loop where -import Prelude hiding ( fst, snd, uncurry )-import Control.Monad-+import Data.Array.Accelerate.Representation.Type import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Array.Sugar hiding ( iter ) import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad +import Prelude hiding ( fst, snd, uncurry )+import Control.Monad + -- | TODO: Iterate over a multidimensional index space. ----- Build nested loops that iterate over a hype-rectangular index space--- between the given coordinates. The LLVM optimiser will be able to--- vectorise nested loops, including when we insert conversions to the--- corresponding linear index (e.g., in order to index arrays).+-- Build nested loops that iterate over a hyper-rectangular index space between+-- the given coordinates. The LLVM optimiser will be able to vectorise nested+-- loops, including when we insert conversions to the corresponding linear index+-- (e.g., in order to index arrays). -- -- iterate -- :: Shape sh--- => IR sh -- ^ starting index--- -> IR sh -- ^ final index--- -> (IR sh -> CodeGen (IR a)) -- ^ body of the loop--- -> CodeGen (IR a)+-- => Operands sh -- ^ starting index+-- -> Operands sh -- ^ final index+-- -> (Operands sh -> CodeGen (Operands a)) -- ^ body of the loop+-- -> CodeGen (Operands a) -- iterate from to body = error "CodeGen.Loop.iterate" -- | Execute the given function at each index in the range -- imapFromStepTo- :: (IsNum i, Elt i)- => IR i -- ^ starting index (inclusive)- -> IR i -- ^ step size- -> IR i -- ^ final index (exclusive)- -> (IR i -> CodeGen ()) -- ^ loop body- -> CodeGen ()+ :: forall i arch. IsNum i+ => Operands i -- ^ starting index (inclusive)+ -> Operands i -- ^ step size+ -> Operands i -- ^ final index (exclusive)+ -> (Operands i -> CodeGen arch ()) -- ^ loop body+ -> CodeGen arch () imapFromStepTo start step end body =- for start- (\i -> lt singleType i end)- (\i -> add numType i step)+ for (TupRsingle $ SingleScalarType $ NumSingleType num) start+ (\i -> lt (NumSingleType num) i end)+ (\i -> add num i step) body+ where num = numType @i -- | Iterate with an accumulator between given start and end indices, executing -- the given function at each. -- iterFromStepTo- :: (IsNum i, Elt i, Elt a)- => IR i -- ^ starting index (inclusive)- -> IR i -- ^ step size- -> IR i -- ^ final index (exclusive)- -> IR a -- ^ initial value- -> (IR i -> IR a -> CodeGen (IR a)) -- ^ loop body- -> CodeGen (IR a)-iterFromStepTo start step end seed body =- iter start seed- (\i -> lt singleType i end)- (\i -> add numType i step)+ :: forall i a arch. IsNum i+ => TypeR a+ -> Operands i -- ^ starting index (inclusive)+ -> Operands i -- ^ step size+ -> Operands i -- ^ final index (exclusive)+ -> Operands a -- ^ initial value+ -> (Operands i -> Operands a -> CodeGen arch (Operands a)) -- ^ loop body+ -> CodeGen arch (Operands a)+iterFromStepTo tp start step end seed body =+ iter (TupRsingle $ SingleScalarType $ NumSingleType num) tp start seed+ (\i -> lt (NumSingleType num) i end)+ (\i -> add num i step) body+ where num = numType @i -- | A standard 'for' loop. ---for :: Elt i- => IR i -- ^ starting index- -> (IR i -> CodeGen (IR Bool)) -- ^ loop test to keep going- -> (IR i -> CodeGen (IR i)) -- ^ increment loop counter- -> (IR i -> CodeGen ()) -- ^ body of the loop- -> CodeGen ()-for start test incr body =- void $ while test (\i -> body i >> incr i) start+for :: TypeR i+ -> Operands i -- ^ starting index+ -> (Operands i -> CodeGen arch (Operands Bool)) -- ^ loop test to keep going+ -> (Operands i -> CodeGen arch (Operands i)) -- ^ increment loop counter+ -> (Operands i -> CodeGen arch ()) -- ^ body of the loop+ -> CodeGen arch ()+for tp start test incr body =+ void $ while tp test (\i -> body i >> incr i) start -- | An loop with iteration count and accumulator. ---iter :: (Elt i, Elt a)- => IR i -- ^ starting index- -> IR a -- ^ initial value- -> (IR i -> CodeGen (IR Bool)) -- ^ index test to keep looping- -> (IR i -> CodeGen (IR i)) -- ^ increment loop counter- -> (IR i -> IR a -> CodeGen (IR a)) -- ^ loop body- -> CodeGen (IR a)-iter start seed test incr body = do- r <- while (test . fst)+iter :: TypeR i+ -> TypeR a+ -> Operands i -- ^ starting index+ -> Operands a -- ^ initial value+ -> (Operands i -> CodeGen arch (Operands Bool)) -- ^ index test to keep looping+ -> (Operands i -> CodeGen arch (Operands i)) -- ^ increment loop counter+ -> (Operands i -> Operands a -> CodeGen arch (Operands a)) -- ^ loop body+ -> CodeGen arch (Operands a)+iter tpi tpa start seed test incr body = do+ r <- while (TupRpair tpi tpa)+ (test . fst) (\v -> do v' <- uncurry body v -- update value and then... i' <- incr (fst v) -- ...calculate new index return $ pair i' v')@@ -106,12 +112,12 @@ -- | A standard 'while' loop ---while :: Elt a- => (IR a -> CodeGen (IR Bool))- -> (IR a -> CodeGen (IR a))- -> IR a- -> CodeGen (IR a)-while test body start = do+while :: TypeR a+ -> (Operands a -> CodeGen arch (Operands Bool))+ -> (Operands a -> CodeGen arch (Operands a))+ -> Operands a+ -> CodeGen arch (Operands a)+while tp test body start = do loop <- newBlock "while.top" exit <- newBlock "while.exit" _ <- beginBlock "while.entry"@@ -121,7 +127,7 @@ top <- cbr p loop exit -- Create the critical variable that will be used to accumulate the results- prev <- fresh+ prev <- fresh tp -- Generate the loop body. Afterwards, we insert a phi node at the head of the -- instruction stream, which selects the input value depending on which edge@@ -132,9 +138,9 @@ p' <- test next bot <- cbr p' loop exit - _ <- phi' loop prev [(start,top), (next,bot)]+ _ <- phi' tp loop prev [(start,top), (next,bot)] -- Now the loop exit setBlock exit- phi [(start,top), (next,bot)]+ phi tp [(start,top), (next,bot)]
src/Data/Array/Accelerate/LLVM/CodeGen/Module.hs view
@@ -2,10 +2,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Module--- 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) --
src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs view
@@ -4,13 +4,14 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Monad--- 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) --@@ -18,7 +19,8 @@ module Data.Array.Accelerate.LLVM.CodeGen.Monad ( CodeGen,- runLLVM,+ evalCodeGen,+ liftCodeGen, -- declarations fresh, freshName,@@ -30,7 +32,7 @@ newBlock, setBlock, beginBlock, createBlocks, -- instructions- instr, instr', do_, return_, retval_, br, cbr, phi, phi',+ instr, instr', do_, return_, retval_, br, cbr, switch, phi, phi', phi1, instr_, -- metadata@@ -38,7 +40,28 @@ ) where --- standard library+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.LLVM.CodeGen.IR+import Data.Array.Accelerate.LLVM.CodeGen.Intrinsic+import Data.Array.Accelerate.LLVM.CodeGen.Module+import Data.Array.Accelerate.LLVM.CodeGen.Sugar ( IROpenAcc(..) )+import Data.Array.Accelerate.LLVM.State ( LLVM )+import Data.Array.Accelerate.LLVM.Target+import Data.Array.Accelerate.Representation.Tag+import Data.Array.Accelerate.Representation.Type+import qualified Data.Array.Accelerate.Debug as Debug++import LLVM.AST.Type.Constant+import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Instruction+import LLVM.AST.Type.Metadata+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation+import LLVM.AST.Type.Terminator+import qualified LLVM.AST as LLVM+import qualified LLVM.AST.Global as LLVM+ import Control.Applicative import Control.Monad.State import Data.ByteString.Short ( ShortByteString )@@ -47,7 +70,6 @@ import Data.Map ( Map ) import Data.Sequence ( Seq ) import Data.String-import Data.Word import Prelude import Text.Printf import qualified Data.Foldable as F@@ -56,33 +78,7 @@ import qualified Data.Sequence as Seq import qualified Data.ByteString.Short as B --- accelerate-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Array.Sugar ( Elt, eltType )-import qualified Data.Array.Accelerate.Debug as Debug --- accelerate-llvm-import LLVM.AST.Type.Instruction-import LLVM.AST.Type.Metadata-import LLVM.AST.Type.Name-import LLVM.AST.Type.Operand-import LLVM.AST.Type.Representation-import LLVM.AST.Type.Terminator--import Data.Array.Accelerate.LLVM.Target-import Data.Array.Accelerate.LLVM.CodeGen.Downcast-import Data.Array.Accelerate.LLVM.CodeGen.IR-import Data.Array.Accelerate.LLVM.CodeGen.Intrinsic-import Data.Array.Accelerate.LLVM.CodeGen.Module-import Data.Array.Accelerate.LLVM.CodeGen.Type--import Data.Array.Accelerate.LLVM.CodeGen.Sugar ( IROpenAcc(..) )---- llvm-hs-import qualified LLVM.AST as LLVM-import qualified LLVM.AST.Global as LLVM-- -- Code generation -- =============== @@ -105,28 +101,30 @@ , terminator :: LLVM.Terminator -- block terminator } -newtype CodeGen a = CodeGen { runCodeGen :: State CodeGenState a }+newtype CodeGen target a = CodeGen { runCodeGen :: StateT CodeGenState (LLVM target) a } deriving (Functor, Applicative, Monad, MonadState CodeGenState) +liftCodeGen :: LLVM arch a -> CodeGen arch a+liftCodeGen = CodeGen . lift -{-# INLINEABLE runLLVM #-}-runLLVM- :: forall arch aenv a. (Target arch, Intrinsic arch)- => CodeGen (IROpenAcc arch aenv a)- -> Module arch aenv a-runLLVM ll =- let- initialState = CodeGenState++{-# INLINEABLE evalCodeGen #-}+evalCodeGen+ :: forall arch aenv a. (HasCallStack, Target arch, Intrinsic arch)+ => CodeGen arch (IROpenAcc arch aenv a)+ -> LLVM arch (Module arch aenv a)+evalCodeGen ll = do+ (IROpenAcc ks, st) <- runStateT (runCodeGen ll)+ $ CodeGenState { blockChain = initBlockChain , symbolTable = Map.empty , metadataTable = HashMap.empty- , intrinsicTable = intrinsicForTarget (undefined::arch)+ , intrinsicTable = intrinsicForTarget @arch , next = 0 } - (kernels, md, st) = case runState (runCodeGen ll) initialState of- (IROpenAcc ks, s) -> let (fs, as) = unzip [ (f , (LLVM.name f, a)) | Kernel f a <- ks ]- in (fs, Map.fromList as, s)+ let (kernels, md) = let (fs, as) = unzip [ (f , (LLVM.name f, a)) | Kernel f a <- ks ]+ in (fs, Map.fromList as) definitions = map LLVM.GlobalDefinition (kernels ++ Map.elems (symbolTable st)) ++ createMetadata (metadataTable st)@@ -136,16 +134,16 @@ , LLVM.Name s <- LLVM.name f = s | otherwise = "<undefined>" - in- Module { moduleMetadata = md- , unModule = LLVM.Module- { LLVM.moduleName = name- , LLVM.moduleSourceFileName = B.empty- , LLVM.moduleDataLayout = targetDataLayout (undefined::arch)- , LLVM.moduleTargetTriple = targetTriple (undefined::arch)- , LLVM.moduleDefinitions = definitions- }- }+ return $+ Module { moduleMetadata = md+ , unModule = LLVM.Module+ { LLVM.moduleName = name+ , LLVM.moduleSourceFileName = B.empty+ , LLVM.moduleDataLayout = targetDataLayout @arch+ , LLVM.moduleTargetTriple = targetTriple @arch+ , LLVM.moduleDefinitions = definitions+ }+ } -- Basic Blocks@@ -153,10 +151,10 @@ -- | An initial block chain ---initBlockChain :: Seq Block+initBlockChain :: HasCallStack => Seq Block initBlockChain = Seq.singleton- $ Block "entry" Seq.empty ($internalError "entry" "block has no terminator")+ $ Block "entry" Seq.empty (internalError "block has no terminator") -- | Create a new basic block, but don't yet add it to the block chain. You need@@ -185,13 +183,13 @@ -- instructions might be added to the wrong blocks, or the first set of blocks -- will be emitted empty and/or without a terminator. ---newBlock :: String -> CodeGen Block+newBlock :: HasCallStack => String -> CodeGen arch Block newBlock nm = state $ \s -> let idx = Seq.length (blockChain s) label = let (h,t) = break (== '.') nm in (h ++ shows idx t) next = Block (fromString label) Seq.empty err- err = $internalError label "Block has no terminator"+ err = internalError (printf "block `%s' has no terminator" label) in ( next, s ) @@ -199,14 +197,14 @@ -- | Add this block to the block stream. Any instructions pushed onto the stream -- by 'instr' and friends will now apply to this block. ---setBlock :: Block -> CodeGen ()+setBlock :: Block -> CodeGen arch () setBlock next = modify $ \s -> s { blockChain = blockChain s Seq.|> next } -- | Generate a new block and branch unconditionally to it. ---beginBlock :: String -> CodeGen Block+beginBlock :: HasCallStack => String -> CodeGen arch Block beginBlock nm = do next <- newBlock nm _ <- br next@@ -218,7 +216,7 @@ -- body. The block stream is re-initialised, but module-level state such as the -- global symbol table is left intact. ---createBlocks :: CodeGen [LLVM.BasicBlock]+createBlocks :: HasCallStack => CodeGen arch [LLVM.BasicBlock] createBlocks = state $ \s -> let s' = s { blockChain = initBlockChain, next = 0 }@@ -237,17 +235,14 @@ -- | Generate a fresh local reference ---fresh :: forall a. Elt a => CodeGen (IR a)-fresh = IR <$> go (eltType (undefined::a))- where- go :: TupleType t -> CodeGen (Operands t)- go TypeRunit = return OP_Unit- go (TypeRpair t2 t1) = OP_Pair <$> go t2 <*> go t1- go (TypeRscalar t) = ir' t . LocalReference (PrimType (ScalarPrimType t)) <$> freshName+fresh :: TypeR a -> CodeGen arch (Operands a)+fresh TupRunit = return OP_Unit+fresh (TupRpair t2 t1) = OP_Pair <$> fresh t2 <*> fresh t1+fresh (TupRsingle t) = ir t . LocalReference (PrimType (ScalarPrimType t)) <$> freshName -- | Generate a fresh (un)name. ---freshName :: CodeGen (Name a)+freshName :: CodeGen arch (Name a) freshName = state $ \s@CodeGenState{..} -> ( UnName next, s { next = next + 1 } ) @@ -255,10 +250,10 @@ -- computed, and return the operand (LocalReference) that can be used to later -- refer to it. ---instr :: Instruction a -> CodeGen (IR a)+instr :: HasCallStack => Instruction a -> CodeGen arch (Operands a) instr ins = ir (typeOf ins) <$> instr' ins -instr' :: Instruction a -> CodeGen (Operand a)+instr' :: HasCallStack => Instruction a -> CodeGen arch (Operand a) instr' ins = -- LLVM-5 does not allow instructions of type void to have a name. case typeOf ins of@@ -273,79 +268,83 @@ -- | Execute an unnamed instruction ---do_ :: Instruction () -> CodeGen ()+do_ :: HasCallStack => Instruction () -> CodeGen arch () do_ ins = instr_ $ downcast (Do ins) -- | Add raw assembly instructions to the execution stream ---instr_ :: LLVM.Named LLVM.Instruction -> CodeGen ()+instr_ :: HasCallStack => LLVM.Named LLVM.Instruction -> CodeGen arch () instr_ ins = modify $ \s -> case Seq.viewr (blockChain s) of- Seq.EmptyR -> $internalError "instr_" "empty block chain"+ Seq.EmptyR -> internalError "empty block chain" bs Seq.:> b -> s { blockChain = bs Seq.|> b { instructions = instructions b Seq.|> ins } } -- | Return void from a basic block ---return_ :: CodeGen ()+return_ :: HasCallStack => CodeGen arch () return_ = void $ terminate Ret -- | Return a value from a basic block ---retval_ :: Operand a -> CodeGen ()+retval_ :: HasCallStack => Operand a -> CodeGen arch () retval_ x = void $ terminate (RetVal x) -- | Unconditional branch. Return the name of the block that was branched from. ---br :: Block -> CodeGen Block+br :: HasCallStack => Block -> CodeGen arch Block br target = terminate $ Br (blockLabel target) -- | Conditional branch. Return the name of the block that was branched from. ---cbr :: IR Bool -> Block -> Block -> CodeGen Block-cbr cond t f = terminate $ CondBr (op scalarType cond) (blockLabel t) (blockLabel f)+cbr :: HasCallStack => Operands Bool -> Block -> Block -> CodeGen arch Block+cbr (OP_Bool cond) t f = terminate $ CondBr cond (blockLabel t) (blockLabel f) +-- | Switch statement. Return the name of the block that was branched from.+--+switch :: HasCallStack => Operands TAG -> Block -> [(TAG, Block)] -> CodeGen arch Block+switch tag def eqs = terminate $ Switch (op scalarType tag) (blockLabel def) [(ScalarConstant scalarType t, blockLabel b) | (t,b) <- eqs] -- | Add a phi node to the top of the current block ---phi :: forall a. Elt a => [(IR a, Block)] -> CodeGen (IR a)-phi incoming = do- crit <- fresh+phi :: forall arch a. HasCallStack => TypeR a -> [(Operands a, Block)] -> CodeGen arch (Operands a)+phi tp incoming = do+ crit <- fresh tp block <- state $ \s -> case Seq.viewr (blockChain s) of- Seq.EmptyR -> $internalError "phi" "empty block chain"+ Seq.EmptyR -> internalError "empty block chain" _ Seq.:> b -> ( b, s )- phi' block crit incoming+ phi' tp block crit incoming -phi' :: forall a. Elt a => Block -> IR a -> [(IR a, Block)] -> CodeGen (IR a)-phi' target (IR crit) incoming = IR <$> go (eltType (undefined::a)) crit [ (o,b) | (IR o, b) <- incoming ]+phi' :: HasCallStack => TypeR a -> Block -> Operands a -> [(Operands a, Block)] -> CodeGen arch (Operands a)+phi' tp target = go tp where- go :: TupleType t -> Operands t -> [(Operands t, Block)] -> CodeGen (Operands t)- go TypeRunit OP_Unit _+ go :: TypeR t -> Operands t -> [(Operands t, Block)] -> CodeGen arch (Operands t)+ go TupRunit OP_Unit _ = return OP_Unit- go (TypeRpair t2 t1) (OP_Pair n2 n1) inc+ go (TupRpair t2 t1) (OP_Pair n2 n1) inc = OP_Pair <$> go t2 n2 [ (x, b) | (OP_Pair x _, b) <- inc ] <*> go t1 n1 [ (y, b) | (OP_Pair _ y, b) <- inc ]- go (TypeRscalar t) tup inc- | LocalReference _ v <- op' t tup = ir' t <$> phi1 target v [ (op' t x, b) | (x, b) <- inc ]- | otherwise = $internalError "phi" "expected critical variable to be local reference"+ go (TupRsingle t) tup inc+ | LocalReference _ v <- op t tup = ir t <$> phi1 target v [ (op t x, b) | (x, b) <- inc ]+ | otherwise = internalError "expected critical variable to be local reference" -phi1 :: Block -> Name a -> [(Operand a, Block)] -> CodeGen (Operand a)+phi1 :: HasCallStack => Block -> Name a -> [(Operand a, Block)] -> CodeGen arch (Operand a) phi1 target crit incoming = let cmp = (==) `on` blockLabel update b = b { instructions = downcast (crit := Phi t [ (p,blockLabel) | (p,Block{..}) <- incoming ]) Seq.<| instructions b } t = case incoming of- [] -> $internalError "phi" "no incoming values specified"+ [] -> internalError "no incoming values specified" (o,_):_ -> case typeOf o of- VoidType -> $internalError "phi" "operand has void type"+ VoidType -> internalError "operand has void type" PrimType x -> x in state $ \s -> case Seq.findIndexR (cmp target) (blockChain s) of- Nothing -> $internalError "phi" "unknown basic block"+ Nothing -> internalError "unknown basic block" Just i -> ( LocalReference (PrimType t) crit , s { blockChain = Seq.adjust update i (blockChain s) } ) @@ -353,19 +352,19 @@ -- | Add a termination condition to the current instruction stream. Also return -- the block that was just terminated. ---terminate :: Terminator a -> CodeGen Block+terminate :: HasCallStack => Terminator a -> CodeGen arch Block terminate term = state $ \s -> case Seq.viewr (blockChain s) of- Seq.EmptyR -> $internalError "terminate" "empty block chain"+ Seq.EmptyR -> internalError "empty block chain" bs Seq.:> b -> ( b, s { blockChain = bs Seq.|> b { terminator = downcast term } } ) -- | Add a global declaration to the symbol table ---declare :: LLVM.Global -> CodeGen ()+declare :: HasCallStack => LLVM.Global -> CodeGen arch () declare g =- let unique (Just q) | g /= q = $internalError "global" "duplicate symbol"+ let unique (Just q) | g /= q = internalError "duplicate symbol" | otherwise = Just g unique _ = Just g @@ -379,7 +378,7 @@ -- | Get name of the corresponding intrinsic function implementing a given C -- function. If there is no mapping, the C function name is used. ---intrinsic :: ShortByteString -> CodeGen Label+intrinsic :: ShortByteString -> CodeGen arch Label intrinsic key = state $ \s -> let name = HashMap.lookupDefault (Label key) key (intrinsicTable s)@@ -392,7 +391,7 @@ -- | Insert a metadata key/value pair into the current module. ---addMetadata :: ShortByteString -> [Maybe Metadata] -> CodeGen ()+addMetadata :: ShortByteString -> [Maybe Metadata] -> CodeGen arch () addMetadata key val = modify $ \s -> s { metadataTable = HashMap.insertWith (flip (Seq.><)) key (Seq.singleton val) (metadataTable s) }
src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot view
@@ -1,18 +1,19 @@ -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Monad-boot--- 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) -- -module Data.Array.Accelerate.LLVM.CodeGen.Monad (CodeGen)+module Data.Array.Accelerate.LLVM.CodeGen.Monad ( CodeGen ) where import Control.Monad.State+import Data.Array.Accelerate.LLVM.State data CodeGenState-newtype CodeGen a = CodeGen { runCodeGen :: State CodeGenState a }+newtype CodeGen target a = CodeGen { runCodeGen :: StateT CodeGenState (LLVM target) a }
src/Data/Array/Accelerate/LLVM/CodeGen/Permute.hs view
@@ -2,14 +2,15 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.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) --@@ -25,10 +26,13 @@ ) where import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.AST.Var+import Data.Array.Accelerate.Debug+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Trafo.Substitution import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.CodeGen.Environment@@ -44,10 +48,13 @@ import LLVM.AST.Type.Instruction.Atomic import LLVM.AST.Type.Instruction.RMW as RMW import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.Name import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation import Control.Applicative+import Data.Constraint ( withDict )+import System.IO.Unsafe import Prelude @@ -78,26 +85,24 @@ -- llvmOfPermuteFun :: forall arch aenv e. Foreign arch- => arch- -> DelayedFun aenv (e -> e -> e)+ => Fun aenv (e -> e -> e) -> Gamma aenv -> IRPermuteFun arch aenv (e -> e -> e)-llvmOfPermuteFun arch fun aenv = IRPermuteFun{..}+llvmOfPermuteFun fun aenv = IRPermuteFun{..} where- combine = llvmOfFun2 arch fun aenv+ combine = llvmOfFun2 fun aenv atomicRMW -- If the old value is not used (i.e. permute const) then we can just -- store the new value directly. Since we do not require the return value- -- we can do this for any scalar value with a regular Store. This is not- -- possible for product types however since we use an unzipped- -- struct-of-array representation; this requires multiple store- -- instructions so the different fields could get their value from- -- different threads.+ -- we can do this for any scalar value with a regular Store. However,+ -- as we use an unzipped struct-of-array representation for product+ -- types, the multiple store instructions for the different fields+ -- could come from different threads, so we only allow the non-atomic+ -- version if the flag @-ffast-permute-const@ is set. --- | Lam (Lam (Body body)) <- fun- , TypeRscalar{} <- eltType (undefined::e)- , Just body' <- strengthenE latest body- , fun' <- llvmOfFun1 arch (Lam (Body body')) aenv+ | Lam lhs (Lam (LeftHandSideWildcard tp) (Body body)) <- fun+ , True <- fast tp+ , fun' <- llvmOfFun1 (Lam lhs (Body body)) aenv = Just (Exchange, fun') -- LLVM natively supports atomic operations on integral types only.@@ -109,17 +114,26 @@ -- atomic compare-and-swap, which is likely to be more performant than the -- generic spin-lock based approach. --- | Lam (Lam (Body body)) <- fun- , TypeRscalar{} <- eltType (undefined::e)+ | Lam lhs@(LeftHandSideSingle _) (Lam (LeftHandSideSingle _) (Body body)) <- fun , Just (rmw, x) <- rmwOp body , Just x' <- strengthenE latest x- , fun' <- llvmOfFun1 arch (Lam (Body x')) aenv+ , fun' <- llvmOfFun1 (Lam lhs (Body x')) aenv = Just (rmw, fun') | otherwise = Nothing - rmwOp :: DelayedOpenExp (((),e),e) aenv e -> Maybe (RMWOperation, DelayedOpenExp (((),e),e) aenv e)+ fast :: TypeR e -> Bool+ fast tp+ | TupRsingle{} <- tp = True+ | otherwise = unsafePerformIO (getFlag fast_permute_const)++ -- XXX: This doesn't work for newtypes because the coercion gets in the+ -- way. This should be generalised to work for product types (e.g.+ -- complex numbers) and take this factor into account as well.+ -- TLM-2019-09-27+ --+ rmwOp :: OpenExp (((),e),e) aenv e -> Maybe (RMWOperation, OpenExp (((),e),e) aenv e) rmwOp (PrimApp f xs) | PrimAdd{} <- f = (RMW.Add,) <$> extract xs | PrimSub{} <- f = (RMW.Sub,) <$> extract xs@@ -138,10 +152,10 @@ -- In the permutation function, the old value is given as the second -- argument, corresponding to ZeroIdx. --- extract :: DelayedOpenExp (((),e),e) aenv (e,e) -> Maybe (DelayedOpenExp (((),e),e) aenv e)- extract (Tuple (SnocTup (SnocTup NilTup x) y))- | Just Refl <- match x (Var ZeroIdx) = Just y- | Just Refl <- match y (Var ZeroIdx) = Just x+ extract :: OpenExp (((),e),e) aenv (e,e) -> Maybe (OpenExp (((),e),e) aenv e)+ extract (Pair x y)+ | Evar (Var _ ZeroIdx) <- x = Just y+ | Evar (Var _ ZeroIdx) <- y = Just x extract _ = Nothing @@ -171,42 +185,34 @@ -- > } -- atomicCAS_rmw- :: SingleType t- -> (IR t -> CodeGen (IR t))- -> Operand (Ptr t)- -> CodeGen ()+ :: forall arch e. HasCallStack+ => SingleType e+ -> (Operands e -> CodeGen arch (Operands e))+ -> Operand (Ptr e)+ -> CodeGen arch () atomicCAS_rmw t update addr = case t of- NonNumSingleType s -> nonnum s NumSingleType (FloatingNumType f) -> floating f NumSingleType (IntegralNumType i) -> integral i where- nonnum :: NonNumType t -> CodeGen ()- nonnum TypeBool{} = atomicCAS_rmw' t (integralType :: IntegralType Word8) update addr- nonnum TypeChar{} = atomicCAS_rmw' t (integralType :: IntegralType Word32) update addr- nonnum TypeCChar{} = atomicCAS_rmw' t (integralType :: IntegralType Word8) update addr- nonnum TypeCSChar{} = atomicCAS_rmw' t (integralType :: IntegralType Word8) update addr- nonnum TypeCUChar{} = atomicCAS_rmw' t (integralType :: IntegralType Word8) update addr-- floating :: FloatingType t -> CodeGen ()- floating TypeHalf{} = atomicCAS_rmw' t (integralType :: IntegralType Word16) update addr- floating TypeFloat{} = atomicCAS_rmw' t (integralType :: IntegralType Word32) update addr- floating TypeDouble{} = atomicCAS_rmw' t (integralType :: IntegralType Word64) update addr- floating TypeCFloat{} = atomicCAS_rmw' t (integralType :: IntegralType Word32) update addr- floating TypeCDouble{} = atomicCAS_rmw' t (integralType :: IntegralType Word64) update addr+ floating :: FloatingType t -> CodeGen arch ()+ floating TypeHalf{} = atomicCAS_rmw' t (integralType :: IntegralType Word16) update addr+ floating TypeFloat{} = atomicCAS_rmw' t (integralType :: IntegralType Word32) update addr+ floating TypeDouble{} = atomicCAS_rmw' t (integralType :: IntegralType Word64) update addr - integral :: IntegralType t -> CodeGen ()- integral i = atomicCAS_rmw' t i update addr+ integral :: IntegralType t -> CodeGen arch ()+ integral i = atomicCAS_rmw' t i update addr atomicCAS_rmw'- :: SingleType t+ :: HasCallStack+ => SingleType t -> IntegralType i- -> (IR t -> CodeGen (IR t))+ -> (Operands t -> CodeGen arch (Operands t)) -> Operand (Ptr t)- -> CodeGen ()-atomicCAS_rmw' t i update addr | EltDict <- integralElt i = do+ -> CodeGen arch ()+atomicCAS_rmw' t i update addr = withDict (integralElt i) $ do let si = SingleScalarType (NumSingleType (IntegralNumType i)) -- spin <- newBlock "rmw.spin"@@ -214,7 +220,7 @@ addr' <- instr' $ PtrCast (PtrPrimType (ScalarPrimType si) defaultAddrSpace) addr init' <- instr' $ Load si NonVolatile addr'- old' <- fresh+ old' <- fresh $ TupRsingle si top <- br spin setBlock spin@@ -222,12 +228,20 @@ val <- update $ ir t old val' <- instr' $ BitCast si (op t val) r <- instr' $ CmpXchg i NonVolatile addr' (op i old') val' (CrossThread, AcquireRelease) Monotonic- done <- instr' $ ExtractValue scalarType ZeroTupIdx r- next' <- instr' $ ExtractValue si (SuccTupIdx ZeroTupIdx) r+ done <- instr' $ ExtractValue scalarType PairIdxRight r+ next' <- instr' $ ExtractValue si PairIdxLeft r - bot <- cbr (ir scalarType done) exit spin- _ <- phi' spin old' [(ir i init',top), (ir i next',bot)]+ -- Since we removed Bool from the set of primitive types Accelerate+ -- supports, we have to do a small hack to have LLVM consider this as its+ -- correct type of a 1-bit integer (rather than the 8-bits it is actually+ -- stored as)+ done' <- case done of+ LocalReference _ (UnName n) -> return $ OP_Bool (LocalReference type' (UnName n))+ _ -> internalError "expected unnamed local reference" + bot <- cbr done' exit spin+ _ <- phi' (TupRsingle si) spin old' [(ir i init',top), (ir i next',bot)]+ setBlock exit @@ -255,44 +269,36 @@ -- address. -- atomicCAS_cmp- :: SingleType t- -> (SingleType t -> IR t -> IR t -> CodeGen (IR Bool))- -> Operand (Ptr t)- -> Operand t- -> CodeGen ()+ :: forall arch e. HasCallStack+ => SingleType e+ -> (SingleType e -> Operands e -> Operands e -> CodeGen arch (Operands Bool))+ -> Operand (Ptr e)+ -> Operand e+ -> CodeGen arch () atomicCAS_cmp t cmp addr val = case t of- NonNumSingleType s -> nonnum s NumSingleType (FloatingNumType f) -> floating f NumSingleType (IntegralNumType i) -> integral i where- nonnum :: NonNumType t -> CodeGen ()- nonnum TypeBool{} = atomicCAS_cmp' t (integralType :: IntegralType Word8) cmp addr val- nonnum TypeChar{} = atomicCAS_cmp' t (integralType :: IntegralType Word32) cmp addr val- nonnum TypeCChar{} = atomicCAS_cmp' t (integralType :: IntegralType Word8) cmp addr val- nonnum TypeCSChar{} = atomicCAS_cmp' t (integralType :: IntegralType Word8) cmp addr val- nonnum TypeCUChar{} = atomicCAS_cmp' t (integralType :: IntegralType Word8) cmp addr val-- floating :: FloatingType t -> CodeGen ()- floating TypeHalf{} = atomicCAS_cmp' t (integralType :: IntegralType Word16) cmp addr val- floating TypeFloat{} = atomicCAS_cmp' t (integralType :: IntegralType Word32) cmp addr val- floating TypeDouble{} = atomicCAS_cmp' t (integralType :: IntegralType Word64) cmp addr val- floating TypeCFloat{} = atomicCAS_cmp' t (integralType :: IntegralType Word32) cmp addr val- floating TypeCDouble{} = atomicCAS_cmp' t (integralType :: IntegralType Word64) cmp addr val+ floating :: FloatingType t -> CodeGen arch ()+ floating TypeHalf{} = atomicCAS_cmp' t (integralType :: IntegralType Word16) cmp addr val+ floating TypeFloat{} = atomicCAS_cmp' t (integralType :: IntegralType Word32) cmp addr val+ floating TypeDouble{} = atomicCAS_cmp' t (integralType :: IntegralType Word64) cmp addr val - integral :: IntegralType t -> CodeGen ()- integral i = atomicCAS_cmp' t i cmp addr val+ integral :: IntegralType t -> CodeGen arch ()+ integral i = atomicCAS_cmp' t i cmp addr val atomicCAS_cmp'- :: SingleType t -- actual type of elements+ :: HasCallStack+ => SingleType t -- actual type of elements -> IntegralType i -- unsigned integral type of same bit size as 't'- -> (SingleType t -> IR t -> IR t -> CodeGen (IR Bool))+ -> (SingleType t -> Operands t -> Operands t -> CodeGen arch (Operands Bool)) -> Operand (Ptr t) -> Operand t- -> CodeGen ()-atomicCAS_cmp' t i cmp addr val | EltDict <- singleElt t = do+ -> CodeGen arch ()+atomicCAS_cmp' t i cmp addr val = withDict (singleElt t) $ do let si = SingleScalarType (NumSingleType (IntegralNumType i)) -- test <- newBlock "cas.cmp"@@ -302,7 +308,7 @@ -- The new value and address to swap cast to integral type addr' <- instr' $ PtrCast (PtrPrimType (ScalarPrimType si) defaultAddrSpace) addr val' <- instr' $ BitCast si val- old <- fresh+ old <- fresh $ TupRsingle $ SingleScalarType t -- Read the current value at the address start <- instr' $ Load (SingleScalarType t) NonVolatile addr@@ -322,12 +328,16 @@ setBlock spin old' <- instr' $ BitCast si (op t old) r <- instr' $ CmpXchg i NonVolatile addr' old' val' (CrossThread, AcquireRelease) Monotonic- done <- instr' $ ExtractValue scalarType ZeroTupIdx r- next <- instr' $ ExtractValue si (SuccTupIdx ZeroTupIdx) r+ done <- instr' $ ExtractValue scalarType PairIdxRight r+ next <- instr' $ ExtractValue si PairIdxLeft r next' <- instr' $ BitCast (SingleScalarType t) next - bot <- cbr (ir scalarType done) exit test- _ <- phi' test old [(ir t start,top), (ir t next',bot)]+ done' <- case done of+ LocalReference _ (UnName n) -> return $ OP_Bool (LocalReference type' (UnName n))+ _ -> internalError "expected unnamed local reference"++ bot <- cbr done' exit test+ _ <- phi' (TupRsingle $ SingleScalarType t) test old [(ir t start,top), (ir t next',bot)] setBlock exit
src/Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Ptr--- 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) --@@ -26,11 +25,11 @@ -- Treat an operand as a Ptr type. This is a hack because we can't unpack IR -- terms of pointer type. ---asPtr :: AddrSpace -> Operand t -> Operand (Ptr t)+asPtr :: HasCallStack => AddrSpace -> Operand t -> Operand (Ptr t) asPtr as x = let retype :: Type a -> Type (Ptr a)- retype VoidType = $internalError "asPtr" "unexpected void type"+ retype VoidType = internalError "unexpected void type" retype (PrimType t) = PrimType (PtrPrimType t as) -- rename :: Name a -> Name (Ptr a)@@ -41,17 +40,17 @@ LocalReference t n -> LocalReference (retype t) (rename n) ConstantOperand (GlobalReference t n) -> ConstantOperand (GlobalReference (retype t) (rename n)) ConstantOperand (UndefConstant t) -> ConstantOperand (UndefConstant (retype t))- ConstantOperand ScalarConstant{} -> $internalError "asPtr" "unexpected scalar constant"+ ConstantOperand _ -> internalError "unexpected constant operand" -- Treat a pointer operand as a scalar. This is a hack because we can't unpack -- IR terms of pointer types. ---unPtr :: Operand (Ptr t) -> Operand t+unPtr :: HasCallStack => Operand (Ptr t) -> Operand t unPtr x = let retype :: Type (Ptr a) -> Type a retype (PrimType (PtrPrimType t _)) = PrimType t- retype _ = $internalError "unPtr" "expected pointer type"+ retype _ = internalError "expected pointer type" -- rename :: Name (Ptr a) -> Name a rename (Name n) = Name n@@ -61,5 +60,5 @@ LocalReference t n -> LocalReference (retype t) (rename n) ConstantOperand (GlobalReference t n) -> ConstantOperand (GlobalReference (retype t) (rename n)) ConstantOperand (UndefConstant t) -> ConstantOperand (UndefConstant (retype t))- ConstantOperand ScalarConstant{} -> $internalError "unPtr" "unexpected scalar constant"+ ConstantOperand ScalarConstant{} -> internalError "unexpected scalar constant"
src/Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs view
@@ -5,10 +5,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Skeleton--- 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) --@@ -19,11 +19,11 @@ ) where -import Prelude hiding ( id )---- accelerate-import Data.Array.Accelerate.AST hiding ( Val(..), PreBoundary(..), prj, stencil )-import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.AST+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.Environment@@ -33,176 +33,117 @@ import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Compile.Cache +import Prelude hiding ( id ) + -- | A class covering code generation for all of the primitive array operations. -- Client backends implement an instance of this class. ----- Minimal complete definition:--- * generate--- * fold, fold1, foldSeg, fold1Seg--- * scanl, scanl', scanl1, scanr, scanr', scanr1--- * permute--- class Skeleton arch where- {-# MINIMAL generate, fold, fold1, foldSeg, fold1Seg, scanl, scanl', scanl1,- scanr, scanr', scanr1, permute #-}-- generate :: (Shape sh, Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun1 arch aenv (sh -> e)- -> CodeGen (IROpenAcc arch aenv (Array sh e))-- transform :: (Shape sh, Shape sh', Elt a, Elt b)- => arch- -> UID- -> Gamma aenv- -> IRFun1 arch aenv (sh' -> sh)- -> IRFun1 arch aenv (a -> b)- -> IRDelayed arch aenv (Array sh a)- -> CodeGen (IROpenAcc arch aenv (Array sh' b))-- map :: (Shape sh, Elt a, Elt b)- => arch- -> UID- -> Gamma aenv- -> IRFun1 arch aenv (a -> b)- -> IRDelayed arch aenv (Array sh a)- -> CodeGen (IROpenAcc arch aenv (Array sh b))-- fold :: (Shape sh, Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRExp arch aenv e- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> CodeGen (IROpenAcc arch aenv (Array sh e))-- fold1 :: (Shape sh, Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> CodeGen (IROpenAcc arch aenv (Array sh e))-- foldSeg :: (Shape sh, Elt e, Elt i, IsIntegral i)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRExp arch aenv e- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> IRDelayed arch aenv (Segments i)- -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))+ {-# MINIMAL generate, transform+ , fold , foldSeg+ , scan, scan'+ , permute+ , stencil1, stencil2 #-} - fold1Seg :: (Shape sh, Elt e, Elt i, IsIntegral i)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> IRDelayed arch aenv (Segments i)- -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))+ generate :: UID+ -> Gamma aenv+ -> ArrayR (Array sh e)+ -> IRFun1 arch aenv (sh -> e)+ -> CodeGen arch (IROpenAcc arch aenv (Array sh e)) - scanl :: (Shape sh, Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRExp arch aenv e- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))+ transform :: UID+ -> Gamma aenv+ -> ArrayR (Array sh a)+ -> ArrayR (Array sh' b)+ -> IRFun1 arch aenv (sh' -> sh)+ -> IRFun1 arch aenv (a -> b)+ -> CodeGen arch (IROpenAcc arch aenv (Array sh' b)) - scanl' :: (Shape sh, Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRExp arch aenv e- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e, Array sh e))+ map :: UID+ -> Gamma aenv+ -> ArrayR (Array sh a)+ -> TypeR b+ -> IRFun1 arch aenv (a -> b)+ -> CodeGen arch (IROpenAcc arch aenv (Array sh b)) - scanl1 :: (Shape sh, Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))+ fold :: UID+ -> Gamma aenv+ -> ArrayR (Array sh e)+ -> IRFun2 arch aenv (e -> e -> e)+ -> Maybe (IRExp arch aenv e)+ -> MIRDelayed arch aenv (Array (sh, Int) e)+ -> CodeGen arch (IROpenAcc arch aenv (Array sh e)) - scanr :: (Shape sh, Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRExp arch aenv e- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))+ foldSeg :: UID+ -> Gamma aenv+ -> ArrayR (Array (sh, Int) e)+ -> IntegralType i+ -> IRFun2 arch aenv (e -> e -> e)+ -> Maybe (IRExp arch aenv e)+ -> MIRDelayed arch aenv (Array (sh, Int) e)+ -> MIRDelayed arch aenv (Segments i)+ -> CodeGen arch (IROpenAcc arch aenv (Array (sh, Int) e)) - scanr' :: (Shape sh, Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRExp arch aenv e- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e, Array sh e))+ scan :: UID+ -> Gamma aenv+ -> ArrayR (Array (sh, Int) e)+ -> Direction+ -> IRFun2 arch aenv (e -> e -> e)+ -> Maybe (IRExp arch aenv e)+ -> MIRDelayed arch aenv (Array (sh, Int) e)+ -> CodeGen arch (IROpenAcc arch aenv (Array (sh, Int) e)) - scanr1 :: (Shape sh, Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (e -> e -> e)- -> IRDelayed arch aenv (Array (sh:.Int) e)- -> CodeGen (IROpenAcc arch aenv (Array (sh:.Int) e))+ scan' :: UID+ -> Gamma aenv+ -> ArrayR (Array (sh, Int) e)+ -> Direction+ -> IRFun2 arch aenv (e -> e -> e)+ -> IRExp arch aenv e+ -> MIRDelayed arch aenv (Array (sh, Int) e)+ -> CodeGen arch (IROpenAcc arch aenv (Array (sh, Int) e, Array sh e)) - permute :: (Shape sh, Shape sh', Elt e)- => arch- -> UID+ permute :: UID -> Gamma aenv+ -> ArrayR (Array sh e)+ -> ShapeR sh' -> IRPermuteFun arch aenv (e -> e -> e)- -> IRFun1 arch aenv (sh -> sh')- -> IRDelayed arch aenv (Array sh e)- -> CodeGen (IROpenAcc arch aenv (Array sh' e))+ -> IRFun1 arch aenv (sh -> PrimMaybe sh')+ -> MIRDelayed arch aenv (Array sh e)+ -> CodeGen arch (IROpenAcc arch aenv (Array sh' e)) - backpermute :: (Shape sh, Shape sh', Elt e)- => arch- -> UID+ backpermute :: UID -> Gamma aenv+ -> ArrayR (Array sh e)+ -> ShapeR sh' -> IRFun1 arch aenv (sh' -> sh)- -> IRDelayed arch aenv (Array sh e)- -> CodeGen (IROpenAcc arch aenv (Array sh' e))+ -> CodeGen arch (IROpenAcc arch aenv (Array sh' e)) - stencil :: (Stencil sh a stencil, Elt b)- => arch- -> UID+ stencil1 :: UID -> Gamma aenv- -> IRFun1 arch aenv (stencil -> b)+ -> StencilR sh a stencil+ -> TypeR b+ -> IRFun1 arch aenv (stencil -> b) -> IRBoundary arch aenv (Array sh a)- -> IRDelayed arch aenv (Array sh a)- -> CodeGen (IROpenAcc arch aenv (Array sh b))+ -> MIRDelayed arch aenv (Array sh a)+ -> CodeGen arch (IROpenAcc arch aenv (Array sh b)) - stencil2 :: (Stencil sh a stencil1, Stencil sh b stencil2, Elt c)- => arch- -> UID+ stencil2 :: UID -> Gamma aenv+ -> StencilR sh a stencil1+ -> StencilR sh b stencil2+ -> TypeR c -> IRFun2 arch aenv (stencil1 -> stencil2 -> c) -> IRBoundary arch aenv (Array sh a)- -> IRDelayed arch aenv (Array sh a)+ -> MIRDelayed arch aenv (Array sh a) -> IRBoundary arch aenv (Array sh b)- -> IRDelayed arch aenv (Array sh b)- -> CodeGen (IROpenAcc arch aenv (Array sh c))+ -> MIRDelayed arch aenv (Array sh b)+ -> CodeGen arch (IROpenAcc arch aenv (Array sh c)) -- Default instances -- ----------------- map = defaultMap backpermute = defaultBackpermute- transform = defaultTransform- stencil = defaultStencil1- stencil2 = defaultStencil2 {-# INLINE id #-}@@ -211,74 +152,25 @@ {-# INLINEABLE defaultMap #-} defaultMap- :: (Skeleton arch, Shape sh, Elt a, Elt b)- => arch- -> UID- -> Gamma aenv- -> IRFun1 arch aenv (a -> b)- -> IRDelayed arch aenv (Array sh a)- -> CodeGen (IROpenAcc arch aenv (Array sh b))-defaultMap arch uid aenv f a- = transform arch uid aenv id f a+ :: Skeleton arch+ => UID+ -> Gamma aenv+ -> ArrayR (Array sh a)+ -> TypeR b+ -> IRFun1 arch aenv (a -> b)+ -> CodeGen arch (IROpenAcc arch aenv (Array sh b))+defaultMap uid aenv repr@(ArrayR shr _) tp f+ = transform uid aenv repr (ArrayR shr tp) id f {-# INLINEABLE defaultBackpermute #-} defaultBackpermute- :: (Skeleton arch, Shape sh, Shape sh', Elt e)- => arch- -> UID- -> Gamma aenv- -> IRFun1 arch aenv (sh' -> sh)- -> IRDelayed arch aenv (Array sh e)- -> CodeGen (IROpenAcc arch aenv (Array sh' e))-defaultBackpermute arch uid aenv p a- = transform arch uid aenv p id a--{-# INLINEABLE defaultTransform #-}-defaultTransform- :: (Skeleton arch, Shape sh', Elt b)- => arch- -> UID+ :: Skeleton arch+ => UID -> Gamma aenv+ -> ArrayR (Array sh e)+ -> ShapeR sh' -> IRFun1 arch aenv (sh' -> sh)- -> IRFun1 arch aenv (a -> b)- -> IRDelayed arch aenv (Array sh a)- -> CodeGen (IROpenAcc arch aenv (Array sh' b))-defaultTransform arch uid aenv p f IRDelayed{..}- = generate arch uid aenv . IRFun1 $ \ix -> do- ix' <- app1 p ix- a <- app1 delayedIndex ix'- app1 f a--{-# INLINEABLE defaultStencil1 #-}-defaultStencil1- :: (Skeleton arch, Stencil sh a stencil, Elt b)- => arch- -> UID- -> Gamma aenv- -> IRFun1 arch aenv (stencil -> b)- -> IRBoundary arch aenv (Array sh a)- -> IRDelayed arch aenv (Array sh a)- -> CodeGen (IROpenAcc arch aenv (Array sh b))-defaultStencil1 arch uid aenv f boundary arr- = generate arch uid aenv . IRFun1 $ \ix -> do- sten <- stencilAccess boundary arr ix- app1 f sten--{-# INLINEABLE defaultStencil2 #-}-defaultStencil2- :: (Skeleton arch, Stencil sh a stencil1, Stencil sh b stencil2, Elt c)- => arch- -> UID- -> Gamma aenv- -> IRFun2 arch aenv (stencil1 -> stencil2 -> c)- -> IRBoundary arch aenv (Array sh a)- -> IRDelayed arch aenv (Array sh a)- -> IRBoundary arch aenv (Array sh b)- -> IRDelayed arch aenv (Array sh b)- -> CodeGen (IROpenAcc arch aenv (Array sh c))-defaultStencil2 arch uid aenv f boundary1 arr1 boundary2 arr2- = generate arch uid aenv . IRFun1 $ \ix -> do- sten1 <- stencilAccess boundary1 arr1 ix- sten2 <- stencilAccess boundary2 arr2 ix- app2 f sten1 sten2+ -> CodeGen arch (IROpenAcc arch aenv (Array sh' e))+defaultBackpermute uid aenv repr@(ArrayR _ tp) shr p+ = transform uid aenv repr (ArrayR shr tp) p id
src/Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs view
@@ -3,14 +3,15 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Stencil--- 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) --@@ -18,40 +19,57 @@ module Data.Array.Accelerate.LLVM.CodeGen.Stencil where --- accelerate-import Data.Array.Accelerate.AST hiding ( Val(..), PreBoundary(..), prj )-import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Sugar-import Data.Array.Accelerate.Type import Data.Array.Accelerate.Error+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 ( ifThenElse )+import Data.Array.Accelerate.LLVM.CodeGen.Arithmetic ( ifThenElse ) import Data.Array.Accelerate.LLVM.CodeGen.Constant import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Monad import Data.Array.Accelerate.LLVM.CodeGen.Sugar-import qualified Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A+import qualified Data.Array.Accelerate.LLVM.CodeGen.Arithmetic as A import Control.Applicative import Prelude +-- Stencil boundary conditions+--+data IRBoundary arch aenv t where+ IRClamp :: IRBoundary arch aenv t+ IRMirror :: IRBoundary arch aenv t+ IRWrap :: IRBoundary arch aenv t+ IRConstant :: Operands e -> IRBoundary arch aenv (Array sh e)+ IRFunction :: IRFun1 arch aenv (sh -> e) -> IRBoundary arch aenv (Array sh e)++ -- Generate the stencil pattern including boundary conditions -- stencilAccess- :: Stencil sh e stencil- => IRBoundary arch aenv (Array sh e)- -> IRDelayed arch aenv (Array sh e)- -> IR sh- -> CodeGen (IR stencil)-stencilAccess bndy arr = goR stencil (bounded bndy arr)+ :: HasCallStack+ => StencilR sh e stencil+ -> Maybe (IRBoundary arch aenv (Array sh e))+ -> IRDelayed arch aenv (Array sh e)+ -> Operands sh+ -> IRExp arch aenv stencil+stencilAccess sR mbndy arr =+ case mbndy of+ Nothing -> goR sR (inbounds arr)+ Just bndy -> goR sR (bounded bndy arr) where -- Base cases, nothing interesting to do here since we know the lower -- dimension is Z. --- goR :: StencilR sh e stencil -> (IR sh -> CodeGen (IR e)) -> IR sh -> CodeGen (IR stencil)- goR StencilRunit3 rf ix- = let z :. i = unindex ix+ goR :: StencilR sh e stencil+ -> (Operands sh -> IRExp arch aenv e)+ -> Operands sh+ -> IRExp arch aenv stencil+ goR (StencilRunit3 _) rf ix+ = let (z, i) = unindex ix rf' d = do d' <- A.add numType i (int d) rf (index z d') in@@ -59,8 +77,8 @@ <*> rf ix <*> rf' 1 - goR StencilRunit5 rf ix- = let z :. i = unindex ix+ goR (StencilRunit5 _) rf ix+ = let (z, i) = unindex ix rf' d = do d' <- A.add numType i (int d) rf (index z d') in@@ -70,8 +88,8 @@ <*> rf' 1 <*> rf' 2 - goR StencilRunit7 rf ix- = let z :. i = unindex ix+ goR (StencilRunit7 _) rf ix+ = let (z, i) = unindex ix rf' d = do d' <- A.add numType i (int d) rf (index z d') in@@ -83,8 +101,8 @@ <*> rf' 2 <*> rf' 3 - goR StencilRunit9 rf ix- = let z :. i = unindex ix+ goR (StencilRunit9 _) rf ix+ = let (z, i) = unindex ix rf' d = do d' <- A.add numType i (int d) rf (index z d') in@@ -104,20 +122,22 @@ -- _left-most_ index component -- goR (StencilRtup3 s1 s2 s3) rf ix =- let (i, ix') = uncons ix- rf' 0 ds = rf (cons i ds)+ let shr = stencilShapeR s1+ (i, ix') = uncons shr ix+ rf' 0 ds = rf (cons shr i ds) rf' d ds = do d' <- A.add numType i (int d)- rf (cons d' ds)+ rf (cons shr d' ds) in tup3 <$> goR s1 (rf' (-1)) ix' <*> goR s2 (rf' 0) ix' <*> goR s3 (rf' 1) ix' goR (StencilRtup5 s1 s2 s3 s4 s5) rf ix =- let (i, ix') = uncons ix- rf' 0 ds = rf (cons i ds)+ let shr = stencilShapeR s1+ (i, ix') = uncons shr ix+ rf' 0 ds = rf (cons shr i ds) rf' d ds = do d' <- A.add numType i (int d)- rf (cons d' ds)+ rf (cons shr d' ds) in tup5 <$> goR s1 (rf' (-2)) ix' <*> goR s2 (rf' (-1)) ix'@@ -126,10 +146,11 @@ <*> goR s5 (rf' 2) ix' goR (StencilRtup7 s1 s2 s3 s4 s5 s6 s7) rf ix =- let (i, ix') = uncons ix- rf' 0 ds = rf (cons i ds)+ let shr = stencilShapeR s1+ (i, ix') = uncons shr ix+ rf' 0 ds = rf (cons shr i ds) rf' d ds = do d' <- A.add numType i (int d)- rf (cons d' ds)+ rf (cons shr d' ds) in tup7 <$> goR s1 (rf' (-3)) ix' <*> goR s2 (rf' (-2)) ix'@@ -140,10 +161,11 @@ <*> goR s7 (rf' 3) ix' goR (StencilRtup9 s1 s2 s3 s4 s5 s6 s7 s8 s9) rf ix =- let (i, ix') = uncons ix- rf' 0 ds = rf (cons i ds)+ let shr = stencilShapeR s1+ (i, ix') = uncons shr ix+ rf' 0 ds = rf (cons shr i ds) rf' d ds = do d' <- A.add numType i (int d)- rf (cons d' ds)+ rf (cons shr d' ds) in tup9 <$> goR s1 (rf' (-4)) ix' <*> goR s2 (rf' (-3)) ix'@@ -156,27 +178,40 @@ <*> goR s9 (rf' 4) ix' +-- Do not apply any boundary conditions to the given index+--+inbounds+ :: IRDelayed arch aenv (Array sh e)+ -> Operands sh+ -> IRExp arch aenv e+inbounds IRDelayed{..} ix =+ app1 delayedIndex ix++ -- Apply boundary conditions to the given index -- bounded- :: (Shape sh, Elt e)+ :: forall sh e arch aenv. HasCallStack => IRBoundary arch aenv (Array sh e) -> IRDelayed arch aenv (Array sh e)- -> IR sh- -> CodeGen (IR e)+ -> Operands sh+ -> IRExp arch aenv e bounded bndy IRDelayed{..} ix = do+ let+ tp :: TypeR e -- GHC 8.4 needs this type annotation+ ArrayR shr tp = delayedRepr sh <- delayedExtent case bndy of IRConstant v ->- if inside sh ix+ if ( tp, inside shr sh ix ) then app1 delayedIndex ix else return v IRFunction f ->- if inside sh ix+ if ( tp, inside shr sh ix ) then app1 delayedIndex ix else app1 f ix _ -> do- ix' <- bound sh ix+ ix' <- bound shr sh ix v <- app1 delayedIndex ix' return v --@@ -184,127 +219,106 @@ -- Return the index, updated to obey the given boundary conditions (clamp, -- mirror, or wrap only). --- bound :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR sh)- bound (IR extent1) (IR extent2) = IR <$> go (eltType (undefined::sh)) extent1 extent2- where- go :: TupleType t -> Operands t -> Operands t -> CodeGen (Operands t)- go TypeRunit OP_Unit OP_Unit- = return OP_Unit- go (TypeRpair tsh ti) (OP_Pair sh sz) (OP_Pair ih iz)- = do- ix' <- go tsh sh ih- i' <- go ti sz iz- return $ OP_Pair ix' i'- go (TypeRscalar t) sz iz- | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)- = do- IR i' <- if A.lt (singleType :: SingleType Int) (IR iz) (int 0)+ bound :: ShapeR sh' -> Operands sh' -> Operands sh' -> CodeGen arch (Operands sh')+ bound ShapeRz OP_Unit OP_Unit+ = return OP_Unit+ bound (ShapeRsnoc shr') (OP_Pair sh sz) (OP_Pair ih iz)+ = do+ ix' <- bound shr' sh ih+ i' <- if ( TupRsingle scalarTypeInt+ , A.lt (singleType :: SingleType Int) iz (int 0))+ then+ case bndy of+ IRClamp -> return (int 0)+ IRMirror -> A.negate numType iz+ IRWrap -> A.add numType sz iz+ _ -> internalError "unexpected boundary condition"+ else+ if ( TupRsingle scalarTypeInt+ , A.gte (singleType :: SingleType Int) iz sz) then case bndy of- IRClamp -> return (int 0)- IRMirror -> A.negate numType (IR iz)- IRWrap -> A.add numType (IR sz) (IR iz)- _ -> $internalError "bound" "unexpected boundary condition"+ IRClamp -> A.sub numType sz (int 1)+ IRWrap -> A.sub numType iz sz+ IRMirror -> do+ a <- A.sub numType iz sz+ b <- A.add numType a (int 2)+ c <- A.sub numType sz b+ return c+ _ -> internalError "unexpected boundary condition" else- if A.gte (singleType :: SingleType Int) (IR iz) (IR sz)- then- case bndy of- IRClamp -> A.sub numType (IR sz) (int 1)- IRWrap -> A.sub numType (IR iz) (IR sz)- IRMirror -> do- a <- A.sub numType (IR iz) (IR sz)- b <- A.add numType a (int 2)- c <- A.sub numType (IR sz) b- return c- _ -> $internalError "bound" "unexpected boundary condition"- else- return (IR iz)- return i'- | otherwise- = $internalError "bound" "expected shape with Int components"+ return iz+ return $ OP_Pair ix' i' -- Return whether the index is inside the bounds of the given shape --- inside :: forall sh. Shape sh => IR sh -> IR sh -> CodeGen (IR Bool)- inside (IR extent1) (IR extent2) = go (eltType (undefined::sh)) extent1 extent2- where- go :: TupleType t -> Operands t -> Operands t -> CodeGen (IR Bool)- go TypeRunit OP_Unit OP_Unit- = return (bool True)- go (TypeRpair tsh ti) (OP_Pair sh sz) (OP_Pair ih iz)- = if go ti sz iz- then go tsh sh ih- else return (bool False)- go (TypeRscalar t) sz iz- | Just Refl <- matchScalarType t (scalarType :: ScalarType Int)- = if A.lt (singleType :: SingleType Int) (IR iz) (int 0) `A.lor`- A.gte (singleType :: SingleType Int) (IR iz) (IR sz)- then return (bool False)- else return (bool True)- --- | otherwise- = $internalError "bound" "expected shape with Int components"+ inside :: ShapeR sh' -> Operands sh' -> Operands sh' -> CodeGen arch (Operands Bool)+ inside ShapeRz OP_Unit OP_Unit+ = return (bool True)+ inside (ShapeRsnoc shr') (OP_Pair sh sz) (OP_Pair ih iz)+ = do+ ifNext <- newBlock "inside.next"+ ifExit <- newBlock "inside.exit" + _ <- beginBlock "inside.entry"+ p <- A.lt (singleType :: SingleType Int) iz (int 0) `A.lor'`+ A.gte (singleType :: SingleType Int) iz sz+ eb <- cbr p ifExit ifNext + setBlock ifNext+ nv <- inside shr' sh ih+ nb <- br ifExit++ setBlock ifExit+ crit <- freshName+ r <- phi1 ifExit crit [(boolean False, eb), (A.unbool nv, nb)]++ return (OP_Bool r)++ -- Utilities -- --------- -int :: Int -> IR Int-int x = IR (constant (eltType (undefined::Int)) x)+int :: Int -> Operands Int+int x = constant (TupRsingle scalarTypeInt) x -bool :: Bool -> IR Bool-bool b = IR (constant (eltType (undefined::Bool)) b)+bool :: Bool -> Operands Bool+bool = OP_Bool . boolean -unindex :: IR (sh :. Int) -> IR sh :. IR Int-unindex (IR (OP_Pair sh i)) = IR sh :. IR i+unindex :: Operands (sh, Int) -> (Operands sh, Operands Int)+unindex (OP_Pair sh i) = (sh, i) -index :: IR sh -> IR Int -> IR (sh :. Int)-index (IR sh) (IR i) = IR (OP_Pair sh i)+index :: Operands sh -> Operands Int -> Operands (sh, Int)+index sh i = OP_Pair sh i -tup3 :: IR a -> IR b -> IR c -> IR (a,b,c)-tup3 (IR a) (IR b) (IR c) = IR $ OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c+tup3 :: Operands a -> Operands b -> Operands c -> Operands (Tup3 a b c)+tup3 a b c = OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c -tup5 :: IR a -> IR b -> IR c -> IR d -> IR e -> IR (a,b,c,d,e)-tup5 (IR a) (IR b) (IR c) (IR d) (IR e) =- IR $ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e+tup5 :: Operands a -> Operands b -> Operands c -> Operands d -> Operands e -> Operands (Tup5 a b c d e)+tup5 a b c d e =+ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e -tup7 :: IR a -> IR b -> IR c -> IR d -> IR e -> IR f -> IR g -> IR (a,b,c,d,e,f,g)-tup7 (IR a) (IR b) (IR c) (IR d) (IR e) (IR f) (IR g) =- IR $ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e) f) g+tup7 :: Operands a -> Operands b -> Operands c -> Operands d -> Operands e -> Operands f -> Operands g -> Operands (Tup7 a b c d e f g)+tup7 a b c d e f g =+ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e) f) g -tup9 :: IR a -> IR b -> IR c -> IR d -> IR e -> IR f -> IR g -> IR h -> IR i -> IR (a,b,c,d,e,f,g,h,i)-tup9 (IR a) (IR b) (IR c) (IR d) (IR e) (IR f) (IR g) (IR h) (IR i) =- IR $ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e) f) g) h) i+tup9 :: Operands a -> Operands b -> Operands c -> Operands d -> Operands e -> Operands f -> Operands g -> Operands h -> Operands i -> Operands (Tup9 a b c d e f g h i)+tup9 a b c d e f g h i =+ OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair (OP_Pair OP_Unit a) b) c) d) e) f) g) h) i -- Add a _left-most_ dimension to a shape ---cons :: forall sh. Shape sh => IR Int -> IR sh -> IR (sh :. Int)-cons (IR ix) (IR extent) = IR $ go (eltType (undefined::sh)) extent- where- go :: TupleType t -> Operands t -> Operands (t,Int)- go TypeRunit OP_Unit = OP_Pair OP_Unit ix- go (TypeRpair th tz) (OP_Pair sh sz)- | TypeRscalar t <- tz- , Just Refl <- matchScalarType t (scalarType :: ScalarType Int)- = OP_Pair (go th sh) sz- go _ _- = $internalError "cons" "expected shape with Int components"+cons :: ShapeR sh -> Operands Int -> Operands sh -> Operands (sh, Int)+cons ShapeRz ix OP_Unit = OP_Pair OP_Unit ix+cons (ShapeRsnoc shr) ix (OP_Pair sh sz) = OP_Pair (cons shr ix sh) sz -- Remove the _left-most_ index to a shape, and return the remainder ---uncons :: forall sh. Shape sh => IR (sh :. Int) -> (IR Int, IR sh)-uncons (IR extent) = let (ix, extent') = go (eltType (undefined::(sh :. Int))) extent- in (IR ix, IR extent')- where- go :: TupleType (t, Int) -> Operands (t, Int) -> (Operands Int, Operands t)- go (TypeRpair TypeRunit _) (OP_Pair OP_Unit v2) = (v2, OP_Unit)- go (TypeRpair t1@(TypeRpair _ t2) _) (OP_Pair v1 v3)- | TypeRscalar t <- t2- , Just Refl <- matchScalarType t (scalarType :: ScalarType Int)- = let (i, v1') = go t1 v1- in (i, OP_Pair v1' v3)- go _ _- = $internalError "uncons" "expected shape with Int components"+uncons :: ShapeR sh -> Operands (sh, Int) -> (Operands Int, Operands sh)+uncons ShapeRz (OP_Pair OP_Unit v2) = (v2, OP_Unit)+uncons (ShapeRsnoc shr) (OP_Pair v1 v3)+ = let (i, v1') = uncons shr v1+ in (i, OP_Pair v1' v3)
src/Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs view
@@ -1,24 +1,24 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Sugar--- 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) -- module Data.Array.Accelerate.LLVM.CodeGen.Sugar ( - IRExp, IRFun1, IRFun2,+ IRExp, MIRExp, IRFun1, IRFun2, IROpenExp, IROpenFun1(..), IROpenFun2(..),- IROpenAcc(..), IRDelayed(..), IRManifest(..),-- IRBoundary(..),+ IROpenAcc(..),+ IRDelayed(..), MIRDelayed(..), IRArray(..), @@ -27,8 +27,7 @@ import LLVM.AST.Type.AddrSpace import LLVM.AST.Type.Instruction.Volatile -import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.LLVM.CodeGen.IR import Data.Array.Accelerate.LLVM.CodeGen.Module@@ -42,31 +41,21 @@ -- fresh names for each application of a scalar function or expression. -- type IRExp arch aenv t = IROpenExp arch () aenv t-type IROpenExp arch env aenv t = CodeGen (IR t)+type MIRExp arch aenv t = Maybe (IRExp arch aenv t)+type IROpenExp arch env aenv t = CodeGen arch (Operands t) type IRFun1 arch aenv t = IROpenFun1 arch () aenv t type IRFun2 arch aenv t = IROpenFun2 arch () aenv t data IROpenFun1 arch env aenv t where- IRFun1 :: { app1 :: IR a -> IROpenExp arch (env,a) aenv b }+ IRFun1 :: { app1 :: Operands a -> IROpenExp arch (env,a) aenv b } -> IROpenFun1 arch env aenv (a -> b) data IROpenFun2 arch env aenv t where- IRFun2 :: { app2 :: IR a -> IR b -> IROpenExp arch ((env,a),b) aenv c }+ IRFun2 :: { app2 :: Operands a -> Operands b -> IROpenExp arch ((env,a),b) aenv c } -> IROpenFun2 arch env aenv (a -> b -> c) --- Stencil--- ---------data IRBoundary arch aenv t where- IRClamp :: IRBoundary arch aenv t- IRMirror :: IRBoundary arch aenv t- IRWrap :: IRBoundary arch aenv t- IRConstant :: Elt e => IR e -> IRBoundary arch aenv (Array sh e)- IRFunction :: (Shape sh, Elt e) => IRFun1 arch aenv (sh -> e) -> IRBoundary arch aenv (Array sh e)-- -- Arrays -- ------ @@ -74,22 +63,22 @@ IROpenAcc :: [Kernel arch aenv arrs] -> IROpenAcc arch aenv arrs -data IRDelayed arch aenv a where- IRDelayed :: (Shape sh, Elt e) =>- { delayedExtent :: IRExp arch aenv sh- , delayedIndex :: IRFun1 arch aenv (sh -> e)- , delayedLinearIndex :: IRFun1 arch aenv (Int -> e)- }- -> IRDelayed arch aenv (Array sh e)--data IRManifest arch aenv a where- IRManifest :: Arrays arrs => Idx aenv arrs -> IRManifest arch aenv arrs+data MIRDelayed arch aenv a+ = IRDelayedJust (IRDelayed arch aenv a)+ | IRDelayedNothing (ArrayR a) +data IRDelayed arch aenv a where+ IRDelayed :: { delayedRepr :: ArrayR (Array sh e)+ , delayedExtent :: IRExp arch aenv sh+ , delayedIndex :: IRFun1 arch aenv (sh -> e)+ , delayedLinearIndex :: IRFun1 arch aenv (Int -> e)+ }+ -> IRDelayed arch aenv (Array sh e) data IRArray a where- IRArray :: (Shape sh, Elt e)- => { irArrayShape :: IR sh -- Array extent- , irArrayData :: IR e -- Array payloads (should really be 'Ptr e')+ IRArray :: { irArrayRepr :: ArrayR (Array sh e)+ , irArrayShape :: Operands sh -- Array extent+ , irArrayData :: Operands e -- Array payloads (should really be 'Ptr e') , irArrayAddrSpace :: AddrSpace , irArrayVolatility :: Volatility }
src/Data/Array/Accelerate/LLVM/CodeGen/Type.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Type--- 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) --@@ -14,195 +13,36 @@ module Data.Array.Accelerate.LLVM.CodeGen.Type where -import Data.Array.Accelerate.Array.Sugar--import LLVM.AST.Type.Constant-import LLVM.AST.Type.Global-import LLVM.AST.Type.Instruction-import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation----- | Does the concrete type represent signed or unsigned values?----class IsSigned dict where- signed :: dict a -> Bool- signed = not . unsigned- --- unsigned :: dict a -> Bool- unsigned = not . signed--instance IsSigned ScalarType where- signed (SingleScalarType t) = signed t- signed (VectorScalarType t) = signed t--instance IsSigned SingleType where- signed (NumSingleType t) = signed t- signed (NonNumSingleType t) = signed t--instance IsSigned VectorType where- signed (Vector2Type t) = signed t- signed (Vector3Type t) = signed t- signed (Vector4Type t) = signed t- signed (Vector8Type t) = signed t- signed (Vector16Type t) = signed t--instance IsSigned BoundedType where- signed (IntegralBoundedType t) = signed t- signed (NonNumBoundedType t) = signed t--instance IsSigned NumType where- signed (IntegralNumType t) = signed t- signed (FloatingNumType t) = signed t--instance IsSigned IntegralType where- signed t =- case t of- TypeInt _ -> True- TypeInt8 _ -> True- TypeInt16 _ -> True- TypeInt32 _ -> True- TypeInt64 _ -> True- TypeCShort _ -> True- TypeCInt _ -> True- TypeCLong _ -> True- TypeCLLong _ -> True- _ -> False--instance IsSigned FloatingType where- signed _ = True--instance IsSigned NonNumType where- signed t =- case t of- TypeBool _ -> False- TypeChar _ -> False- TypeCUChar _ -> False- TypeCSChar _ -> True- TypeCChar _ -> True----- | Extract the reified scalar type dictionary of an operation----class TypeOf op where- typeOf :: op a -> Type a--instance TypeOf Instruction where- typeOf ins =- case ins of- Add _ x _ -> typeOf x- Sub _ x _ -> typeOf x- Mul _ x _ -> typeOf x- Quot _ x _ -> typeOf x- Rem _ x _ -> typeOf x- Div _ x _ -> typeOf x- ShiftL _ x _ -> typeOf x- ShiftRL _ x _ -> typeOf x- ShiftRA _ x _ -> typeOf x- BAnd _ x _ -> typeOf x- BOr _ x _ -> typeOf x- BXor _ x _ -> typeOf x- LAnd _ _ -> type'- LOr _ _ -> type'- LNot _ -> type'- ExtractElement v _ _ -> case v of- Vector2Type t -> PrimType (ScalarPrimType (SingleScalarType t))- Vector3Type t -> PrimType (ScalarPrimType (SingleScalarType t))- Vector4Type t -> PrimType (ScalarPrimType (SingleScalarType t))- Vector8Type t -> PrimType (ScalarPrimType (SingleScalarType t))- Vector16Type t -> PrimType (ScalarPrimType (SingleScalarType t))- InsertElement _ x _ -> typeOf x- ExtractValue t _ _ -> PrimType (ScalarPrimType t)- Load t _ _ -> PrimType (ScalarPrimType t)- Store _ _ _ -> VoidType- GetElementPtr x _ -> typeOf x- Fence _ -> VoidType- CmpXchg t _ _ _ _ _ _ -> PrimType- $ StructPrimType- $ TypeRunit `TypeRpair` TypeRscalar (SingleScalarType (NumSingleType (IntegralNumType t)))- `TypeRpair` TypeRscalar scalarType- AtomicRMW _ _ _ _ x _ -> typeOf x- FTrunc _ t _ -> PrimType (ScalarPrimType (SingleScalarType (NumSingleType (FloatingNumType t))))- FExt _ t _ -> PrimType (ScalarPrimType (SingleScalarType (NumSingleType (FloatingNumType t))))- Trunc _ t _ -> case t of- IntegralBoundedType i -> PrimType (ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType i))))- NonNumBoundedType n -> PrimType (ScalarPrimType (SingleScalarType (NonNumSingleType n)))- Ext _ t _ -> case t of- IntegralBoundedType i -> PrimType (ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType i))))- NonNumBoundedType n -> PrimType (ScalarPrimType (SingleScalarType (NonNumSingleType n)))- FPToInt _ t _ -> PrimType (ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType t))))- IntToFP _ t _ -> PrimType (ScalarPrimType (SingleScalarType (NumSingleType (FloatingNumType t))))- BitCast t _ -> PrimType (ScalarPrimType t)- PtrCast t _ -> PrimType t- FCmp{} -> type'- Cmp{} -> type'- Select t _ _ _ -> PrimType (ScalarPrimType (SingleScalarType t))- Phi t _ -> PrimType t- Call f _ -> funResultType f- where- funResultType :: GlobalFunction args t -> Type t- funResultType (Lam _ _ l) = funResultType l- funResultType (Body t _) = t--instance TypeOf Operand where- typeOf op =- case op of- LocalReference t _ -> t- ConstantOperand c -> typeOf c+import Data.Array.Accelerate.Sugar.Elt -instance TypeOf Constant where- typeOf c =- case c of- ScalarConstant t _ -> PrimType (ScalarPrimType t)- UndefConstant t -> t- GlobalReference t _ -> t+import Data.Constraint -- | Extract some evidence that a reified type implies that type is a valid -- element ---data EltDict a where- EltDict :: Elt a => EltDict a--singleElt :: SingleType a -> EltDict a+singleElt :: SingleType a -> Dict (Elt a) singleElt (NumSingleType t) = numElt t-singleElt (NonNumSingleType t) = nonNumElt t -numElt :: NumType a -> EltDict a+numElt :: NumType a -> Dict (Elt a) numElt (IntegralNumType t) = integralElt t numElt (FloatingNumType t) = floatingElt t -integralElt :: IntegralType a -> EltDict a-integralElt TypeInt{} = EltDict-integralElt TypeInt8{} = EltDict-integralElt TypeInt16{} = EltDict-integralElt TypeInt32{} = EltDict-integralElt TypeInt64{} = EltDict-integralElt TypeWord{} = EltDict-integralElt TypeWord8{} = EltDict-integralElt TypeWord16{} = EltDict-integralElt TypeWord32{} = EltDict-integralElt TypeWord64{} = EltDict-integralElt TypeCShort{} = EltDict-integralElt TypeCUShort{} = EltDict-integralElt TypeCInt{} = EltDict-integralElt TypeCUInt{} = EltDict-integralElt TypeCLong{} = EltDict-integralElt TypeCULong{} = EltDict-integralElt TypeCLLong{} = EltDict-integralElt TypeCULLong{} = EltDict--floatingElt :: FloatingType a -> EltDict a-floatingElt TypeHalf{} = EltDict-floatingElt TypeFloat{} = EltDict-floatingElt TypeDouble{} = EltDict-floatingElt TypeCFloat{} = EltDict-floatingElt TypeCDouble{} = EltDict+integralElt :: IntegralType a -> Dict (Elt a)+integralElt TypeInt{} = Dict+integralElt TypeInt8{} = Dict+integralElt TypeInt16{} = Dict+integralElt TypeInt32{} = Dict+integralElt TypeInt64{} = Dict+integralElt TypeWord{} = Dict+integralElt TypeWord8{} = Dict+integralElt TypeWord16{} = Dict+integralElt TypeWord32{} = Dict+integralElt TypeWord64{} = Dict -nonNumElt :: NonNumType a -> EltDict a-nonNumElt TypeBool{} = EltDict-nonNumElt TypeChar{} = EltDict-nonNumElt TypeCChar{} = EltDict-nonNumElt TypeCSChar{} = EltDict-nonNumElt TypeCUChar{} = EltDict+floatingElt :: FloatingType a -> Dict (Elt a)+floatingElt TypeHalf{} = Dict+floatingElt TypeFloat{} = Dict+floatingElt TypeDouble{} = Dict
src/Data/Array/Accelerate/LLVM/Compile.hs view
@@ -1,18 +1,19 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.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) --@@ -24,69 +25,70 @@ CompiledOpenAcc(..), CompiledOpenAfun, CompiledAcc, CompiledAfun,- CompiledExp, CompiledOpenExp,- CompiledFun, CompiledOpenFun ) where --- accelerate import Data.Array.Accelerate.AST-import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )+import Data.Array.Accelerate.AST.Environment+import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.AST.Var+import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Product-import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Stencil+import Data.Array.Accelerate.Representation.Tag+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Trafo.Delayed+import Data.Array.Accelerate.Trafo.Substitution import Data.Array.Accelerate.Type-import qualified Data.Array.Accelerate.Array.Sugar as A+import qualified Data.Array.Accelerate.Sugar.Foreign as A import Data.Array.Accelerate.LLVM.CodeGen.Environment import Data.Array.Accelerate.LLVM.Foreign import Data.Array.Accelerate.LLVM.State import qualified Data.Array.Accelerate.LLVM.AST as AST --- standard library import Data.IntMap ( IntMap ) import Control.Applicative hiding ( Const ) import Prelude hiding ( map, unzip, zipWith, scanl, scanl1, scanr, scanr1, exp )+import qualified Data.IntMap as IntMap class Foreign arch => Compile arch where data ObjectR arch- -- TODO: Provide serialisation facilities, for on-disk caching etc. -- | Compile an accelerate computation into some backend-specific code that -- will be used to execute the given array expression. The code is not yet -- linked into the running executable. -- compileForTarget- :: DelayedOpenAcc aenv a+ :: PreOpenAcc DelayedOpenAcc aenv a -> Gamma aenv -> LLVM arch (ObjectR arch) data CompiledOpenAcc arch aenv a where- BuildAcc :: Gamma aenv+ BuildAcc :: ArraysR a+ -> Gamma aenv -> ObjectR arch -> AST.PreOpenAccSkeleton CompiledOpenAcc arch aenv a -> CompiledOpenAcc arch aenv a - PlainAcc :: Arrays a- => AST.PreOpenAccCommand CompiledOpenAcc arch aenv a+ PlainAcc :: ArraysR a+ -> AST.PreOpenAccCommand CompiledOpenAcc arch aenv a -> CompiledOpenAcc arch aenv a -- An annotated AST with embedded build products -- type CompiledOpenAfun arch = PreOpenAfun (CompiledOpenAcc arch)-type CompiledOpenExp arch = PreOpenExp (CompiledOpenAcc arch)-type CompiledOpenFun arch = PreOpenFun (CompiledOpenAcc arch) type CompiledAcc arch a = CompiledOpenAcc arch () a type CompiledAfun arch a = CompiledOpenAfun arch () a -type CompiledExp arch = CompiledOpenExp arch ()-type CompiledFun arch = CompiledOpenFun arch () - -- | Generate and compile code for an array expression. The returned expression -- is annotated with the compilation products required to executed each -- operation on the given target, together with the list of array variables@@ -94,14 +96,14 @@ -- {-# INLINEABLE compileAcc #-} compileAcc- :: Compile arch+ :: (HasCallStack, Compile arch) => DelayedAcc a -> LLVM arch (CompiledAcc arch a) compileAcc = compileOpenAcc {-# INLINEABLE compileAfun #-} compileAfun- :: Compile arch+ :: (HasCallStack, Compile arch) => DelayedAfun f -> LLVM arch (CompiledAfun arch f) compileAfun = compileOpenAfun@@ -109,16 +111,16 @@ {-# INLINEABLE compileOpenAfun #-} compileOpenAfun- :: Compile arch+ :: (HasCallStack, Compile arch) => DelayedOpenAfun aenv f -> LLVM arch (CompiledOpenAfun arch aenv f)-compileOpenAfun (Alam l) = Alam <$> compileOpenAfun l-compileOpenAfun (Abody b) = Abody <$> compileOpenAcc b+compileOpenAfun (Alam lhs l) = Alam lhs <$> compileOpenAfun l+compileOpenAfun (Abody b) = Abody <$> compileOpenAcc b {-# INLINEABLE compileOpenAcc #-} compileOpenAcc- :: forall arch _aenv _a. Compile arch+ :: forall arch _aenv _a. (HasCallStack, Compile arch) => DelayedOpenAcc _aenv _a -> LLVM arch (CompiledOpenAcc arch _aenv _a) compileOpenAcc = traverseAcc@@ -132,54 +134,51 @@ -- array variables that were referred to within scalar sub-expressions. -- These will be required during code generation and execution. --- traverseAcc :: forall aenv arrs. DelayedOpenAcc aenv arrs -> LLVM arch (CompiledOpenAcc arch aenv arrs)- traverseAcc Delayed{} = $internalError "compileOpenAcc" "unexpected delayed array"- traverseAcc topAcc@(Manifest pacc) =+ traverseAcc+ :: forall aenv arrs. HasCallStack+ => DelayedOpenAcc aenv arrs+ -> LLVM arch (CompiledOpenAcc arch aenv arrs)+ traverseAcc Delayed{} = internalError "unexpected delayed array"+ traverseAcc (Manifest pacc) = case pacc of -- Environment and control flow Avar ix -> plain $ pure (AST.Avar ix)- Alet a b -> plain . pure =<< AST.Alet <$> traverseAcc a <*> traverseAcc b- Apply f a -> plain =<< liftA2 AST.Apply <$> travAF f <*> travA a+ Alet lhs a b -> plain . pure =<< AST.Alet lhs <$> traverseAcc a <*> traverseAcc b+ Apply r f a -> plain =<< liftA2 (AST.Apply r) <$> travAF f <*> travA a Awhile p f a -> plain =<< liftA3 AST.Awhile <$> travAF p <*> travAF f <*> travA a Acond p t e -> plain =<< liftA3 AST.Acond <$> travE p <*> travA t <*> travA e- Atuple tup -> plain =<< liftA AST.Atuple <$> travAtup tup- Aprj ix tup -> plain =<< liftA (AST.Aprj ix) <$> travA tup+ Apair a1 a2 -> plain =<< liftA2 AST.Apair <$> travA a1 <*> travA a2+ Anil -> plain $ pure AST.Anil -- Foreign arrays operations- Aforeign ff afun a -> foreignA ff afun a+ Aforeign repr ff afun a -> foreignA repr ff afun a -- Uninitialised array allocation- Generate sh f- | alloc f -> plain =<< liftA AST.Alloc <$> travE sh+ Generate r sh f+ | alloc f -> plain =<< liftA (AST.Alloc r) <$> travE sh -- Array injection & manipulation- Reshape sh a -> plain =<< liftA2 AST.Reshape <$> travE sh <*> travM a- Unit e -> plain =<< liftA AST.Unit <$> travE e- Use arrs -> plain $ pure (AST.Use arrs)- Map f a+ Reshape shr sh a -> plain =<< liftA2 (AST.Reshape shr) <$> travE sh <*> travM a+ Unit tp e -> plain =<< liftA (AST.Unit tp) <$> travE e+ Use repr arrs -> plain $ pure (AST.Use repr arrs)+ Map _ f a | Just (t,x) <- unzip f a -> plain $ pure (AST.Unzip t x) -- Skeleton operations resulting in compiled code -- Producers- Map f a -> build =<< liftA2 map <$> travF f <*> travD a- Generate sh f -> build =<< liftA2 generate <$> travE sh <*> travF f- Transform sh p f a -> build =<< liftA4 transform <$> travE sh <*> travF p <*> travF f <*> travD a- Backpermute sh f a -> build =<< liftA3 backpermute <$> travE sh <*> travF f <*> travD a+ Map tp f a -> build =<< liftA2 (map tp) <$> travF f <*> travA a+ Generate r sh f -> build =<< liftA2 (generate r) <$> travE sh <*> travF f+ Transform r sh p f a -> build =<< liftA4 (transform r) <$> travE sh <*> travF p <*> travF f <*> travA a+ Backpermute shr sh f a -> build =<< liftA3 (backpermute shr) <$> travE sh <*> travF f <*> travA a -- Consumers- Fold f z a -> build =<< liftA3 fold <$> travF f <*> travE z <*> travD a- Fold1 f a -> build =<< liftA2 fold1 <$> travF f <*> travD a- FoldSeg f z a s -> build =<< liftA4 foldSeg <$> travF f <*> travE z <*> travD a <*> travD s- Fold1Seg f a s -> build =<< liftA3 fold1Seg <$> travF f <*> travD a <*> travD s- Scanl f z a -> build =<< liftA3 scanl <$> travF f <*> travE z <*> travD a- Scanl' f z a -> build =<< liftA3 scanl' <$> travF f <*> travE z <*> travD a- Scanl1 f a -> build =<< liftA2 scanl1 <$> travF f <*> travD a- Scanr f z a -> build =<< liftA3 scanr <$> travF f <*> travE z <*> travD a- Scanr' f z a -> build =<< liftA3 scanr' <$> travF f <*> travE z <*> travD a- Scanr1 f a -> build =<< liftA2 scanr1 <$> travF f <*> travD a+ Fold f z a -> build =<< liftA3 fold <$> travF f <*> travME z <*> travD a+ FoldSeg i f z a s -> build =<< liftA4 (foldSeg i) <$> travF f <*> travME z <*> travD a <*> travD s+ Scan d f z a -> build =<< liftA3 (scan d) <$> travF f <*> travME z <*> travD a+ Scan' d f z a -> build =<< liftA3 (scan' d) <$> travF f <*> travE z <*> travD a Permute f d g a -> build =<< liftA4 permute <$> travF f <*> travA d <*> travF g <*> travD a- Stencil f x a -> build =<< liftA3 stencil1 <$> travF f <*> travB x <*> travD a- Stencil2 f x a y b -> build =<< liftA5 stencil2 <$> travF f <*> travB x <*> travD a <*> travB y <*> travD b+ Stencil s tp f x a -> build =<< liftA3 (stencil1 s tp) <$> travF f <*> travB x <*> travD a+ Stencil2 s1 s2 tp f x a y b -> build =<< liftA5 (stencil2 s1 s2 tp) <$> travF f <*> travB x <*> travD a <*> travB y <*> travD b -- Removed by fusion Replicate{} -> fusionError@@ -187,58 +186,79 @@ ZipWith{} -> fusionError where- map _ a = AST.Map a- generate sh _ = AST.Generate sh- transform sh _ _ _ = AST.Transform sh- backpermute sh _ _ = AST.Backpermute sh- fold _ _ a = AST.Fold a- fold1 _ a = AST.Fold1 a- foldSeg _ _ a s = AST.FoldSeg a s- fold1Seg _ a s = AST.Fold1Seg a s- scanl _ _ a = AST.Scanl a- scanl1 _ a = AST.Scanl1 a- scanl' _ _ a = AST.Scanl' a- scanr _ _ a = AST.Scanr a- scanr1 _ a = AST.Scanr1 a- scanr' _ _ a = AST.Scanr' a- permute _ d _ a = AST.Permute a d- stencil1 _ _ a = AST.Stencil a- stencil2 _ _ a _ b = AST.Stencil2 a b+ map tp _ a = AST.Map tp a+ generate r sh _ = AST.Generate r sh+ transform r sh _ _ a = AST.Transform r sh a+ backpermute shr sh _ a = AST.Backpermute shr sh a+ fold _ z a = AST.Fold z a+ foldSeg i _ z a s = AST.FoldSeg i z a s+ scan d _ z a = AST.Scan d z a+ scan' d _ _ a = AST.Scan' d a+ permute _ d _ a = AST.Permute d a + stencil1 :: StencilR sh a stencil+ -> TypeR b+ -> Fun aenv (stencil -> b)+ -> Boundary aenv (Array sh a)+ -> AST.DelayedOpenAcc CompiledOpenAcc arch aenv (Array sh a)+ -> AST.PreOpenAccSkeleton CompiledOpenAcc arch aenv (Array sh b)+ stencil1 s tp _ _ a = AST.Stencil1 tp (snd $ stencilHalo s) a++ stencil2 :: StencilR sh a stencil1+ -> StencilR sh b stencil2+ -> TypeR c+ -> Fun aenv (stencil1 -> stencil2 -> c)+ -> Boundary aenv (Array sh a)+ -> AST.DelayedOpenAcc CompiledOpenAcc arch aenv (Array sh a)+ -> Boundary aenv (Array sh b)+ -> AST.DelayedOpenAcc CompiledOpenAcc arch aenv (Array sh b)+ -> AST.PreOpenAccSkeleton CompiledOpenAcc arch aenv (Array sh c)+ stencil2 s1 s2 tp _ _ a _ b = AST.Stencil2 tp (union shr h1 h2) a b+ where+ (shr, h1) = stencilHalo s1+ (_, h2) = stencilHalo s2+ fusionError :: error- fusionError = $internalError "execute" $ "unexpected fusible material: " ++ showPreAccOp pacc+ fusionError = internalError $ "unexpected fusible material: " ++ showPreAccOp pacc - travA :: DelayedOpenAcc aenv a -> LLVM arch (IntMap (Idx' aenv), CompiledOpenAcc arch aenv a)+ travA :: HasCallStack+ => DelayedOpenAcc aenv a+ -> LLVM arch (IntMap (Idx' aenv), CompiledOpenAcc arch aenv a) travA acc = pure <$> traverseAcc acc - travD :: (Shape sh, Elt e)+ travD :: HasCallStack => DelayedOpenAcc aenv (Array sh e)- -> LLVM arch (IntMap (Idx' aenv), PreExp (CompiledOpenAcc arch) aenv sh)- travD Manifest{} = $internalError "compileOpenAcc" "expected delayed array"- travD Delayed{..} = liftA2 (flip const) <$> travF indexD <*> travE extentD+ -> LLVM arch ( IntMap (Idx' aenv)+ , AST.DelayedOpenAcc CompiledOpenAcc arch aenv (Array sh e))+ travD acc =+ case acc of+ Delayed{..} -> liftA2 (const . (AST.Delayed reprD)) <$> travE extentD <*> travF indexD+ _ -> liftA (AST.Manifest $ arraysR acc) <$> travA acc - travM :: (Shape sh, Elt e)+ travM :: HasCallStack => DelayedOpenAcc aenv (Array sh e)- -> LLVM arch (IntMap (Idx' aenv), Idx aenv (Array sh e))- travM (Manifest (Avar ix)) = return (freevar ix, ix)- travM _ = $internalError "compileOpenAcc" "expected array variable"+ -> LLVM arch (IntMap (Idx' aenv), ArrayVar aenv (Array sh e))+ travM (Manifest (Avar v)) = return (freevar v, v)+ travM _ = internalError "expected array variable" - travAF :: DelayedOpenAfun aenv f+ travME :: Maybe (OpenExp env aenv e) -> LLVM arch (IntMap (Idx' aenv), Bool)+ travME Nothing = return (IntMap.empty, False)+ travME (Just e) = (True <$) <$> travE e++ travAF :: HasCallStack+ => DelayedOpenAfun aenv f -> LLVM arch (IntMap (Idx' aenv), CompiledOpenAfun arch aenv f) travAF afun = pure <$> compileOpenAfun afun - travAtup :: Atuple (DelayedOpenAcc aenv) a- -> LLVM arch (IntMap (Idx' aenv), Atuple (CompiledOpenAcc arch aenv) a)- travAtup NilAtup = return (pure NilAtup)- travAtup (SnocAtup t a) = liftA2 SnocAtup <$> travAtup t <*> travA a-- travF :: DelayedOpenFun env aenv t- -> LLVM arch (IntMap (Idx' aenv), CompiledOpenFun arch env aenv t)- travF (Body b) = liftA Body <$> travE b- travF (Lam f) = liftA Lam <$> travF f+ travF :: HasCallStack+ => OpenFun env aenv t+ -> LLVM arch (IntMap (Idx' aenv), OpenFun env aenv t)+ travF (Body b) = liftA Body <$> travE b+ travF (Lam lhs f) = liftA (Lam lhs) <$> travF f - travB :: PreBoundary DelayedOpenAcc aenv t- -> LLVM arch (IntMap (Idx' aenv), PreBoundary (CompiledOpenAcc arch) aenv t)+ travB :: HasCallStack+ => Boundary aenv t+ -> LLVM arch (IntMap (Idx' aenv), Boundary aenv t) travB Clamp = return $ pure Clamp travB Mirror = return $ pure Mirror travB Wrap = return $ pure Wrap@@ -249,13 +269,12 @@ -> LLVM arch (CompiledOpenAcc arch aenv arrs) build (aenv, eacc) = do let aval = makeGamma aenv- kernel <- compileForTarget topAcc aval- return $! BuildAcc aval kernel eacc+ kernel <- compileForTarget pacc aval+ return $! BuildAcc (arraysR eacc) aval kernel eacc - plain :: Arrays arrs'- => (IntMap (Idx' aenv'), AST.PreOpenAccCommand CompiledOpenAcc arch aenv' arrs')+ plain :: (IntMap (Idx' aenv'), AST.PreOpenAccCommand CompiledOpenAcc arch aenv' arrs') -> LLVM arch (CompiledOpenAcc arch aenv' arrs')- plain (_, eacc) = return (PlainAcc eacc)+ plain (_, eacc) = return (PlainAcc (arraysR eacc) eacc) -- Filling an array with undefined values is equivalent to allocating an -- uninitialised array. We look for this specific pattern because we@@ -270,131 +289,144 @@ -- execute, even though they do nothing (except incur scheduler -- overhead). --- alloc :: (Shape sh, Elt e)- => PreFun DelayedOpenAcc aenv (sh -> e)+ alloc :: Fun aenv (sh -> e) -> Bool alloc f- | Lam (Body Undef) <- f = True- | otherwise = False+ | Lam _ (Body (Undef _)) <- f = True+ | otherwise = False -- Unzips of manifest array data can be done in constant time without -- executing any array programs. We split them out here into a separate -- case so that the execution phase does not have to continually perform -- the below check. --- unzip :: forall sh a b. Elt a- => PreFun DelayedOpenAcc aenv (a -> b)+ unzip :: forall sh a b.+ Fun aenv (a -> b) -> DelayedOpenAcc aenv (Array sh a)- -> Maybe (TupleIdx (TupleRepr a) b, Idx aenv (Array sh a))- unzip _ _- | TypeRscalar VectorScalarType{} <- eltType (undefined::a)- = Nothing+ -> Maybe (AST.UnzipIdx a b, ArrayVar aenv (Array sh a)) unzip f a- | Lam (Body (Prj tix (Var ZeroIdx))) <- f- , Delayed sh index _ <- a+ | Lam lhs (Body b) <- f+ , Just vars <- extractExpVars b+ , Delayed _ sh index _ <- a , Shape u <- sh- , Manifest (Avar ix) <- u- , Lam (Body (Index v (Var ZeroIdx))) <- index- , Just Refl <- match u v- = Just (tix, ix)+ , Just v <- isIdentityIndexing index+ , Just Refl <- matchVar u v+ = Just (unzipIdx lhs vars, u) unzip _ _ = Nothing + unzipIdx :: forall env a b. ELeftHandSide a () env -> Vars ScalarType env b -> AST.UnzipIdx a b+ unzipIdx lhs = go+ where+ go :: Vars ScalarType env y -> AST.UnzipIdx a y+ go TupRunit = AST.UnzipUnit+ go (TupRpair v1 v2) = AST.UnzipPair (go v1) (go v2)+ go (TupRsingle (Var _ ix)) = case lookupVar lhs ix of+ Right u -> u+ Left ix' -> case ix' of {}+ -- Left branch is unreachable, as `Idx () y` is an empty type++ lookupVar :: ELeftHandSide x env1 env2 -> Idx env2 y -> Either (Idx env1 y) (AST.UnzipIdx x y)+ lookupVar (LeftHandSideWildcard _) ix = Left ix+ lookupVar (LeftHandSideSingle _) ix = case ix of+ ZeroIdx -> Right AST.UnzipId+ SuccIdx ix' -> Left ix'+ lookupVar (LeftHandSidePair l1 l2) ix = case lookupVar l2 ix of+ Right u -> Right $ AST.UnzipPrj PairIdxRight u+ Left ix' -> case lookupVar l1 ix' of+ Right u -> Right $ AST.UnzipPrj PairIdxLeft u+ Left ix'' -> Left ix''+ -- Is there a foreign version available for this backend? If so, take -- the foreign function and drop the remaining terms. Otherwise, drop -- this term and continue walking down the list of alternate -- implementations. --- foreignA :: (Arrays a, Arrays b, A.Foreign asm)- => asm (a -> b)+ foreignA :: (HasCallStack, A.Foreign asm)+ => ArraysR b+ -> asm (a -> b) -> DelayedAfun (a -> b) -> DelayedOpenAcc aenv a -> LLVM arch (CompiledOpenAcc arch aenv b)- foreignA ff f a =- case foreignAcc (undefined :: arch) ff of- Just asm -> plain =<< liftA (AST.Aforeign (strForeign ff) asm) <$> travA a- Nothing -> traverseAcc $ Manifest (Apply (weaken absurd f) a)- where- absurd :: Idx () t -> Idx aenv t- absurd = error "complicated stuff in simple words"+ foreignA repr ff f a =+ case foreignAcc ff of+ Just asm -> plain =<< liftA (AST.Aforeign repr (A.strForeign ff) asm) <$> travA a+ Nothing -> traverseAcc $ Manifest (Apply repr (weaken weakenEmpty f) a) -- Traverse a scalar expression --- travE :: DelayedOpenExp env aenv e- -> LLVM arch (IntMap (Idx' aenv), PreOpenExp (CompiledOpenAcc arch) env aenv e)+ travE :: HasCallStack+ => OpenExp env aenv e+ -> LLVM arch (IntMap (Idx' aenv), OpenExp env aenv e) travE exp = case exp of- Var ix -> return $ pure (Var ix)- Const c -> return $ pure (Const c)- PrimConst c -> return $ pure (PrimConst c)- Undef -> return $ pure Undef- IndexAny -> return $ pure IndexAny- IndexNil -> return $ pure IndexNil- Foreign ff f x -> foreignE ff f x+ Evar v -> return $ pure $ Evar v+ Const tp c -> return $ pure $ Const tp c+ PrimConst c -> return $ pure $ PrimConst c+ Undef tp -> return $ pure $ Undef tp+ Foreign tp ff f x -> foreignE tp ff f x --- Let a b -> liftA2 Let <$> travE a <*> travE b- IndexCons t h -> liftA2 IndexCons <$> travE t <*> travE h- IndexHead h -> liftA IndexHead <$> travE h- IndexTail t -> liftA IndexTail <$> travE t+ Let lhs a b -> liftA2 (Let lhs) <$> travE a <*> travE b IndexSlice slix x s -> liftA2 (IndexSlice slix) <$> travE x <*> travE s IndexFull slix x s -> liftA2 (IndexFull slix) <$> travE x <*> travE s- ToIndex s i -> liftA2 ToIndex <$> travE s <*> travE i- FromIndex s i -> liftA2 FromIndex <$> travE s <*> travE i- Tuple t -> liftA Tuple <$> travT t- Prj ix e -> liftA (Prj ix) <$> travE e+ ToIndex shr s i -> liftA2 (ToIndex shr) <$> travE s <*> travE i+ FromIndex shr s i -> liftA2 (FromIndex shr) <$> travE s <*> travE i+ Nil -> return $ pure Nil+ Pair e1 e2 -> liftA2 Pair <$> travE e1 <*> travE e2+ VecPack vecr e -> liftA (VecPack vecr) <$> travE e+ VecUnpack vecr e -> liftA (VecUnpack vecr) <$> travE e+ Case t xs x -> liftA3 Case <$> travE t <*> travLE xs <*> travME x Cond p t e -> liftA3 Cond <$> travE p <*> travE t <*> travE e While p f x -> liftA3 While <$> travF p <*> travF f <*> travE x PrimApp f e -> liftA (PrimApp f) <$> travE e Index a e -> liftA2 Index <$> travA a <*> travE e LinearIndex a e -> liftA2 LinearIndex <$> travA a <*> travE e Shape a -> liftA Shape <$> travA a- ShapeSize e -> liftA ShapeSize <$> travE e- Intersect x y -> liftA2 Intersect <$> travE x <*> travE y- Union x y -> liftA2 Union <$> travE x <*> travE y- Coerce x -> liftA Coerce <$> travE x+ ShapeSize shr e -> liftA (ShapeSize shr) <$> travE e+ Coerce t1 t2 x -> liftA (Coerce t1 t2) <$> travE x where- travA :: (Shape sh, Elt e)- => DelayedOpenAcc aenv (Array sh e)- -> LLVM arch (IntMap (Idx' aenv), CompiledOpenAcc arch aenv (Array sh e))- travA a = do- a' <- traverseAcc a- return $ (bind a', a')+ travA :: ArrayVar aenv (Array sh e)+ -> LLVM arch (IntMap (Idx' aenv), ArrayVar aenv (Array sh e))+ travA var = return (freevar var, var) - travT :: Tuple (DelayedOpenExp env aenv) t- -> LLVM arch (IntMap (Idx' aenv), Tuple (PreOpenExp (CompiledOpenAcc arch) env aenv) t)- travT NilTup = return (pure NilTup)- travT (SnocTup t e) = liftA2 SnocTup <$> travT t <*> travE e+ travF :: HasCallStack+ => OpenFun env aenv t+ -> LLVM arch (IntMap (Idx' aenv), OpenFun env aenv t)+ travF (Body b) = liftA Body <$> travE b+ travF (Lam lhs f) = liftA (Lam lhs) <$> travF f - travF :: DelayedOpenFun env aenv t- -> LLVM arch (IntMap (Idx' aenv), PreOpenFun (CompiledOpenAcc arch) env aenv t)- travF (Body b) = liftA Body <$> travE b- travF (Lam f) = liftA Lam <$> travF f+ travLE :: HasCallStack+ => [(TAG, OpenExp env aenv t)]+ -> LLVM arch (IntMap (Idx' aenv), [(TAG, OpenExp env aenv t)])+ travLE [] = return $ pure []+ travLE ((t,x):xs) = do+ (v, y) <- travE x+ (vs, ys) <- travLE xs+ return (IntMap.union v vs, (t,y):ys) - bind :: (Shape sh, Elt e) => CompiledOpenAcc arch aenv (Array sh e) -> IntMap (Idx' aenv)- bind (PlainAcc (AST.Avar ix)) = freevar ix- bind _ = $internalError "bind" "expected array variable"+ travME :: HasCallStack+ => Maybe (OpenExp env aenv t)+ -> LLVM arch (IntMap (Idx' aenv), Maybe (OpenExp env aenv t))+ travME Nothing = return $ pure Nothing+ travME (Just e) = fmap Just <$> travE e - foreignE :: (Elt a, Elt b, A.Foreign asm)- => asm (a -> b)- -> DelayedFun () (a -> b)- -> DelayedOpenExp env aenv a- -> LLVM arch (IntMap (Idx' aenv), PreOpenExp (CompiledOpenAcc arch) env aenv b)- foreignE asm f x =- case foreignExp (undefined :: arch) asm of- Just{} -> liftA (Foreign asm err) <$> travE x- Nothing | Lam (Body b) <- f -> liftA2 Let <$> travE x <*> travE (weaken absurd (weakenE zero b))- _ -> error "the slow regard of silent things"+ foreignE :: (HasCallStack, A.Foreign asm)+ => TypeR b+ -> asm (a -> b)+ -> Fun () (a -> b)+ -> OpenExp env aenv a+ -> LLVM arch (IntMap (Idx' aenv), OpenExp env aenv b)+ foreignE tp asm f x =+ case foreignExp @arch asm of+ Just{} -> liftA (Foreign tp asm err) <$> travE x+ Nothing+ | Lam lhs (Body b) <- f+ , Exists lhs' <- rebuildLHS lhs -> liftA2 (Let lhs') <$> travE x <*> travE (weaken weakenEmpty $ weakenE (sinkWithLHS lhs lhs' weakenEmpty) b)+ _ -> error "the slow regard of silent things" where- absurd :: Idx () t -> Idx aenv t- absurd = error "Look to my coming, at first light, on the fifth day. At dawn, look to the East."-- zero :: Idx ((), a) t -> Idx (env,a) t- zero ZeroIdx = ZeroIdx- zero _ = error "There are three things all wise men fear: the sea in storm, a night with no moon, and the anger of a gentle man."-- err :: CompiledFun arch () (a -> b)- err = $internalError "foreignE" "attempt to use fallback in foreign expression"+ err :: Fun () (a -> b)+ err = internalError "attempt to use fallback in foreign expression" -- Applicative@@ -405,4 +437,9 @@ liftA5 :: Applicative f => (a -> b -> c -> d -> e -> g) -> f a -> f b -> f c -> f d -> f e -> f g liftA5 f a b c d g = f <$> a <*> b <*> c <*> d <*> g++instance HasArraysR (CompiledOpenAcc arch) where+ {-# INLINEABLE arraysR #-}+ arraysR (BuildAcc r _ _ _) = r+ arraysR (PlainAcc r _) = r
src/Data/Array/Accelerate/LLVM/Compile/Cache.hs view
@@ -1,10 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.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) --@@ -13,14 +13,15 @@ Persistent(..), UID, cacheOfUID,- cacheOfOpenAcc,+ cacheOfPreOpenAcc, removeCacheDirectory, ) where -import Data.Array.Accelerate.Debug-import Data.Array.Accelerate.Trafo+import Data.Array.Accelerate.AST import Data.Array.Accelerate.Analysis.Hash+import Data.Array.Accelerate.Debug+import Data.Array.Accelerate.Trafo.Delayed import Data.Array.Accelerate.LLVM.State @@ -53,13 +54,14 @@ -- | Return the unique cache file path corresponding to a given accelerate -- computation. ---{-# INLINEABLE cacheOfOpenAcc #-}-cacheOfOpenAcc+{-# INLINEABLE cacheOfPreOpenAcc #-}+cacheOfPreOpenAcc :: Persistent arch- => DelayedOpenAcc aenv a+ => PreOpenAcc DelayedOpenAcc aenv a -> LLVM arch (UID, FilePath)-cacheOfOpenAcc acc = do- let uid = hashDelayedOpenAcc acc+cacheOfPreOpenAcc pacc = do+ let opt = defaultHashOptions { perfect=False }+ uid = hashPreOpenAccWith opt encodeDelayedOpenAcc pacc cacheFile <- cacheOfUID uid return (uid, cacheFile) @@ -74,7 +76,7 @@ -> LLVM arch FilePath cacheOfUID uid = do dbg <- liftIO $ if debuggingIsEnabled then getFlag debug else return False- appdir <- liftIO $ getAppUserDataDirectory "accelerate"+ appdir <- liftIO $ getXdgDirectory XdgCache "accelerate" template <- targetCacheTemplate let (base, file) = splitFileName template@@ -92,7 +94,7 @@ {-# INLINEABLE removeCacheDirectory #-} removeCacheDirectory :: Persistent arch => LLVM arch () removeCacheDirectory = do- appdir <- liftIO $ getAppUserDataDirectory "accelerate"+ appdir <- liftIO $ getXdgDirectory XdgCache "accelerate" template <- targetCacheTemplate let (base, _) = splitFileName template
src/Data/Array/Accelerate/LLVM/Embed.hs view
@@ -4,13 +4,14 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.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) --@@ -25,16 +26,21 @@ import LLVM.AST.Type.Name -import Data.Array.Accelerate.AST ( liftIdx, liftTupleIdx, liftArrays, liftConst, liftSliceIndex, liftPrimConst, liftPrimFun )-import Data.Array.Accelerate.Array.Sugar+import Data.Array.Accelerate.AST ( PreOpenAfun(..), ArrayVar, Direction(..), Exp, liftALeftHandSide, liftOpenExp, arrayR )+import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Elt+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Type import Data.Array.Accelerate.LLVM.AST import Data.Array.Accelerate.LLVM.CodeGen.Environment import Data.Array.Accelerate.LLVM.Compile import Data.Array.Accelerate.LLVM.Link -import Data.Typeable import Data.ByteString.Short ( ShortByteString ) import GHC.Ptr ( Ptr(..) ) import Language.Haskell.TH ( Q, TExp )@@ -69,7 +75,7 @@ -- {-# INLINEABLE embedAfun #-} embedAfun- :: (Embed arch, Typeable arch)+ :: Embed arch => arch -> CompiledAfun arch f -> Q (TExp (ExecAfun arch f))@@ -77,24 +83,25 @@ {-# INLINEABLE embedOpenAfun #-} embedOpenAfun- :: (Embed arch, Typeable arch, Typeable aenv)+ :: (HasCallStack, Embed arch) => arch -> CompiledOpenAfun arch aenv f -> Q (TExp (ExecOpenAfun arch aenv f))-embedOpenAfun arch (Alam l) = [|| Alam $$(embedOpenAfun arch l) ||]-embedOpenAfun arch (Abody b) = [|| Abody $$(embedOpenAcc arch b) ||]+embedOpenAfun arch (Alam lhs l) = [|| Alam $$(liftALeftHandSide lhs) $$(embedOpenAfun arch l) ||]+embedOpenAfun arch (Abody b) = [|| Abody $$(embedOpenAcc arch b) ||] {-# INLINEABLE embedOpenAcc #-} embedOpenAcc- :: forall arch aenv arrs. (Embed arch, Typeable arch, Typeable aenv, Typeable arrs)+ :: forall arch aenv arrs. (HasCallStack, Embed arch) => arch -> CompiledOpenAcc arch aenv arrs -> Q (TExp (ExecOpenAcc arch aenv arrs)) embedOpenAcc arch = liftA where- liftA :: (Typeable aenv', Typeable arrs') => CompiledOpenAcc arch aenv' arrs' -> Q (TExp (ExecOpenAcc arch aenv' arrs'))- liftA (PlainAcc pacc) = withSigE [|| EvalAcc $$(liftPreOpenAccCommand arch pacc) ||]- liftA (BuildAcc aenv obj pacc) = withSigE [|| ExecAcc $$(liftGamma aenv) $$(embedForTarget arch obj) $$(liftPreOpenAccSkeleton arch pacc) ||]+ liftA :: CompiledOpenAcc arch aenv' arrs' -> Q (TExp (ExecOpenAcc arch aenv' arrs'))+ liftA acc = case acc of+ PlainAcc repr pacc -> [|| EvalAcc $$(liftArraysR repr) $$(liftPreOpenAccCommand arch pacc) ||]+ BuildAcc repr aenv obj pacc -> [|| ExecAcc $$(liftArraysR repr) $$(liftGamma aenv) $$(embedForTarget arch obj) $$(liftPreOpenAccSkeleton arch pacc) ||] liftGamma :: Gamma aenv' -> Q (TExp (Gamma aenv')) #if MIN_VERSION_containers(0,5,8)@@ -106,12 +113,11 @@ liftGamma aenv = [|| IM.fromAscList $$(liftIM (IM.toAscList aenv)) ||] where liftIM :: [(Int, (Label, Idx' aenv'))] -> Q (TExp [(Int, (Label, Idx' aenv'))])- liftIM im = do- im' <- mapM (\(k,v) -> TH.unTypeQ [|| (k, $$(liftV v)) ||]) im- TH.unsafeTExpCoerce (return $ TH.ListE im')+ liftIM im =+ TH.TExp . TH.ListE <$> mapM (\(k,v) -> TH.unTypeQ [|| (k, $$(liftV v)) ||]) im #endif liftV :: (Label, Idx' aenv') -> Q (TExp (Label, Idx' aenv'))- liftV (Label n, Idx' ix) = [|| (Label $$(liftSBS n), Idx' $$(liftIdx ix)) ||]+ liftV (Label n, Idx' repr ix) = [|| (Label $$(liftSBS n), Idx' $$(liftArrayR repr) $$(liftIdx ix)) ||] -- O(n) at runtime to copy from the Addr# to the ByteArray#. We should -- be able to do this without copying, but I don't think the definition of@@ -126,159 +132,94 @@ {-# INLINEABLE liftPreOpenAfun #-} liftPreOpenAfun- :: (Embed arch, Typeable arch, Typeable aenv)+ :: (HasCallStack, Embed arch) => arch -> PreOpenAfun (CompiledOpenAcc arch) aenv t -> Q (TExp (PreOpenAfun (ExecOpenAcc arch) aenv t))-liftPreOpenAfun arch (Alam f) = [|| Alam $$(liftPreOpenAfun arch f) ||]-liftPreOpenAfun arch (Abody b) = [|| Abody $$(embedOpenAcc arch b) ||]+liftPreOpenAfun arch (Alam lhs f) = [|| Alam $$(liftALeftHandSide lhs) $$(liftPreOpenAfun arch f) ||]+liftPreOpenAfun arch (Abody b) = [|| Abody $$(embedOpenAcc arch b) ||] {-# INLINEABLE liftPreOpenAccCommand #-} liftPreOpenAccCommand- :: forall arch aenv a. (Embed arch, Typeable arch, Typeable aenv)+ :: forall arch aenv a. (HasCallStack, Embed arch) => arch -> PreOpenAccCommand CompiledOpenAcc arch aenv a -> Q (TExp (PreOpenAccCommand ExecOpenAcc arch aenv a)) liftPreOpenAccCommand arch pacc = let- liftA :: (Typeable aenv', Typeable arrs) => CompiledOpenAcc arch aenv' arrs -> Q (TExp (ExecOpenAcc arch aenv' arrs))+ liftA :: CompiledOpenAcc arch aenv' arrs -> Q (TExp (ExecOpenAcc arch aenv' arrs)) liftA = embedOpenAcc arch - liftE :: PreExp (CompiledOpenAcc arch) aenv t -> Q (TExp (PreExp (ExecOpenAcc arch) aenv t))- liftE = liftPreOpenExp arch+ liftE :: Exp aenv t -> Q (TExp (Exp aenv t))+ liftE = liftOpenExp liftAF :: PreOpenAfun (CompiledOpenAcc arch) aenv f -> Q (TExp (PreOpenAfun (ExecOpenAcc arch) aenv f)) liftAF = liftPreOpenAfun arch-- liftAtuple :: Atuple (CompiledOpenAcc arch aenv) t -> Q (TExp (Atuple (ExecOpenAcc arch aenv) t))- liftAtuple NilAtup = [|| NilAtup ||]- liftAtuple (SnocAtup tup a) = [|| SnocAtup $$(liftAtuple tup) $$(liftA a) ||] in case pacc of- Avar ix -> [|| Avar $$(liftIdx ix) ||]- Alet bnd body -> [|| Alet $$(liftA bnd) $$(liftA body) ||]- Alloc sh -> [|| Alloc $$(liftE sh) ||]- Use a -> [|| Use $$(liftArrays (arrays (undefined::a)) a) ||]- Unit e -> [|| Unit $$(liftE e) ||]- Atuple tup -> [|| Atuple $$(liftAtuple tup) ||]- Aprj tix a -> [|| Aprj $$(liftTupleIdx tix) $$(liftA a) ||]- Apply f a -> [|| Apply $$(liftAF f) $$(liftA a) ||]+ Avar v -> [|| Avar $$(liftArrayVar v) ||]+ Alet lhs bnd body -> [|| Alet $$(liftALeftHandSide lhs) $$(liftA bnd) $$(liftA body) ||]+ Alloc repr sh -> [|| Alloc $$(liftArrayR repr) $$(liftE sh) ||]+ Use repr a -> [|| Use $$(liftArrayR repr) $$(liftArray repr a) ||]+ Unit tp e -> [|| Unit $$(liftTypeR tp) $$(liftE e) ||]+ Apair a1 a2 -> [|| Apair $$(liftA a1) $$(liftA a2) ||]+ Anil -> [|| Anil ||]+ Apply repr f a -> [|| Apply $$(liftArraysR repr) $$(liftAF f) $$(liftA a) ||] Acond p t e -> [|| Acond $$(liftE p) $$(liftA t) $$(liftA e) ||] Awhile p f a -> [|| Awhile $$(liftAF p) $$(liftAF f) $$(liftA a) ||]- Reshape sh ix -> [|| Reshape $$(liftE sh) $$(liftIdx ix) ||]- Unzip tix ix -> [|| Unzip $$(liftTupleIdx tix) $$(liftIdx ix) ||]- Aforeign{} -> $internalError "liftPreOpenAcc" "using foreign functions from template-haskell is not supported yet"+ Reshape shr sh v -> [|| Reshape $$(liftShapeR shr) $$(liftE sh) $$(liftArrayVar v) ||]+ Unzip tix v -> [|| Unzip $$(liftUnzipIdx tix) $$(liftArrayVar v) ||]+ Aforeign{} -> internalError "using foreign functions from template-haskell is not supported yet" {-# INLINEABLE liftPreOpenAccSkeleton #-} liftPreOpenAccSkeleton- :: forall arch aenv a. (Embed arch, Typeable arch, Typeable aenv)+ :: forall arch aenv a. (HasCallStack, Embed arch) => arch -> PreOpenAccSkeleton CompiledOpenAcc arch aenv a -> Q (TExp (PreOpenAccSkeleton ExecOpenAcc arch aenv a)) liftPreOpenAccSkeleton arch pacc = let- liftA :: Typeable arrs => CompiledOpenAcc arch aenv arrs -> Q (TExp (ExecOpenAcc arch aenv arrs))+ liftA :: CompiledOpenAcc arch aenv arrs -> Q (TExp (ExecOpenAcc arch aenv arrs)) liftA = embedOpenAcc arch - liftE :: PreExp (CompiledOpenAcc arch) aenv t -> Q (TExp (PreExp (ExecOpenAcc arch) aenv t))- liftE = liftPreOpenExp arch- in- case pacc of- Map sh -> [|| Map $$(liftE sh) ||]- Generate sh -> [|| Generate $$(liftE sh) ||]- Transform sh -> [|| Transform $$(liftE sh) ||]- Backpermute sh -> [|| Backpermute $$(liftE sh) ||]- Fold sh -> [|| Fold $$(liftE sh) ||]- Fold1 sh -> [|| Fold1 $$(liftE sh) ||]- FoldSeg sa ss -> [|| FoldSeg $$(liftE sa) $$(liftE ss) ||]- Fold1Seg sa ss -> [|| Fold1Seg $$(liftE sa) $$(liftE ss) ||]- Scanl sh -> [|| Scanl $$(liftE sh) ||]- Scanl1 sh -> [|| Scanl1 $$(liftE sh) ||]- Scanl' sh -> [|| Scanl' $$(liftE sh) ||]- Scanr sh -> [|| Scanr $$(liftE sh) ||]- Scanr1 sh -> [|| Scanr1 $$(liftE sh) ||]- Scanr' sh -> [|| Scanr' $$(liftE sh) ||]- Permute sh a -> [|| Permute $$(liftE sh) $$(liftA a) ||]- Stencil sh -> [|| Stencil $$(liftE sh) ||]- Stencil2 sh1 sh2 -> [|| Stencil2 $$(liftE sh1) $$(liftE sh2) ||]--{-# INLINEABLE liftPreOpenFun #-}-liftPreOpenFun- :: (Embed arch, Typeable arch, Typeable env, Typeable aenv)- => arch- -> PreOpenFun (CompiledOpenAcc arch) env aenv t- -> Q (TExp (PreOpenFun (ExecOpenAcc arch) env aenv t))-liftPreOpenFun arch (Lam f) = [|| Lam $$(liftPreOpenFun arch f) ||]-liftPreOpenFun arch (Body b) = [|| Body $$(liftPreOpenExp arch b) ||]+ liftD :: DelayedOpenAcc CompiledOpenAcc arch aenv arrs -> Q (TExp (DelayedOpenAcc ExecOpenAcc arch aenv arrs))+ liftD (Delayed repr sh) = [|| Delayed $$(liftArrayR repr) $$(liftE sh) ||]+ liftD (Manifest repr a) = [|| Manifest $$(liftArraysR repr) $$(liftA a) ||] -{-# INLINEABLE liftPreOpenExp #-}-liftPreOpenExp- :: forall arch env aenv t. (Embed arch, Typeable arch, Typeable env, Typeable aenv)- => arch- -> PreOpenExp (CompiledOpenAcc arch) env aenv t- -> Q (TExp (PreOpenExp (ExecOpenAcc arch) env aenv t))-liftPreOpenExp arch pexp =- let- liftA :: Typeable arrs => CompiledOpenAcc arch aenv arrs -> Q (TExp (ExecOpenAcc arch aenv arrs))- liftA = embedOpenAcc arch+ liftE :: Exp aenv t -> Q (TExp (Exp aenv t))+ liftE = liftOpenExp - liftE :: PreOpenExp (CompiledOpenAcc arch) env aenv e -> Q (TExp (PreOpenExp (ExecOpenAcc arch) env aenv e))- liftE = liftPreOpenExp arch+ liftS :: ShapeR sh -> sh -> Q (TExp sh)+ liftS shr sh = [|| $$(liftElt (shapeType shr) sh) ||] - liftF :: PreOpenFun (CompiledOpenAcc arch) env aenv f -> Q (TExp (PreOpenFun (ExecOpenAcc arch) env aenv f))- liftF = liftPreOpenFun arch+ liftZ :: HasInitialValue -> Q (TExp HasInitialValue)+ liftZ True = [|| True ||]+ liftZ False = [|| False ||] - liftT :: Tuple (PreOpenExp (CompiledOpenAcc arch) env aenv) e -> Q (TExp (Tuple (PreOpenExp (ExecOpenAcc arch) env aenv) e))- liftT NilTup = [|| NilTup ||]- liftT (SnocTup tup e) = [|| SnocTup $$(liftT tup) $$(liftE e) ||]+ liftDir :: Direction -> Q (TExp Direction)+ liftDir LeftToRight = [|| LeftToRight ||]+ liftDir RightToLeft = [|| RightToLeft ||] in- case pexp of- Let bnd body -> [|| Let $$(liftPreOpenExp arch bnd) $$(liftPreOpenExp arch body) ||]- Var ix -> [|| Var $$(liftIdx ix) ||]- Foreign asm f x -> [|| Foreign $$(liftForeign asm) $$(liftPreOpenFun arch f) $$(liftE x) ||]- Const c -> [|| Const $$(liftConst (eltType (undefined::t)) c) ||]- Undef -> [|| Undef ||]- Tuple tup -> [|| Tuple $$(liftT tup) ||]- Prj tix e -> [|| Prj $$(liftTupleIdx tix) $$(liftE e) ||]- IndexNil -> [|| IndexNil ||]- IndexCons sh sz -> [|| IndexCons $$(liftE sh) $$(liftE sz) ||]- IndexHead sh -> [|| IndexHead $$(liftE sh) ||]- IndexTail sh -> [|| IndexTail $$(liftE sh) ||]- IndexAny -> [|| IndexAny ||]- IndexSlice slice slix sh -> withSigE [|| IndexSlice $$(liftSliceIndex slice) $$(withSigE (liftE slix)) $$(withSigE (liftE sh)) ||]- IndexFull slice slix sl -> withSigE [|| IndexFull $$(liftSliceIndex slice) $$(withSigE (liftE slix)) $$(withSigE (liftE sl)) ||]- ToIndex sh ix -> [|| ToIndex $$(liftE sh) $$(liftE ix) ||]- FromIndex sh ix -> [|| FromIndex $$(liftE sh) $$(liftE ix) ||]- Cond p t e -> [|| Cond $$(liftE p) $$(liftE t) $$(liftE e) ||]- While p f x -> [|| While $$(liftF p) $$(liftF f) $$(liftE x) ||]- PrimConst t -> [|| PrimConst $$(liftPrimConst t) ||]- PrimApp f x -> [|| PrimApp $$(liftPrimFun f) $$(liftE x) ||]- Index a ix -> [|| Index $$(liftA a) $$(liftE ix) ||]- LinearIndex a ix -> [|| LinearIndex $$(liftA a) $$(liftE ix) ||]- Shape a -> [|| Shape $$(liftA a) ||]- ShapeSize ix -> [|| ShapeSize $$(liftE ix) ||]- Intersect sh1 sh2 -> [|| Intersect $$(liftE sh1) $$(liftE sh2) ||]- Union sh1 sh2 -> [|| Union $$(liftE sh1) $$(liftE sh2) ||]- Coerce x -> [|| Coerce $$(liftE x) ||]----- Utilities--- -----------withSigE :: forall e. Typeable e => Q (TExp e) -> Q (TExp e)-withSigE e = e `sigE` typeRepToType (typeOf (undefined::e))+ case pacc of+ Map tp a -> [|| Map $$(liftTypeR tp) $$(liftA a) ||]+ Generate repr sh -> [|| Generate $$(liftArrayR repr) $$(liftE sh) ||]+ Transform repr sh a -> [|| Transform $$(liftArrayR repr) $$(liftE sh) $$(liftA a) ||]+ Backpermute shr sh a -> [|| Backpermute $$(liftShapeR shr) $$(liftE sh) $$(liftA a) ||]+ Fold z a -> [|| Fold $$(liftZ z) $$(liftD a) ||]+ FoldSeg i z a s -> [|| FoldSeg $$(liftIntegralType i) $$(liftZ z) $$(liftD a) $$(liftD s) ||]+ Scan d z a -> [|| Scan $$(liftDir d) $$(liftZ z) $$(liftD a) ||]+ Scan' d a -> [|| Scan' $$(liftDir d) $$(liftD a) ||]+ Permute d a -> [|| Permute $$(liftA d) $$(liftD a) ||]+ Stencil1 tp h a -> [|| Stencil1 $$(liftTypeR tp) $$(liftS (arrayRshape $ arrayR a) h) $$(liftD a) ||]+ Stencil2 tp h a b -> [|| Stencil2 $$(liftTypeR tp) $$(liftS (arrayRshape $ arrayR a) h) $$(liftD a) $$(liftD b) ||] -sigE :: Q (TExp t) -> Q TH.Type -> Q (TExp t)-sigE e t = TH.unsafeTExpCoerce $ TH.sigE (TH.unTypeQ e) t+liftArrayVar :: ArrayVar aenv v -> Q (TExp (ArrayVar aenv v))+liftArrayVar (Var tp v) = [|| Var $$(liftArrayR tp) $$(liftIdx v) ||] -typeRepToType :: TypeRep -> Q TH.Type-typeRepToType trep = do- let (con, args) = splitTyConApp trep- name = TH.Name (TH.OccName (tyConName con)) (TH.NameG TH.TcClsName (TH.PkgName (tyConPackage con)) (TH.ModName (tyConModule con)))- --- appsT x [] = x- appsT x (y:xs) = appsT (TH.AppT x y) xs- --- resultArgs <- mapM typeRepToType args- return (appsT (TH.ConT name) resultArgs)+liftUnzipIdx :: UnzipIdx tup e -> Q (TExp (UnzipIdx tup e))+liftUnzipIdx UnzipId = [|| UnzipId ||]+liftUnzipIdx (UnzipPrj PairIdxLeft ix) = [|| UnzipPrj PairIdxLeft $$(liftUnzipIdx ix) ||]+liftUnzipIdx (UnzipPrj PairIdxRight ix) = [|| UnzipPrj PairIdxRight $$(liftUnzipIdx ix) ||]+liftUnzipIdx UnzipUnit = [|| UnzipUnit ||]+liftUnzipIdx (UnzipPair ix1 ix2) = [|| UnzipPair $$(liftUnzipIdx ix1) $$(liftUnzipIdx ix2) ||]
src/Data/Array/Accelerate/LLVM/Execute.hs view
@@ -1,206 +1,170 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.Execute--- 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.Execute ( - Execute(..), Gamma,- executeAcc, executeAfun,+ Execute(..), Delayed(..), Gamma,+ executeAcc, executeOpenAcc, ) where --- accelerate+import Data.Array.Accelerate.AST ( Direction, PreOpenAfun(..), ALeftHandSide, ArrayVar, Fun, OpenFun(..), Exp, OpenExp(..), PrimBool, arraysR, arrayR )+import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.Var import Data.Array.Accelerate.Analysis.Match-import Data.Array.Accelerate.Array.Representation ( SliceIndex(..) )-import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )-import Data.Array.Accelerate.Error-import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalCoerceScalar )+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Elt+import Data.Array.Accelerate.Representation.Shape+import Data.Array.Accelerate.Representation.Slice+import Data.Array.Accelerate.Representation.Tag+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Representation.Vec import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Interpreter ( evalPrim, evalPrimConst, evalPrj, evalUndef, evalCoerce )+import qualified Data.Array.Accelerate.Debug as Debug -import Data.Array.Accelerate.LLVM.AST+import Data.Array.Accelerate.LLVM.AST hiding ( Delayed, Manifest ) import Data.Array.Accelerate.LLVM.Array.Data-import Data.Array.Accelerate.LLVM.Link-import Data.Array.Accelerate.LLVM.State- import Data.Array.Accelerate.LLVM.CodeGen.Environment ( Gamma )--import Data.Array.Accelerate.LLVM.Execute.Async hiding ( join )+import Data.Array.Accelerate.LLVM.Execute.Async import Data.Array.Accelerate.LLVM.Execute.Environment+import Data.Array.Accelerate.LLVM.Link+import qualified Data.Array.Accelerate.LLVM.AST as AST --- library import Control.Monad-import Control.Applicative hiding ( Const )+import System.IO.Unsafe import Prelude hiding ( exp, map, unzip, scanl, scanr, scanl1, scanr1 ) class Remote arch => Execute arch where- map :: (Shape sh, Elt b)- => ExecutableR arch- -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh- -> LLVM arch (Array sh b)-- generate :: (Shape sh, Elt e)- => ExecutableR arch- -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh- -> LLVM arch (Array sh e)-- transform :: (Shape sh, Elt e)- => ExecutableR arch+ map :: Maybe (a :~: b) -- update values in-place?+ -> ArrayR (Array sh a)+ -> TypeR b+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh- -> LLVM arch (Array sh e)+ -> ValR arch aenv+ -> Array sh a+ -> Par arch (FutureR arch (Array sh b)) - backpermute :: (Shape sh, Elt e)- => ExecutableR arch+ generate :: ArrayR (Array sh e)+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch+ -> ValR arch aenv -> sh- -> LLVM arch (Array sh e)-- fold :: (Shape sh, Elt e)- => ExecutableR arch- -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> LLVM arch (Array sh e)-- fold1 :: (Shape sh, Elt e)- => ExecutableR arch- -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> LLVM arch (Array sh e)-- foldSeg :: (Shape sh, Elt e)- => ExecutableR arch- -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> DIM1- -> LLVM arch (Array (sh:.Int) e)-- fold1Seg :: (Shape sh, Elt e)- => ExecutableR arch- -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> DIM1- -> LLVM arch (Array (sh:.Int) e)+ -> Par arch (FutureR arch (Array sh e)) - scanl :: (Shape sh, Elt e)- => ExecutableR arch+ transform :: ArrayR (Array sh a)+ -> ArrayR (Array sh' b)+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> LLVM arch (Array (sh:.Int) e)+ -> ValR arch aenv+ -> sh'+ -> Array sh a+ -> Par arch (FutureR arch (Array sh' b)) - scanl1 :: (Shape sh, Elt e)- => ExecutableR arch+ backpermute :: ArrayR (Array sh e)+ -> ShapeR sh'+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> LLVM arch (Array (sh:.Int) e)+ -> ValR arch aenv+ -> sh'+ -> Array sh e+ -> Par arch (FutureR arch (Array sh' e)) - scanl' :: (Shape sh, Elt e)- => ExecutableR arch+ fold :: HasInitialValue+ -> ArrayR (Array sh e)+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> LLVM arch (Array (sh:.Int) e, Array sh e)+ -> ValR arch aenv+ -> Delayed (Array (sh, Int) e)+ -> Par arch (FutureR arch (Array sh e)) - scanr :: (Shape sh, Elt e)- => ExecutableR arch+ foldSeg :: IntegralType i+ -> HasInitialValue+ -> ArrayR (Array (sh, Int) e)+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> LLVM arch (Array (sh:.Int) e)+ -> ValR arch aenv+ -> Delayed (Array (sh, Int) e)+ -> Delayed (Segments i)+ -> Par arch (FutureR arch (Array (sh, Int) e)) - scanr1 :: (Shape sh, Elt e)- => ExecutableR arch+ scan :: Direction+ -> HasInitialValue+ -> ArrayR (Array (sh, Int) e)+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> LLVM arch (Array (sh:.Int) e)+ -> ValR arch aenv+ -> Delayed (Array (sh, Int) e)+ -> Par arch (FutureR arch (Array (sh, Int) e)) - scanr' :: (Shape sh, Elt e)- => ExecutableR arch+ scan' :: Direction+ -> ArrayR (Array (sh, Int) e)+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh :. Int- -> LLVM arch (Array (sh:.Int) e, Array sh e)+ -> ValR arch aenv+ -> Delayed (Array (sh, Int) e)+ -> Par arch (FutureR arch (Array (sh, Int) e, Array sh e)) - permute :: (Shape sh, Shape sh', Elt e)- => ExecutableR arch+ permute :: Bool -- ^ update defaults array in-place?+ -> ArrayR (Array sh e)+ -> ShapeR sh'+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> Bool- -> sh+ -> ValR arch aenv -> Array sh' e- -> LLVM arch (Array sh' e)+ -> Delayed (Array sh e)+ -> Par arch (FutureR arch (Array sh' e)) - stencil1 :: (Shape sh, Elt e)- => ExecutableR arch- -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch+ stencil1 :: TypeR a+ -> ArrayR (Array sh b) -> sh- -> LLVM arch (Array sh e)-- stencil2 :: (Shape sh, Elt e)- => ExecutableR arch+ -> ExecutableR arch -> Gamma aenv- -> AvalR arch aenv- -> StreamR arch- -> sh+ -> ValR arch aenv+ -> Delayed (Array sh a)+ -> Par arch (FutureR arch (Array sh b))++ stencil2 :: TypeR a+ -> TypeR b+ -> ArrayR (Array sh c) -> sh- -> LLVM arch (Array sh e)+ -> ExecutableR arch+ -> Gamma aenv+ -> ValR arch aenv+ -> Delayed (Array sh a)+ -> Delayed (Array sh b)+ -> Par arch (FutureR arch (Array sh c)) - aforeign :: (Arrays as, Arrays bs)- => String- -> (StreamR arch -> as -> LLVM arch bs)- -> StreamR arch+ aforeign :: String+ -> ArraysR as+ -> ArraysR bs+ -> (as -> Par arch (FutureR arch bs)) -> as- -> LLVM arch bs+ -> Par arch (FutureR arch bs) +data Delayed a where+ Delayed :: sh -> Delayed (Array sh e)+ Manifest :: a -> Delayed a -- Array expression evaluation@@ -220,13 +184,14 @@ -- {-# INLINEABLE executeAcc #-} executeAcc- :: forall arch a. Execute arch+ :: Execute arch => ExecAcc arch a- -> LLVM arch a+ -> Par arch (FutureArraysR arch a) executeAcc !acc =- get =<< async (executeOpenAcc acc Aempty)+ executeOpenAcc acc Empty +{-- -- Execute a variadic array function -- {-# INLINEABLE executeAfun #-}@@ -238,26 +203,27 @@ class ExecuteAfun arch f where type ExecAfunR arch f- executeOpenAfun :: ExecOpenAfun arch aenv (ExecAfunR arch f) -> LLVM arch (AvalR arch aenv) -> f+ executeOpenAfun :: ExecOpenAfun arch aenv (ExecAfunR arch f) -> Par arch (AvalR arch aenv) -> f instance (Remote arch, ExecuteAfun arch b) => ExecuteAfun arch (a -> b) where type ExecAfunR arch (a -> b) = a -> ExecAfunR arch b {-# INLINEABLE executeOpenAfun #-}- executeOpenAfun Abody{} _ _ = $internalError "executeOpenAfun" "malformed array function"- executeOpenAfun (Alam f) k arrs =- let k' = do aenv <- k- AsyncR _ a <- async (useRemoteAsync arrs)+ executeOpenAfun Abody{} _ _ = $internalError "executeOpenAfun" "malformed array function"+ executeOpenAfun (Alam lhs f) k arrs =+ let k' = do aenv <- k+ a <- useRemoteAsync arrs return (aenv `Apush` a) in executeOpenAfun f k' -instance Execute arch => ExecuteAfun arch (LLVM arch b) where- type ExecAfunR arch (LLVM arch b) = b+instance Execute arch => ExecuteAfun arch (Par arch b) where+ type ExecAfunR arch (Par arch b) = b {-# INLINEABLE executeOpenAfun #-} executeOpenAfun Alam{} _ = $internalError "executeOpenAfun" "function not fully applied" executeOpenAfun (Abody b) k = do aenv <- k- get =<< async (executeOpenAcc b aenv)+ executeOpenAcc b aenv+--} -- NOTE: [ExecuteAfun and closed type families]@@ -298,219 +264,398 @@ executeOpenAcc :: forall arch aenv arrs. Execute arch => ExecOpenAcc arch aenv arrs- -> AvalR arch aenv- -> StreamR arch- -> LLVM arch arrs-executeOpenAcc !topAcc !aenv !stream = travA topAcc+ -> ValR arch aenv+ -> Par arch (FutureArraysR arch arrs)+executeOpenAcc !topAcc !aenv = travA topAcc where- travA :: ExecOpenAcc arch aenv a -> LLVM arch a- travA (EvalAcc pacc) =+ travA :: ExecOpenAcc arch aenv a -> Par arch (FutureArraysR arch a)+ travA (EvalAcc _ pacc) = case pacc of- Use arrs -> get =<< useRemoteAsync (toArr arrs) stream- Unit x -> newRemote Z . const =<< travE x- Avar ix -> avar ix- Alet bnd body -> alet bnd body- Alloc sh -> allocateRemote =<< travE sh- Apply f a -> travAF f =<< async (executeOpenAcc a aenv)- Atuple tup -> toAtuple <$> travT tup- Aprj ix tup -> evalPrj ix . fromAtuple <$> travA tup- Acond p t e -> acond t e =<< travE p- Awhile p f a -> awhile p f =<< travA a- Reshape sh ix -> reshape <$> travE sh <*> avar ix- Unzip tix ix -> unzip tix <$> avar ix- Aforeign str asm a -> aforeign str asm stream =<< travA a+ Use repr arr -> spawn $ useRemoteAsync (TupRsingle repr) arr+ Unit tp x -> unit tp x+ Avar (Var ArrayR{} ix) -> return $ prj ix aenv+ Alet lhs bnd body -> alet lhs bnd body+ Apair a1 a2 -> liftM2 (,) (travA a1) (travA a2)+ Anil -> return ()+ Alloc repr sh -> allocate repr sh+ Apply _ f a -> travAF f =<< spawn (travA a)+ -- We need quite some type applications in the rules for acond and awhile, and cannot use do notation.+ -- For some unknown reason, GHC will "simplify" 'FutureArraysR arch a' to 'FutureR arch a', which is not sound.+ -- It then complains that 'FutureR arch a' isn't assignable to 'FutureArraysR arch a'. By adding explicit+ -- type applications, type checking works fine. This appears to be fixed in GHC 8.8; we don't have problems+ -- with type inference there after removing the explicit type applications.+ Acond p (t :: ExecOpenAcc arch aenv a) e+ -> (>>=) @(Par arch) @(FutureR arch PrimBool) @(FutureArraysR arch a) (travE p) (acond t e)+ Awhile p f (a :: ExecOpenAcc arch aenv a)+ -> (>>=) @(Par arch) @(FutureArraysR arch a) @(FutureArraysR arch a)+ (spawn @arch @(FutureArraysR arch a) $ travA a)+ (awhile p f)+ Reshape shr sh (Var (ArrayR shr' _) ix)+ -> liftF2 (\s -> reshape shr s shr') (travE sh) (return $ prj ix aenv)+ Unzip tix (Var _ ix) -> liftF1 (unzip tix) (return $ prj ix aenv)+ Aforeign r str asm a -> do+ x <- travA a+ y <- spawn $ aforeign str (arraysR a) r asm =<< getArrays (arraysR a) x+ split r y - travA (ExecAcc !gamma !kernel pacc) =+ travA (ExecAcc _ !gamma !kernel pacc) = case pacc of -- Producers- Map sh -> map kernel gamma aenv stream =<< travE sh- Generate sh -> generate kernel gamma aenv stream =<< travE sh- Transform sh -> transform kernel gamma aenv stream =<< travE sh- Backpermute sh -> backpermute kernel gamma aenv stream =<< travE sh+ Map tp a -> exec1 (map_ a (arrayR a) tp) (travA a)+ Generate repr sh -> exec1 (generate repr) (travE sh)+ Transform repr sh a -> exec2 (transform (arrayR a) repr) (travE sh) (travA a)+ Backpermute shr sh a -> exec2 (backpermute (arrayR a) shr) (travE sh) (travA a) -- Consumers- Fold sh -> fold kernel gamma aenv stream =<< travE sh- Fold1 sh -> fold1 kernel gamma aenv stream =<< travE sh- FoldSeg sa ss -> id =<< foldSeg kernel gamma aenv stream <$> travE sa <*> travE ss- Fold1Seg sa ss -> id =<< fold1Seg kernel gamma aenv stream <$> travE sa <*> travE ss- Scanl sh -> scanl kernel gamma aenv stream =<< travE sh- Scanr sh -> scanr kernel gamma aenv stream =<< travE sh- Scanl1 sh -> scanl1 kernel gamma aenv stream =<< travE sh- Scanr1 sh -> scanr1 kernel gamma aenv stream =<< travE sh- Scanl' sh -> scanl' kernel gamma aenv stream =<< travE sh- Scanr' sh -> scanr' kernel gamma aenv stream =<< travE sh- Permute sh d -> id =<< permute kernel gamma aenv stream (inplace d) <$> travE sh <*> travA d- Stencil2 sh1 sh2 -> id =<< stencil2 kernel gamma aenv stream <$> travE sh1 <*> travE sh2- Stencil sh -> stencil1 kernel gamma aenv stream =<< travE sh+ Fold z a -> exec1 (fold z $ reduceRank $ arrayR a) (travD a)+ FoldSeg i z a s -> exec2 (foldSeg i z $ arrayR a) (travD a) (travD s)+ Scan d z a -> exec1 (scan d z $ arrayR a) (travD a)+ Scan' d a -> splitPair+ $ exec1 (scan' d $ arrayR a) (travD a)+ Permute d a -> exec2 (permute_ d (arrayR a) $ arrayRshape $ arrayR d) (travA d) (travD a)+ Stencil1 tpB h a -> let ArrayR shr tpA = arrayR a+ in exec1 (stencil1 tpA (ArrayR shr tpB) h) (travD a)+ Stencil2 tpC h a b -> let ArrayR shr tpA = arrayR a+ ArrayR _ tpB = arrayR b+ in exec2 (stencil2 tpA tpB (ArrayR shr tpC) h) (travD a) (travD b) - travAF :: ExecOpenAfun arch aenv (a -> b) -> AsyncR arch a -> LLVM arch b- travAF (Alam (Abody f)) a = get =<< async (executeOpenAcc f (aenv `Apush` a))- travAF _ _ = error "boop!"+ where+ exec1 :: (ExecutableR arch -> Gamma aenv -> ValR arch aenv -> a -> Par arch (FutureR arch b))+ -> Par arch (FutureR arch a)+ -> Par arch (FutureR arch b)+ exec1 f x = do+ x' <- x+ spawn $ f kernel gamma aenv =<< get x' - travE :: ExecExp arch aenv t -> LLVM arch t- travE exp = executeExp exp aenv stream+ exec2 :: (ExecutableR arch -> Gamma aenv -> ValR arch aenv -> a -> b -> Par arch (FutureR arch c))+ -> Par arch (FutureR arch a)+ -> Par arch (FutureR arch b)+ -> Par arch (FutureR arch c)+ exec2 f x y = do+ x' <- x+ y' <- y+ spawn $ id =<< liftM2 (f kernel gamma aenv) (get x') (get y') - travT :: Atuple (ExecOpenAcc arch aenv) t -> LLVM arch t- travT NilAtup = return ()- travT (SnocAtup t a) = (,) <$> travT t <*> travA a+ splitPair :: forall a b. Par arch (FutureR arch (a, b))+ -> Par arch (FutureR arch a, FutureR arch b)+ splitPair x = do+ r1 <- new+ r2 <- new+ fork $ do+ x' <- x+ (a, b) <- get x'+ put r1 a+ put r2 b+ return (r1, r2) - -- Bound terms. Let-bound input arrays (Use nodes) are copied to the device- -- asynchronously, so that they may overlap other computations if possible.- alet :: ExecOpenAcc arch aenv bnd -> ExecOpenAcc arch (aenv, bnd) body -> LLVM arch body- alet bnd body = do- bnd' <- case bnd of- EvalAcc (Use arrs) -> do AsyncR _ bnd' <- async (useRemoteAsync (toArr arrs))- return bnd'- _ -> async (executeOpenAcc bnd aenv)- body' <- executeOpenAcc body (aenv `Apush` bnd') stream+ travAF :: ExecOpenAfun arch aenv (a -> b) -> FutureArraysR arch a -> Par arch (FutureArraysR arch b)+ travAF (Alam lhs (Abody f)) a = executeOpenAcc f $ aenv `push` (lhs, a)+ travAF _ _ = error "boop!"++ travE :: Exp aenv t -> Par arch (FutureR arch t)+ travE exp = executeExp exp aenv++ travD :: DelayedOpenAcc ExecOpenAcc arch aenv a -> Par arch (FutureR arch (Delayed a))+ travD (AST.Delayed _ sh) = liftF1 Delayed (travE sh)+ travD (AST.Manifest _ a) = liftF1 Manifest (travA a)++ unit :: TypeR t -> Exp aenv t -> Par arch (FutureR arch (Scalar t))+ unit tp x = do+ x' <- travE x+ spawn $ newRemoteAsync (ArrayR ShapeRz tp) () . const =<< get x'++ -- Let bindings+ alet :: ALeftHandSide a aenv aenv' -> ExecOpenAcc arch aenv a -> ExecOpenAcc arch aenv' b -> Par arch (FutureArraysR arch b)+ alet lhs bnd body = do+ bnd' <- spawn $ executeOpenAcc bnd aenv+ body' <- spawn $ executeOpenAcc body $ aenv `push` (lhs, bnd') return body' - -- Access bound variables- avar :: Idx aenv a -> LLVM arch a- avar ix = do- let AsyncR event arr = aprj ix aenv- after stream event- return arr+ -- Allocate an array on the remote device+ allocate :: ArrayR (Array sh e) -> Exp aenv sh -> Par arch (FutureR arch (Array sh e))+ allocate repr sh = do+ r <- new+ sh' <- travE sh+ fork $ do+ arr <- allocateRemote repr =<< get sh'+ put r arr+ return r -- Array level conditionals- acond :: ExecOpenAcc arch aenv a -> ExecOpenAcc arch aenv a -> Bool -> LLVM arch a- acond yes _ True = travA yes- acond _ no False = travA no+ acond :: ExecOpenAcc arch aenv a+ -> ExecOpenAcc arch aenv a+ -> FutureR arch PrimBool+ -> Par arch (FutureArraysR arch a)+ acond yes no p =+ spawn $ do+ c <- block p+ if toBool c then travA yes+ else travA no -- Array loops- awhile :: ExecOpenAfun arch aenv (a -> Scalar Bool)+ awhile :: ExecOpenAfun arch aenv (a -> Scalar PrimBool) -> ExecOpenAfun arch aenv (a -> a)- -> a- -> LLVM arch a+ -> FutureArraysR arch a+ -> Par arch (FutureArraysR arch a) awhile p f a = do- e <- checkpoint stream- r <- travAF p (AsyncR e a)- ok <- indexRemote r 0- if ok then awhile p f =<< travAF f (AsyncR e a)- else return a+ r <- get =<< travAF p a+ ok <- indexRemote (TupRsingle scalarType) r 0+ if toBool ok then awhile p f =<< travAF f a+ else return a -- Pull apart the unzipped struct-of-array representation- unzip :: forall t sh e. (Elt t, Elt e) => TupleIdx (TupleRepr t) e -> Array sh t -> Array sh e- unzip tix (Array sh adata) = Array sh $ go tix (eltType (undefined::t)) adata+ unzip :: UnzipIdx t e -> Array sh t -> Array sh e+ unzip tix (Array sh adata) = Array sh $ go tix adata where- go :: TupleIdx v e -> TupleType t' -> ArrayData t' -> ArrayData (EltRepr e)- go (SuccTupIdx ix) (TypeRpair t _) (AD_Pair x _) = go ix t x- go ZeroTupIdx (TypeRpair _ t) (AD_Pair _ x)- | Just Refl <- matchTupleType t (eltType (undefined::e)) = x- go _ _ _ = $internalError "unzip" "inconsistent valuation"+ go :: UnzipIdx a b -> ArrayData a -> ArrayData b+ go UnzipUnit _ = ()+ go UnzipId ad = ad+ go (UnzipPrj PairIdxLeft ix) (ad, _) = go ix ad+ go (UnzipPrj PairIdxRight ix) (_, ad) = go ix ad+ go (UnzipPair ix1 ix2) ad = (go ix1 ad, go ix2 ad) - -- Can the permutation function write directly into the results array?+ map_ :: ExecOpenAcc arch aenv (Array sh a)+ -> ArrayR (Array sh a)+ -> TypeR b+ -> ExecutableR arch+ -> Gamma aenv+ -> ValR arch aenv+ -> Array sh a+ -> Par arch (FutureR arch (Array sh b))+ map_ a repr@(ArrayR _ tp) tp'+ = map (if inplace a then matchTypeR tp tp' else Nothing) repr tp'++ permute_ :: ExecOpenAcc arch aenv (Array sh' e)+ -> ArrayR (Array sh e)+ -> ShapeR sh'+ -> ExecutableR arch+ -> Gamma aenv+ -> ValR arch aenv+ -> Array sh' e+ -> Delayed (Array sh e)+ -> Par arch (FutureR arch (Array sh' e))+ permute_ d = permute (inplace d)++ -- Can the function store its results in-place to the input array? inplace :: ExecOpenAcc arch aenv a -> Bool- inplace (EvalAcc Avar{}) = False- inplace _ = True+ inplace a+ | unsafePerformIO (Debug.getFlag Debug.inplace) -- liftPar :: IO a -> Par arch a+ = case a of+ ExecAcc{} -> True+ EvalAcc _ pacc ->+ case pacc of+ Avar{} -> False+ Use{} -> False+ Unit{} -> False+ _ -> True+ --+ | otherwise+ = False -- Scalar expression evaluation -- ---------------------------- +-- TLM: Returning a future seems the correct thing to do here, but feels pretty+-- heavy-weight. In particular, perhaps we only need to know the shape of+-- an array before proceeding (i.e. scheduling execution of the next array)+-- without having to wait for the array elements to be evaluated.+--+-- Additionally, most operations do not interact with arrays and could be+-- evaluated directly (e.g. shape/index manipulations) (currently futures+-- are implemented in both backends as a data structure in an IORef, so we+-- could avoid some indirections).+--+ {-# INLINEABLE executeExp #-} executeExp :: Execute arch- => ExecExp arch aenv t- -> AvalR arch aenv- -> StreamR arch- -> LLVM arch t-executeExp exp aenv stream = executeOpenExp exp Empty aenv stream+ => Exp aenv t+ -> ValR arch aenv+ -> Par arch (FutureR arch t)+executeExp exp aenv = executeOpenExp exp Empty aenv {-# INLINEABLE executeOpenExp #-} executeOpenExp :: forall arch env aenv exp. Execute arch- => ExecOpenExp arch env aenv exp- -> Val env- -> AvalR arch aenv- -> StreamR arch- -> LLVM arch exp-executeOpenExp rootExp env aenv stream = travE rootExp+ => OpenExp env aenv exp+ -> ValR arch env+ -> ValR arch aenv+ -> Par arch (FutureR arch exp)+executeOpenExp rootExp env aenv = travE rootExp where- travE :: ExecOpenExp arch env aenv t -> LLVM arch t- travE exp = case exp of- Var ix -> return (prj ix env)- Let bnd body -> travE bnd >>= \x -> executeOpenExp body (env `Push` x) aenv stream- Undef -> return evalUndef- Const c -> return (toElt c)- PrimConst c -> return (evalPrimConst c)- PrimApp f x -> evalPrim f <$> travE x- Tuple t -> toTuple <$> travT t- Prj ix e -> evalPrj ix . fromTuple <$> travE e- Cond p t e -> travE p >>= \x -> if x then travE t else travE e+ travE :: OpenExp env aenv t -> Par arch (FutureR arch t)+ travE = \case+ Evar (Var _ ix) -> return $ prj ix env+ Let lhs bnd body -> do+ x <- travE bnd+ env' <- env `pushE` (lhs, x)+ executeOpenExp body env' aenv+ Undef tp -> newFull $ undefElt (TupRsingle tp)+ Const _ c -> newFull c+ PrimConst c -> newFull (evalPrimConst c)+ PrimApp f x -> lift1 (newFull . evalPrim f) (travE x)+ Nil -> newFull ()+ Pair e1 e2 -> liftF2 (,) (travE e1) (travE e2)+ VecPack vecr e -> liftF1 (pack vecr) (travE e)+ VecUnpack vecr e -> liftF1 (unpack vecr) (travE e)+ Case p xs x -> caseof xs x =<< travE p+ Cond p t e -> cond t e =<< travE p While p f x -> while p f =<< travE x- IndexAny -> return Any- IndexNil -> return Z- IndexCons sh sz -> (:.) <$> travE sh <*> travE sz- IndexHead sh -> (\(_ :. ix) -> ix) <$> travE sh- IndexTail sh -> (\(ix :. _) -> ix) <$> travE sh- IndexSlice ix slix sh -> indexSlice ix <$> travE slix <*> travE sh- IndexFull ix slix sl -> indexFull ix <$> travE slix <*> travE sl- ToIndex sh ix -> toIndex <$> travE sh <*> travE ix- FromIndex sh ix -> fromIndex <$> travE sh <*> travE ix- Intersect sh1 sh2 -> intersect <$> travE sh1 <*> travE sh2- Union sh1 sh2 -> union <$> travE sh1 <*> travE sh2- ShapeSize sh -> size <$> travE sh- Shape acc -> shape <$> travA acc- Index acc ix -> join $ index <$> travA acc <*> travE ix- LinearIndex acc ix -> join $ indexRemote <$> travA acc <*> travE ix- Foreign _ f x -> foreignE f x- Coerce x -> evalCoerce <$> travE x+ IndexSlice ix slix sh -> lift2 (newFull $$ indexSlice ix) (travE slix) (travE sh)+ IndexFull ix slix sl -> lift2 (newFull $$ indexFull ix) (travE slix) (travE sl)+ ToIndex shr sh ix -> lift2 (newFull $$ toIndex shr) (travE sh) (travE ix)+ FromIndex shr sh ix -> lift2 (newFull $$ fromIndex shr) (travE sh) (travE ix)+ ShapeSize shr sh -> lift1 (newFull . size shr) (travE sh)+ Shape var -> lift1 (newFull . shape) (travAvar var)+ Index (Var repr a) ix -> lift2 (index repr) (travAIdx a) (travE ix)+ LinearIndex (Var (ArrayR _ tp) a) ix -> lift2 (indexRemoteAsync tp) (travAIdx a) (travE ix)+ Coerce t1 t2 x -> lift1 (newFull . evalCoerceScalar t1 t2) (travE x)+ Foreign _ _ f x -> foreignE f x -- Helpers -- ------- - travT :: Tuple (ExecOpenExp arch env aenv) t -> LLVM arch t- travT tup = case tup of- NilTup -> return ()- SnocTup t e -> (,) <$> travT t <*> travE e+ travAvar :: ArrayVar aenv a -> Par arch (FutureR arch a)+ travAvar (Var _ ix) = travAIdx ix - travA :: ExecOpenAcc arch aenv a -> LLVM arch a- travA acc = executeOpenAcc acc aenv stream+ travAIdx :: Idx aenv a -> Par arch (FutureR arch a)+ travAIdx a = return $ prj a aenv - foreignE :: ExecFun arch () (a -> b) -> ExecOpenExp arch env aenv a -> LLVM arch b- foreignE (Lam (Body f)) x = travE x >>= \e -> executeOpenExp f (Empty `Push` e) Aempty stream- foreignE _ _ = error "I bless the rains down in Africa"+ foreignE :: Fun () (a -> b) -> OpenExp env aenv a -> Par arch (FutureR arch b)+ foreignE (Lam lhs (Body f)) x = do e <- travE x+ env' <- Empty `pushE` (lhs, e)+ executeOpenExp f env' Empty+ foreignE _ _ = error "I bless the rains down in Africa" - travF1 :: ExecOpenFun arch env aenv (a -> b) -> a -> LLVM arch b- travF1 (Lam (Body f)) x = executeOpenExp f (env `Push` x) aenv stream- travF1 _ _ = error "LANAAAAAAAA!"+ travF1 :: OpenFun env aenv (a -> b) -> FutureR arch a -> Par arch (FutureR arch b)+ travF1 (Lam lhs (Body f)) x = do env' <- env `pushE` (lhs, x)+ executeOpenExp f env' aenv+ travF1 _ _ = error "LANAAAAAAAA!" - while :: ExecOpenFun arch env aenv (a -> Bool) -> ExecOpenFun arch env aenv (a -> a) -> a -> LLVM arch a+ while :: OpenFun env aenv (a -> PrimBool)+ -> OpenFun env aenv (a -> a)+ -> FutureR arch a+ -> Par arch (FutureR arch a) while p f x = do- ok <- travF1 p x- if ok then while p f =<< travF1 f x- else return x+ ok <- block =<< travF1 p x+ if toBool ok then while p f =<< travF1 f x+ else return x - indexSlice :: (Elt slix, Elt sh, Elt sl)- => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+ cond :: OpenExp env aenv a+ -> OpenExp env aenv a+ -> FutureR arch PrimBool+ -> Par arch (FutureR arch a)+ cond yes no p =+ spawn $ do+ c <- block p+ if toBool c then travE yes+ else travE no++ caseof :: [(TAG, OpenExp env aenv a)]+ -> Maybe (OpenExp env aenv a)+ -> FutureR arch TAG+ -> Par arch (FutureR arch a)+ caseof xs d p =+ spawn $ do+ t <- block p+ case lookup t xs of+ Just r -> travE r+ Nothing -> case d of+ Just r -> travE r+ Nothing -> error "unmatched case"++ indexSlice :: SliceIndex slix sl co sh -> slix -> sh -> sl- indexSlice ix slix sh = toElt $ restrict ix (fromElt slix) (fromElt sh)+ indexSlice ix slix sh = restrict ix slix sh where restrict :: SliceIndex slix sl co sh -> slix -> sh -> sl restrict SliceNil () () = () restrict (SliceAll sliceIdx) (slx, ()) (sl, sz) = (restrict sliceIdx slx sl, sz) restrict (SliceFixed sliceIdx) (slx, _) (sl, _) = restrict sliceIdx slx sl - indexFull :: (Elt slix, Elt sh, Elt sl)- => SliceIndex (EltRepr slix) (EltRepr sl) co (EltRepr sh)+ indexFull :: SliceIndex slix sl co sh -> slix -> sl -> sh- indexFull ix slix sl = toElt $ extend ix (fromElt slix) (fromElt sl)+ indexFull ix slix sl = extend ix slix sl where extend :: SliceIndex slix sl co sh -> slix -> sl -> sh extend SliceNil () () = () extend (SliceAll sliceIdx) (slx, ()) (sh, sz) = (extend sliceIdx slx sh, sz) extend (SliceFixed sliceIdx) (slx, sz) sh = (extend sliceIdx slx sh, sz) - index :: Shape sh => Array sh e -> sh -> LLVM arch e- index arr ix = linearIndex arr (toIndex (shape arr) ix)+ index :: ArrayR (Array sh e) -> Array sh e -> sh -> Par arch (FutureR arch e)+ index (ArrayR shr tp) arr ix = indexRemoteAsync tp arr (toIndex shr (shape arr) ix) - linearIndex :: Array sh e -> Int -> LLVM arch e- linearIndex arr ix = do- block =<< checkpoint stream- indexRemote arr ix++-- Utilities+-- ---------++{-# INLINE toBool #-}+toBool :: PrimBool -> Bool+toBool 0 = False+toBool _ = True++{-# INLINE lift1 #-}+lift1 :: Async arch+ => (a -> Par arch (FutureR arch b))+ -> Par arch (FutureR arch a)+ -> Par arch (FutureR arch b)+lift1 f x = do+ x' <- x+ spawn $ f =<< get x'++{-# INLINE lift2 #-}+lift2 :: Async arch+ => (a -> b -> Par arch (FutureR arch c))+ -> Par arch (FutureR arch a)+ -> Par arch (FutureR arch b)+ -> Par arch (FutureR arch c)+lift2 f x y = do+ x' <- x+ y' <- y+ spawn $ id =<< liftM2 f (get x') (get y')++{-# INLINE liftF1 #-}+liftF1 :: Async arch+ => (a -> b)+ -> Par arch (FutureR arch a)+ -> Par arch (FutureR arch b)+liftF1 f x = do+ r <- new+ x' <- x+ fork $ put r . f =<< get x'+ return r++{-# INLINE liftF2 #-}+liftF2 :: Async arch+ => (a -> b -> c)+ -> Par arch (FutureR arch a)+ -> Par arch (FutureR arch b)+ -> Par arch (FutureR arch c)+liftF2 f x y = do+ r <- new+ x' <- x+ y' <- y+ fork $ put r =<< liftM2 f (get x') (get y')+ return r++{-# INLINE ($$) #-}+infixr 0 $$+($$) :: (b -> a) -> (c -> d -> b) -> c -> d -> a+(f $$ g) x y = f (g x y)++split :: Execute arch => ArraysR a -> FutureR arch a -> Par arch (FutureArraysR arch a)+split repr x = do+ rs <- newArrays repr+ fork $ get x >>= fill repr rs+ return rs+ where+ fill :: Execute arch => ArraysR a -> FutureArraysR arch a -> a -> Par arch ()+ fill TupRunit _ _ = return ()+ fill (TupRsingle ArrayR{}) r a = put r a+ fill (TupRpair repr1 repr2) (r1, r2) (a1, a2) = fill repr1 r1 a1 >> fill repr2 r2 a2
src/Data/Array/Accelerate/LLVM/Execute/Async.hs view
@@ -1,12 +1,16 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.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) --@@ -14,74 +18,96 @@ module Data.Array.Accelerate.LLVM.Execute.Async where -import Data.Array.Accelerate.LLVM.State+import Data.Array.Accelerate.LLVM.State ( LLVM )+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.Representation.Type +import GHC.Stack --- Asynchronous operations--- ----------------------- --- | The result of a potentially parallel computation which will be available at--- some point (presumably, in the future). This is essentially a write-once--- IVar.----data AsyncR arch a = AsyncR !(EventR arch) !a+class Monad (Par arch) => Async arch where -class Async arch where- -- | Streams (i.e. threads) can execute concurrently with other streams, but- -- operations within the same stream proceed sequentially.+ -- | The monad parallel computations will be executed in. Presumably a stack+ -- with the LLVM monad at the base. --- type StreamR arch+ data Par arch :: * -> * - -- | An Event marks a point in the execution stream, possibly in the future.- -- Since execution within a stream is sequential, events can be used to test- -- the progress of a computation and synchronise between different streams.+ -- | Parallel computations can communicate via futures. --- type EventR arch+ type FutureR arch :: * -> * - -- | Create a new execution stream that can be used to track (potentially- -- parallel) computations+ -- | Create a new (empty) promise, to be fulfilled at some future point. --- fork :: LLVM arch (StreamR arch)+ new :: HasCallStack => Par arch (FutureR arch a) - -- | Mark the given execution stream as closed. The stream may still be- -- executing in the background, but no new work may be submitted to it.+ -- | The future is here. Multiple 'put's to the same future are not allowed+ -- and (presumably) result in a runtime error. --- join :: StreamR arch -> LLVM arch ()+ put :: HasCallStack => FutureR arch a -> a -> Par arch () - -- | Generate a new event at the end of the given execution stream. It will be- -- filled once all prior work submitted to the stream has completed.+ -- | Read the value stored in a future, once it is available. It is _not_+ -- required that this is a blocking operation on the host, only that it is+ -- blocking with respect to computations on the remote device. --- checkpoint :: StreamR arch -> LLVM arch (EventR arch)+ get :: HasCallStack => FutureR arch a -> Par arch a - -- | Make all future work submitted to the given execution stream wait until- -- the given event has passed. Typically the event is from a different- -- execution stream, therefore this function is intended to enable- -- non-blocking cross-stream coordination.+ -- | Fork a computation to happen in parallel. The forked computation may+ -- exchange values with other computations using Futures. --- after :: StreamR arch -> EventR arch -> LLVM arch ()+ fork :: HasCallStack => Par arch () -> Par arch () - -- | Block execution of the calling thread until the given event has been- -- recorded.+ -- | Lift an operation from the base LLVM monad into the Par monad --- block :: EventR arch -> LLVM arch ()+ liftPar :: HasCallStack => LLVM arch a -> Par arch a + -- | Read a value stored in a future, once it is available. This is blocking+ -- with respect to both the host and remote device.+ --+ {-# INLINEABLE block #-}+ block :: HasCallStack => FutureR arch a -> Par arch a+ block = get --- | Wait for an asynchronous operation to complete, then return it.----{-# INLINEABLE get #-}-get :: Async arch => AsyncR arch a -> LLVM arch a-get (AsyncR e a) = block e >> return a+ -- | Evaluate a computation in a new thread/context. This might be implemented+ -- more efficiently than the default implementation.+ --+ {-# INLINEABLE spawn #-}+ spawn :: HasCallStack => Par arch a -> Par arch a+ spawn m = do+ r <- new+ fork $ put r =<< m+ get r --- | Execute the given operation asynchronously in a new execution stream.+ -- | Create a new "future" where the value is available immediately. This+ -- might be implemented more efficiently than the default implementation.+ --+ {-# INLINEABLE newFull #-}+ newFull :: HasCallStack => a -> Par arch (FutureR arch a)+ newFull a = do+ r <- new+ put r a+ return r++type family FutureArraysR arch arrs where+ FutureArraysR arch () = ()+ FutureArraysR arch (a, b) = (FutureArraysR arch a, FutureArraysR arch b)+ FutureArraysR arch (Array sh e) = FutureR arch (Array sh e)++getArrays :: Async arch => ArraysR a -> FutureArraysR arch a -> Par arch a+getArrays (TupRsingle ArrayR{}) a = get a+getArrays TupRunit _ = return ()+getArrays (TupRpair r1 r2) (a1, a2) = (,) <$> getArrays r1 a1 <*> getArrays r2 a2++blockArrays :: Async arch => ArraysR a -> FutureArraysR arch a -> Par arch a+blockArrays (TupRsingle ArrayR{}) a = block a+blockArrays TupRunit _ = return ()+blockArrays (TupRpair r1 r2) (a1, a2) = (,) <$> blockArrays r1 a1 <*> blockArrays r2 a2++-- | Create new (empty) promises for a structure of arrays, to be fulfilled+-- at some future point. Note that the promises in the structure may all be+-- fullfilled at different moments. ---{-# INLINEABLE async #-}-async :: Async arch- => (StreamR arch -> LLVM arch a)- -> LLVM arch (AsyncR arch a)-async f = do- s <- fork- r <- f s- e <- checkpoint s- join s- return $ AsyncR e r+newArrays :: Async arch => ArraysR a -> Par arch (FutureArraysR arch a)+newArrays TupRunit = return ()+newArrays (TupRsingle ArrayR{}) = new+newArrays (TupRpair repr1 repr2) = (,) <$> newArrays repr1 <*> newArrays repr2
src/Data/Array/Accelerate/LLVM/Execute/Environment.hs view
@@ -1,15 +1,13 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.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) --@@ -17,31 +15,49 @@ module Data.Array.Accelerate.LLVM.Execute.Environment where --- accelerate-import Data.Array.Accelerate.AST-#if __GLASGOW_HASKELL__ < 800-import Data.Array.Accelerate.Error-#endif+import Data.Array.Accelerate.AST ( ALeftHandSide, ELeftHandSide )+import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.AST.LeftHandSide+import Data.Array.Accelerate.Representation.Array import Data.Array.Accelerate.LLVM.Execute.Async --- Array environments--- ------------------+-- Environments+-- ------------ --- Valuation for an environment of array computations+-- Valuation for an environment of futures ---data AvalR arch env where- Aempty :: AvalR arch ()- Apush :: AvalR arch env -> AsyncR arch t -> AvalR arch (env, t)+data ValR arch env where+ Empty :: ValR arch ()+ Push :: ValR arch env -> FutureR arch t -> ValR arch (env, t) +push :: ValR arch env -> (ALeftHandSide t env env', FutureArraysR arch t) -> ValR arch env'+push env (LeftHandSideWildcard _ , _ ) = env+push env (LeftHandSideSingle ArrayR{}, a ) = env `Push` a+push env (LeftHandSidePair l1 l2 , (a1, a2)) = push env (l1, a1) `push` (l2, a2) +pushE :: Async arch => ValR arch env -> (ELeftHandSide t env env', FutureR arch t) -> Par arch (ValR arch env')+pushE env (LeftHandSideSingle _ , e) = return $ env `Push` e+pushE env (LeftHandSideWildcard _, _) = return env+pushE env (LeftHandSidePair l1 l2, e) = do+ -- TODO: This code creates many intermediate Futures, in case of deeply nested pairs.+ -- We could improve this to only construct Futures for the values actually stored+ -- in the environment and not have any intermediate ones. We can do that in a similar+ -- way as done in Data.Array.Accelerate.LLVM.Execute.split+ --+ e1 <- new+ e2 <- new+ fork $ do+ (v1, v2) <- get e+ put e1 v1+ put e2 v2+ env' <- pushE env (l1, e1)+ pushE env' (l2, e2)+ -- Projection of a value from a valuation using a de Bruijn index. ---aprj :: Idx env t -> AvalR arch env -> AsyncR arch t-aprj ZeroIdx (Apush _ x) = x-aprj (SuccIdx idx) (Apush val _) = aprj idx val-#if __GLASGOW_HASKELL__ < 800-aprj _ _ = $internalError "aprj" "inconsistent valuation"-#endif+prj :: Idx env t -> ValR arch env -> FutureR arch t+prj ZeroIdx (Push _ x) = x+prj (SuccIdx idx) (Push val _) = prj idx val
src/Data/Array/Accelerate/LLVM/Execute/Marshal.hs view
@@ -1,16 +1,23 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.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) --@@ -18,85 +25,102 @@ module Data.Array.Accelerate.LLVM.Execute.Marshal where --- accelerate import Data.Array.Accelerate.Array.Data-import Data.Array.Accelerate.Array.Sugar-import qualified Data.Array.Accelerate.Array.Representation as R+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.Environment ( Gamma, Idx'(..) )+import Data.Array.Accelerate.LLVM.Execute.Environment import Data.Array.Accelerate.LLVM.Execute.Async --- libraries import Data.DList ( DList ) import qualified Data.DList as DL+import qualified Data.IntMap as IM -- Marshalling arguments -- ---------------------+class Async arch => Marshal arch where+ -- | A type family that is used to specify a concrete kernel argument and+ -- stream/context type for a given backend target.+ --+ type ArgR arch --- | Convert function arguments into stream a form suitable for function calls----marshal :: Marshalable t args => t -> StreamR t -> args -> IO [ArgR t]-marshal target stream args = DL.toList `fmap` marshal' target stream args+ -- | Used to pass shapes as arguments to kernels.+ marshalInt :: Int -> ArgR arch + -- | Pass arrays to kernels+ marshalScalarData' :: SingleType e -> ScalarArrayData e -> Par arch (DList (ArgR arch)) --- | A type family that is used to specify a concrete kernel argument and--- stream/context type for a given backend target.+-- | Convert function arguments into stream a form suitable for function calls+-- The functions ending in a prime return a DList, other functions return lists. ---type family ArgR target+marshalArrays :: forall arch arrs. Marshal arch => ArraysR arrs -> arrs -> Par arch [ArgR arch]+marshalArrays repr arrs = DL.toList <$> marshalArrays' @arch repr arrs +marshalArrays' :: forall arch arrs. Marshal arch => ArraysR arrs -> arrs -> Par arch (DList (ArgR arch))+marshalArrays' = marshalTupR' @arch (marshalArray' @arch) --- | Data which can be marshalled as function arguments to kernels.------ These are just the basic definitions that don't require backend specific--- knowledge. To complete the definition, a backend must provide instances for:------ * Int -- for shapes--- * ArrayData e -- for array data--- * (Gamma aenv, Aval aenv) -- for free array variables----class Marshalable t a where- marshal' :: t -> StreamR t -> a -> IO (DList (ArgR t))+marshalArray' :: forall arch a. Marshal arch => ArrayR a -> a -> Par arch (DList (ArgR arch))+marshalArray' (ArrayR shr tp) (Array sh a) = do+ arg1 <- marshalArrayData' @arch tp a+ let arg2 = marshalShape' @arch shr sh+ return $ arg1 `DL.append` arg2 -instance Marshalable t () where- marshal' _ _ () = return DL.empty+marshalArrayData' :: forall arch t. Marshal arch => TypeR t -> ArrayData t -> Par arch (DList (ArgR arch))+marshalArrayData' TupRunit () = return DL.empty+marshalArrayData' (TupRpair t1 t2) (a1, a2) = do+ l1 <- marshalArrayData' t1 a1+ l2 <- marshalArrayData' t2 a2+ return $ l1 `DL.append` l2+marshalArrayData' (TupRsingle t) ad+ | ScalarArrayDict _ s <- scalarArrayDict t+ = marshalScalarData' @arch s ad -instance (Marshalable t a, Marshalable t b) => Marshalable t (a, b) where- marshal' t s (a, b) =- DL.concat `fmap` sequence [marshal' t s a, marshal' t s b]+marshalEnv :: forall arch aenv. Marshal arch => Gamma aenv -> ValR arch aenv -> Par arch [ArgR arch]+marshalEnv g a = DL.toList <$> marshalEnv' g a -instance (Marshalable t a, Marshalable t b, Marshalable t c) => Marshalable t (a, b, c) where- marshal' t s (a, b, c) =- DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c]+marshalEnv' :: forall arch aenv. Marshal arch => Gamma aenv -> ValR arch aenv -> Par arch (DList (ArgR arch))+marshalEnv' gamma aenv+ = fmap DL.concat+ $ mapM (\(_, Idx' repr idx) -> marshalArray' @arch repr =<< get (prj idx aenv)) (IM.elems gamma) -instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d) => Marshalable t (a, b, c, d) where- marshal' t s (a, b, c, d) =- DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d]+marshalShape :: forall arch sh. Marshal arch => ShapeR sh -> sh -> [ArgR arch]+marshalShape shr sh = DL.toList $ marshalShape' @arch shr sh -instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d, Marshalable t e)- => Marshalable t (a, b, c, d, e) where- marshal' t s (a, b, c, d, e) =- DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d, marshal' t s e]+marshalShape' :: forall arch sh. Marshal arch => ShapeR sh -> sh -> DList (ArgR arch)+marshalShape' ShapeRz () = DL.empty+marshalShape' (ShapeRsnoc shr) (sh, n) = marshalShape' @arch shr sh `DL.snoc` marshalInt @arch n -instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d, Marshalable t e, Marshalable t f)- => Marshalable t (a, b, c, d, e, f) where- marshal' t s (a, b, c, d, e, f) =- DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d, marshal' t s e, marshal' t s f]+type ParamsR arch = TupR (ParamR arch) -instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d, Marshalable t e, Marshalable t f, Marshalable t g)- => Marshalable t (a, b, c, d, e, f, g) where- marshal' t s (a, b, c, d, e, f, g) =- DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d, marshal' t s e, marshal' t s f, marshal' t s g]+data ParamR arch a where+ ParamRarray :: ArrayR (Array sh e) -> ParamR arch (Array sh e)+ ParamRmaybe :: ParamR arch a -> ParamR arch (Maybe a)+ ParamRfuture :: ParamR arch a -> ParamR arch (FutureR arch a)+ ParamRenv :: Gamma aenv -> ParamR arch (ValR arch aenv)+ ParamRint :: ParamR arch Int+ ParamRshape :: ShapeR sh -> ParamR arch sh+ ParamRargs :: ParamR arch (DList (ArgR arch)) -instance (Marshalable t a, Marshalable t b, Marshalable t c, Marshalable t d, Marshalable t e, Marshalable t f, Marshalable t g, Marshalable t h)- => Marshalable t (a, b, c, d, e, f, g, h) where- marshal' t s (a, b, c, d, e, f, g, h) =- DL.concat `fmap` sequence [marshal' t s a, marshal' t s b, marshal' t s c, marshal' t s d, marshal' t s e, marshal' t s f, marshal' t s g, marshal' t s h]+marshalParam' :: forall arch a. Marshal arch => ParamR arch a -> a -> Par arch (DList (ArgR arch))+marshalParam' (ParamRarray repr) a = marshalArray' repr a+marshalParam' (ParamRmaybe _ ) Nothing = return $ DL.empty+marshalParam' (ParamRmaybe repr) (Just a) = marshalParam' repr a+marshalParam' (ParamRfuture repr) future = marshalParam' repr =<< get future+marshalParam' (ParamRenv gamma) aenv = marshalEnv' gamma aenv+marshalParam' ParamRint x = return $ DL.singleton $ marshalInt @arch x+marshalParam' (ParamRshape shr) sh = return $ marshalShape' @arch shr sh+marshalParam' ParamRargs args = return args -instance Marshalable t a => Marshalable t [a] where- marshal' t s = fmap DL.concat . mapM (marshal' t s)+marshalParams' :: forall arch a. Marshal arch => ParamsR arch a -> a -> Par arch (DList (ArgR arch))+marshalParams' = marshalTupR' @arch (marshalParam' @arch) -instance (Shape sh, Marshalable t Int, Marshalable t (ArrayData (EltRepr e)))- => Marshalable t (Array sh e) where- marshal' t s (Array sh adata) =- marshal' t s (adata, reverse (R.shapeToList sh))+{-# INLINE marshalTupR' #-}+marshalTupR' :: forall arch s a. Marshal arch => (forall b. s b -> b -> Par arch (DList (ArgR arch))) -> TupR s a -> a -> Par arch (DList (ArgR arch))+marshalTupR' _ TupRunit () = return $ DL.empty+marshalTupR' f (TupRsingle t) x = f t x+marshalTupR' f (TupRpair t1 t2) (x1, x2) = DL.append <$> marshalTupR' @arch f t1 x1 <*> marshalTupR' @arch f t2 x2
+ src/Data/Array/Accelerate/LLVM/Extra.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : Data.Array.Accelerate.LLVM.Extra+-- 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.Extra+ where++import Data.Array.Accelerate.Error++import Data.Word+import qualified Data.Bits as B+++-- | The number of bits in a type+--+{-# INLINE bitSize #-}+bitSize :: HasCallStack => B.Bits a => a -> Word32+bitSize x+ | Just s <- B.bitSizeMaybe x = fromIntegral s+ | otherwise = internalError "could not determine bit size of type"+++-- | Convert a boolean value into an integral value, where False is zero and+-- True is one.+--+{-# INLINE fromBool #-}+fromBool :: Integral i => Bool -> i+fromBool True = 1+fromBool False = 0++-- | Convert an integral value into a boolean. We follow the C convention, where+-- zero is False and all other values represent True.+--+{-# INLINE toBool #-}+toBool :: Integral i => i -> Bool+toBool 0 = False+toBool _ = True+
src/Data/Array/Accelerate/LLVM/Foreign.hs view
@@ -2,10 +2,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.CodeGen.Foreign--- 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) --@@ -13,28 +13,23 @@ module Data.Array.Accelerate.LLVM.Foreign where -import Data.Array.Accelerate.Array.Sugar as A+import Data.Array.Accelerate.Sugar.Foreign as A import Data.Array.Accelerate.LLVM.CodeGen.Sugar import Data.Array.Accelerate.LLVM.Execute.Async-import Data.Array.Accelerate.LLVM.State -import Data.Typeable - -- | Interface for backends to provide foreign function implementations for -- array and scalar expressions. -- class Foreign arch where- foreignAcc :: (A.Foreign asm, Typeable a, Typeable b)- => arch {- dummy -}- -> asm (a -> b)- -> Maybe (StreamR arch -> a -> LLVM arch b)- foreignAcc _ _ = Nothing+ foreignAcc :: A.Foreign asm+ => asm (a -> b)+ -> Maybe (a -> Par arch (FutureR arch b))+ foreignAcc _ = Nothing - foreignExp :: (A.Foreign asm, Typeable x, Typeable y)- => arch {- dummy -}- -> asm (x -> y)+ foreignExp :: A.Foreign asm+ => asm (x -> y) -> Maybe (IRFun1 arch () (x -> y))- foreignExp _ _ = Nothing+ foreignExp _ = Nothing
src/Data/Array/Accelerate/LLVM/Link.hs view
@@ -1,14 +1,15 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.Link--- 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) --@@ -20,14 +21,12 @@ ExecOpenAcc(..), ExecOpenAfun, ExecAcc, ExecAfun,- ExecExp, ExecOpenExp,- ExecFun, ExecOpenFun ) where -- accelerate-import Data.Array.Accelerate.Array.Sugar hiding ( Foreign )-import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Array+import Data.Array.Accelerate.AST ( PreOpenAfun(..), HasArraysR(..) ) import Data.Array.Accelerate.LLVM.AST import Data.Array.Accelerate.LLVM.CodeGen.Environment@@ -35,7 +34,6 @@ import Data.Array.Accelerate.LLVM.State import Control.Applicative hiding ( Const )-import Control.DeepSeq import Prelude hiding ( exp ) @@ -54,29 +52,30 @@ -- target address space, suitable for execution. -- data ExecOpenAcc arch aenv a where- ExecAcc :: Gamma aenv+ ExecAcc :: ArraysR a+ -> Gamma aenv -> ExecutableR arch -> PreOpenAccSkeleton ExecOpenAcc arch aenv a -> ExecOpenAcc arch aenv a - EvalAcc :: Arrays a- => PreOpenAccCommand ExecOpenAcc arch aenv a+ EvalAcc :: ArraysR a+ -> PreOpenAccCommand ExecOpenAcc arch aenv a -> ExecOpenAcc arch aenv a +instance HasArraysR (ExecOpenAcc arch) where+ {-# INLINEABLE arraysR #-}+ arraysR (ExecAcc r _ _ _) = r+ arraysR (EvalAcc r _) = r+ -- An AST annotated with compiled and linked functions in the target address -- space, suitable for execution. -- type ExecOpenAfun arch = PreOpenAfun (ExecOpenAcc arch)-type ExecOpenExp arch = PreOpenExp (ExecOpenAcc arch)-type ExecOpenFun arch = PreOpenFun (ExecOpenAcc arch) type ExecAcc arch a = ExecOpenAcc arch () a type ExecAfun arch a = ExecOpenAfun arch () a -type ExecExp arch = ExecOpenExp arch ()-type ExecFun arch = ExecOpenFun arch () - -- | Link the compiled code for an array expression into the target address -- space. Additionally, copy input array data into the target address space. --@@ -100,8 +99,8 @@ :: Link arch => CompiledOpenAfun arch aenv f -> LLVM arch (ExecOpenAfun arch aenv f)-linkOpenAfun (Alam l) = Alam <$> linkOpenAfun l-linkOpenAfun (Abody b) = Abody <$> linkOpenAcc b+linkOpenAfun (Alam lhs l) = Alam lhs <$> linkOpenAfun l+linkOpenAfun (Abody b) = Abody <$> linkOpenAcc b {-# INLINEABLE linkOpenAcc #-} linkOpenAcc@@ -111,96 +110,42 @@ linkOpenAcc = travA where travA :: forall aenv arrs. CompiledOpenAcc arch aenv arrs -> LLVM arch (ExecOpenAcc arch aenv arrs)- travA (PlainAcc pacc) = EvalAcc <$>+ travA (PlainAcc repr' pacc) = EvalAcc repr' <$> case pacc of Unzip tix ix -> return (Unzip tix ix) Avar ix -> return (Avar ix)- Use arrs -> rnfArrs (arrays (undefined::arrs)) arrs `seq` return (Use arrs)- Unit e -> Unit <$> travE e- Alloc sh -> Alloc <$> travE sh- Alet a b -> Alet <$> travA a <*> travA b- Apply f a -> Apply <$> travAF f <*> travA a- Awhile p f a -> Awhile <$> travAF p <*> travAF f <*> travA a- Acond p t e -> Acond <$> travE p <*> travA t <*> travA e- Atuple tup -> Atuple <$> travAtup tup- Aprj ix tup -> Aprj ix <$> travA tup- Reshape s ix -> Reshape <$> travE s <*> pure ix- Aforeign s f a -> Aforeign s f <$> travA a+ Use repr arr -> rnfArray repr arr `seq` return (Use repr arr)+ Unit tp e -> return $ Unit tp e+ Alloc repr sh -> return $ Alloc repr sh+ Alet lhs a b -> Alet lhs <$> travA a <*> travA b+ Apply repr f a -> Apply repr <$> travAF f <*> travA a+ Awhile p f a -> Awhile <$> travAF p <*> travAF f <*> travA a+ Acond p t e -> Acond p <$> travA t <*> travA e+ Apair a1 a2 -> Apair <$> travA a1 <*> travA a2+ Anil -> return Anil+ Reshape shr s ix -> Reshape shr s <$> pure ix+ Aforeign s r f a -> Aforeign s r f <$> travA a - travA (BuildAcc aenv obj pacc) = ExecAcc aenv <$> linkForTarget obj <*>+ travA (BuildAcc repr' aenv obj pacc) = ExecAcc repr' aenv <$> linkForTarget obj <*> case pacc of- Map sh -> Map <$> travE sh- Generate sh -> Generate <$> travE sh- Transform sh -> Transform <$> travE sh- Backpermute sh -> Backpermute <$> travE sh- Fold sh -> Fold <$> travE sh- Fold1 sh -> Fold1 <$> travE sh- FoldSeg sa ss -> FoldSeg <$> travE sa <*> travE ss- Fold1Seg sa ss -> Fold1Seg <$> travE sa <*> travE ss- Scanl sh -> Scanl <$> travE sh- Scanl1 sh -> Scanl1 <$> travE sh- Scanl' sh -> Scanl' <$> travE sh- Scanr sh -> Scanr <$> travE sh- Scanr1 sh -> Scanr1 <$> travE sh- Scanr' sh -> Scanr' <$> travE sh- Permute sh d -> Permute <$> travE sh <*> travA d- Stencil sh -> Stencil <$> travE sh- Stencil2 sh1 sh2 -> Stencil2 <$> travE sh1 <*> travE sh2+ Map tp a -> Map tp <$> travA a+ Generate repr sh -> return $ Generate repr sh+ Transform repr sh a -> Transform repr sh <$> travA a+ Backpermute shr sh a -> Backpermute shr sh <$> travA a+ Fold z a -> Fold z <$> travD a+ FoldSeg i z a s -> FoldSeg i z <$> travD a <*> travD s+ Scan d z a -> Scan d z <$> travD a+ Scan' d a -> Scan' d <$> travD a+ Permute d a -> Permute <$> travA d <*> travD a+ Stencil1 tp h a -> Stencil1 tp h <$> travD a+ Stencil2 tp h a b -> Stencil2 tp h <$> travD a <*> travD b travAF :: CompiledOpenAfun arch aenv f -> LLVM arch (ExecOpenAfun arch aenv f) travAF = linkOpenAfun - travAtup :: Atuple (CompiledOpenAcc arch aenv) a- -> LLVM arch (Atuple (ExecOpenAcc arch aenv) a)- travAtup NilAtup = return NilAtup- travAtup (SnocAtup t a) = SnocAtup <$> travAtup t <*> travA a-- travF :: CompiledOpenFun arch env aenv t- -> LLVM arch (ExecOpenFun arch env aenv t)- travF (Body b) = Body <$> travE b- travF (Lam f) = Lam <$> travF f-- travE :: CompiledOpenExp arch env aenv t- -> LLVM arch (ExecOpenExp arch env aenv t)- travE exp =- case exp of- Var ix -> return (Var ix)- Const c -> return (Const c)- PrimConst c -> return (PrimConst c)- Undef -> return Undef- IndexAny -> return IndexAny- IndexNil -> return IndexNil- Let a b -> Let <$> travE a <*> travE b- IndexCons t h -> IndexCons <$> travE t <*> travE h- IndexHead h -> IndexHead <$> travE h- IndexTail t -> IndexTail <$> travE t- IndexSlice slix x s -> (IndexSlice slix) <$> travE x <*> travE s- IndexFull slix x s -> (IndexFull slix) <$> travE x <*> travE s- ToIndex s i -> ToIndex <$> travE s <*> travE i- FromIndex s i -> FromIndex <$> travE s <*> travE i- Tuple t -> Tuple <$> travT t- Prj ix e -> (Prj ix) <$> travE e- Cond p t e -> Cond <$> travE p <*> travE t <*> travE e- While p f x -> While <$> travF p <*> travF f <*> travE x- PrimApp f e -> (PrimApp f) <$> travE e- Index a e -> Index <$> travA a <*> travE e- LinearIndex a e -> LinearIndex <$> travA a <*> travE e- Shape a -> Shape <$> travA a- ShapeSize e -> ShapeSize <$> travE e- Intersect x y -> Intersect <$> travE x <*> travE y- Union x y -> Union <$> travE x <*> travE y- Coerce x -> Coerce <$> travE x- Foreign asm _ x -> Foreign asm err <$> travE x- where err = $internalError "link" "attempt to use fallback foreign expression"-- travT :: Tuple (CompiledOpenExp arch env aenv) t- -> LLVM arch (Tuple (ExecOpenExp arch env aenv) t)- travT NilTup = return NilTup- travT (SnocTup t e) = SnocTup <$> travT t <*> travE e-- rnfArrs :: ArraysR a -> a -> ()- rnfArrs (ArraysRpair ar1 ar2) (a1, a2) = rnfArrs ar1 a1 `seq` rnfArrs ar2 a2- rnfArrs ArraysRarray arr = rnf arr- rnfArrs ArraysRunit () = ()+ travD :: DelayedOpenAcc CompiledOpenAcc arch aenv a+ -> LLVM arch (DelayedOpenAcc ExecOpenAcc arch aenv a)+ travD (Manifest r a) = Manifest r <$> travA a+ travD (Delayed r sh) = return $ Delayed r sh
src/Data/Array/Accelerate/LLVM/Link/Cache.hs view
@@ -1,10 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.Link.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) --
src/Data/Array/Accelerate/LLVM/State.hs view
@@ -3,11 +3,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.State--- 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,7 +15,6 @@ where -- library-import Control.Applicative ( Applicative ) import Control.Concurrent ( forkIO, threadDelay ) import Control.Monad.Catch ( MonadCatch, MonadThrow, MonadMask ) import Control.Monad.State ( StateT, MonadState, evalStateT )
src/Data/Array/Accelerate/LLVM/Target.hs view
@@ -1,14 +1,11 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.LLVM.Target--- 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) --@@ -23,6 +20,6 @@ -- | Describes some target specific information needed for code generation -- class Target t where- targetTriple :: t {- dummy -} -> Maybe ShortByteString- targetDataLayout :: t {- dummy -} -> Maybe DataLayout+ targetTriple :: Maybe ShortByteString+ targetDataLayout :: Maybe DataLayout
− src/Data/Array/Accelerate/LLVM/Util.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Data.Array.Accelerate.LLVM.Util--- 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)------ Generate types for the reified elements of an array computation-----module Data.Array.Accelerate.LLVM.Util- where---- accelerate-import Data.Array.Accelerate.Error---- standard library-import Data.Word-import qualified Data.Bits as B----- | The number of bits in a type----{-# INLINE bitSize #-}-bitSize :: B.Bits a => a -> Word32-bitSize x- | Just s <- B.bitSizeMaybe x = fromIntegral s- | otherwise = $internalError "bitSize" "could not determine bit size of type"----- | Convert a boolean value into an integral value, where False is zero and--- True is one.----{-# INLINE fromBool #-}-fromBool :: Integral i => Bool -> i-fromBool True = 1-fromBool False = 0---- | Convert an integral value into a boolean. We follow the C convention, where--- zero is False and all other values represent True.----{-# INLINE toBool #-}-toBool :: Integral i => i -> Bool-toBool 0 = False-toBool _ = True-
src/Data/ByteString/Short/Char8.hs view
@@ -1,10 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.ByteString.Short.Char8--- 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) --
src/Data/ByteString/Short/Extra.hs view
@@ -1,13 +1,14 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.ByteString.Short.Extra--- 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) --@@ -17,12 +18,19 @@ ShortByteString, take, takeWhile,+ liftSBS, ) where import Data.ByteString.Short ( ShortByteString ) import qualified Data.ByteString.Short as BS import qualified Data.ByteString.Short.Internal as BI++import Language.Haskell.TH ( Q, TExp )+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH++import System.IO.Unsafe import Prelude hiding ( take, takeWhile ) import GHC.ST@@ -66,6 +74,15 @@ | p (indexWord8Array ba i) = i | otherwise = go (i+1) ++-- | Lift a ShortByteString into a Template Haskell splice+--+liftSBS :: ShortByteString -> Q (TExp ShortByteString)+liftSBS bs =+ let bytes = BS.unpack bs+ len = BS.length bs+ in+ [|| unsafePerformIO $ BI.createFromPtr $$( TH.unsafeTExpCoerce [| Ptr $(TH.litE (TH.StringPrimL bytes)) |]) len ||] ------------------------------------------------------------------------ -- Internal utils
− src/Data/Range.hs
@@ -1,184 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-{-# OPTIONS_HADDOCK hide #-}--- |--- Module : Data.Range--- 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.Range- where---- accelerate-import Data.Array.Accelerate.Error---- standard library-import Prelude hiding ( take, splitAt )-import GHC.Base ( quotInt )-import Text.Printf--import Data.Sequence ( Seq )-import qualified Data.Sequence as Seq----- | A simple range data type----data Range- = Empty -- ^ The empty range- | IE !Int !Int -- ^ A range span with inclusive left, exclusive right- deriving Eq--instance Show Range where- show Empty = "empty"- show (IE u v)- | u == pred v = printf "singleton %d" u- | otherwise = printf "[%d...%d]" u (pred v) -- note display with inclusive ends----- | An empty interval-{-# INLINE empty #-}-empty :: Range-empty = Empty---- | Check if an interval is empty----{-# INLINE null #-}-null :: Range -> Bool-null Empty = True-null _ = False---- | A singleton point----{-# INLINE singleton #-}-singleton :: Int -> Range-singleton !a = IE a (succ a)---- | A range span with exclusive endpoint [u,v).----{-# INLINE (...) #-}-(...) :: Int -> Int -> Range-u ... v- | u <= v = IE u (succ v)- | otherwise = Empty-infix 3 ...----- | /O(1)/. The number of elements defined by the range interval----{-# INLINE size #-}-size :: Range -> Int-size range =- case range of- Empty -> 0- IE u v -> v - u----- | /O(1)/. Split an interval into two roughly equally sized ranges. If the interval is--- odd then the first interval gets the extra element.----{-# INLINE bisect #-}-bisect :: Range -> (Range, Range)-bisect range =- case range of- Empty -> (Empty, Empty)- IE u v ->- let n = size range- m = (n + 1) `quotInt` 2- o = u+m-- x = IE u o- y | o < v = IE o v- | otherwise = Empty- in- (x, y)----- | /O(1)/. Return the first @n@ elements of the range, or the range itself if--- @n > size@.----{-# INLINE take #-}-take :: Int -> Range -> Range-take !n !_ | n <= 0 = Empty-take !n !range =- case range of- Empty -> Empty- IE u v -> IE u ((u+n) `min` v)----- | /O(1)/. A tuple where the first element is the first @n@ elements of the range, and--- the second is the remainder of the list (if any).----{-# INLINE splitAt #-}-splitAt :: Int -> Range -> (Range, Range)-splitAt !n !range | n <= 0 = (Empty, range)-splitAt !n !range =- case range of- Empty -> (Empty, Empty)- IE u v ->- let m = u+n- x = IE u (m `min` v)- y | m < v = IE m v- | otherwise = Empty- in- (x, y)----- | If the two ranges are adjacent, return one combined range. The ranges must--- not be empty.----{-# INLINE merge #-}-merge :: Range -> Range -> Maybe Range-merge (IE u v) (IE x y)- | v == x = Just (IE u y)- | otherwise = Nothing-merge _ _ = $internalError "merge" "empty range encountered"----- | /O(1)/. Add a new range to the end of the given sequence. We assume that--- ranges are non-overlapping and non-empty. If the new range is adjacent to the--- last range on the sequence, the ranges are appended.----{-# INLINEABLE append #-}-append :: Seq Range -> Range -> Seq Range-append rs Empty = rs-append rs next =- case Seq.viewr rs of- Seq.EmptyR -> Seq.singleton next- rs' Seq.:> prev- | Just r <- merge prev next -> rs' Seq.|> r- | otherwise -> rs Seq.|> next----- | /O(n log n)/. Compress the given ranges into the fewest number of sections--- as possible. The ranges must not be empty.----{-# INLINEABLE compress #-}-compress :: Seq Range -> Seq Range-compress = squash . Seq.unstableSortBy cmp- where- -- Compare by the lower bound. Assume ranges are non-overlapping.- --- cmp (IE u _) (IE v _) = compare u v- cmp _ _ = $internalError "compress" "empty range encountered"-- -- Look at the first two elements, compress them if they are adjacent, and- -- continue walking down the sequence doing the same. If we merge a range,- -- be sure to continue attempting to merge that with subsequent ranges- --- squash rrs =- case Seq.viewl rrs of- Seq.EmptyL -> Seq.empty- r1 Seq.:< rs -> case Seq.viewl rs of- Seq.EmptyL -> rrs- r2 Seq.:< rs'- | Just r12 <- merge r1 r2 -> squash $ r12 Seq.<| rs'- | otherwise -> r1 Seq.<| squash rs-
src/LLVM/AST/Type/AddrSpace.hs view
@@ -1,10 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.AddrSpace--- 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) --
src/LLVM/AST/Type/Constant.hs view
@@ -1,11 +1,16 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Constant--- 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) --@@ -13,10 +18,20 @@ module LLVM.AST.Type.Constant where +import LLVM.AST.Type.Downcast import LLVM.AST.Type.Name import LLVM.AST.Type.Representation +import qualified LLVM.AST.Constant as LLVM+import qualified LLVM.AST.Float as LLVM+import qualified LLVM.AST.Type as LLVM +import Data.Constraint+import Data.Primitive.ByteArray+import Data.Primitive.Types+import Data.Primitive.Vec++ -- | Although constant expressions and instructions have many similarities, -- there are important differences - so they're represented using different -- types in this AST. At the cost of making it harder to move an code back and@@ -32,10 +47,78 @@ -> a -> Constant a + BooleanConstant :: Bool+ -> Constant Bool+ UndefConstant :: Type a -> Constant a GlobalReference :: Type a -> Name a -> Constant a+++-- | Convert to llvm-hs+--+instance Downcast (Constant a) LLVM.Constant where+ downcast = \case+ UndefConstant t -> LLVM.Undef (downcast t)+ GlobalReference t n -> LLVM.GlobalReference (downcast t) (downcast n)+ BooleanConstant x -> LLVM.Int 1 (toInteger (fromEnum x))+ ScalarConstant t x -> scalar t x+ where+ scalar :: ScalarType s -> s -> LLVM.Constant+ scalar (SingleScalarType s) = single s+ scalar (VectorScalarType s) = vector s++ single :: SingleType s -> s -> LLVM.Constant+ single (NumSingleType s) = num s++ vector :: VectorType s -> s -> LLVM.Constant+ vector (VectorType _ s) (Vec ba#)+ = LLVM.Vector+ $ map (single s)+ $ singlePrim s `withDict` foldrByteArray (:) [] (ByteArray ba#)++ num :: NumType s -> s -> LLVM.Constant+ num (IntegralNumType s) v+ | IntegralDict <- integralDict s+ = LLVM.Int (LLVM.typeBits (downcast s)) (fromIntegral v)++ num (FloatingNumType s) v+ = LLVM.Float+ $ case s of+ TypeFloat -> LLVM.Single v+ TypeDouble -> LLVM.Double v+ TypeHalf | Half (CUShort u) <- v -> LLVM.Half u++ singlePrim :: SingleType s -> Dict (Prim s)+ singlePrim (NumSingleType s) = numPrim s++ numPrim :: NumType s -> Dict (Prim s)+ numPrim (IntegralNumType s) = integralPrim s+ numPrim (FloatingNumType s) = floatingPrim s++ integralPrim :: IntegralType s -> Dict (Prim s)+ integralPrim TypeInt = Dict+ integralPrim TypeInt8 = Dict+ integralPrim TypeInt16 = Dict+ integralPrim TypeInt32 = Dict+ integralPrim TypeInt64 = Dict+ integralPrim TypeWord = Dict+ integralPrim TypeWord8 = Dict+ integralPrim TypeWord16 = Dict+ integralPrim TypeWord32 = Dict+ integralPrim TypeWord64 = Dict++ floatingPrim :: FloatingType s -> Dict (Prim s)+ floatingPrim TypeHalf = Dict+ floatingPrim TypeFloat = Dict+ floatingPrim TypeDouble = Dict++instance TypeOf Constant where+ typeOf (BooleanConstant _) = type'+ typeOf (ScalarConstant t _) = PrimType (ScalarPrimType t)+ typeOf (UndefConstant t) = t+ typeOf (GlobalReference t _) = t
+ src/LLVM/AST/Type/Downcast.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Downcast+-- Copyright : [2015..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Downcast (++ Downcast(..),++) where++import Data.Array.Accelerate.Type+import qualified LLVM.AST.Type as LLVM++import Data.Bits++import GHC.Stack+++-- | Convert a value from our representation of the LLVM AST which uses+-- Haskell-level types, into the llvm-hs representation where types are+-- represented only at the value level.+--+-- The type-level information to generate the appropriate value-level types.+--+class Downcast typed untyped where+ downcast :: HasCallStack => typed -> untyped++instance Downcast a a' => Downcast [a] [a'] where+ downcast = map downcast++instance Downcast a a' => Downcast (Maybe a) (Maybe a') where+ downcast Nothing = Nothing+ downcast (Just x) = Just (downcast x)++instance (Downcast a a', Downcast b b') => Downcast (a,b) (a',b') where+ downcast (a,b) = (downcast a, downcast b)++instance (Downcast a a', Downcast b b') => Downcast (Either a b) (Either a' b') where+ downcast (Left a) = Left (downcast a)+ downcast (Right b) = Right (downcast b)+++instance Downcast (ScalarType a) LLVM.Type where+ downcast (SingleScalarType t) = downcast t+ downcast (VectorScalarType t) = downcast t++instance Downcast (SingleType a) LLVM.Type where+ downcast (NumSingleType t) = downcast t++instance Downcast (VectorType a) LLVM.Type where+ downcast (VectorType n t) = LLVM.VectorType (fromIntegral n) (downcast t)++instance Downcast (BoundedType t) LLVM.Type where+ downcast (IntegralBoundedType t) = downcast t++instance Downcast (NumType a) LLVM.Type where+ downcast (IntegralNumType t) = downcast t+ downcast (FloatingNumType t) = downcast t++instance Downcast (IntegralType a) LLVM.Type where+ downcast TypeInt = LLVM.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Int)) |] )+ downcast TypeInt8 = LLVM.IntegerType 8+ downcast TypeInt16 = LLVM.IntegerType 16+ downcast TypeInt32 = LLVM.IntegerType 32+ downcast TypeInt64 = LLVM.IntegerType 64+ downcast TypeWord = LLVM.IntegerType $( [| fromIntegral (finiteBitSize (undefined :: Word)) |] )+ downcast TypeWord8 = LLVM.IntegerType 8+ downcast TypeWord16 = LLVM.IntegerType 16+ downcast TypeWord32 = LLVM.IntegerType 32+ downcast TypeWord64 = LLVM.IntegerType 64++instance Downcast (FloatingType a) LLVM.Type where+ downcast TypeHalf = LLVM.FloatingPointType LLVM.HalfFP+ downcast TypeFloat = LLVM.FloatingPointType LLVM.FloatFP+ downcast TypeDouble = LLVM.FloatingPointType LLVM.DoubleFP+
src/LLVM/AST/Type/Flags.hs view
@@ -3,10 +3,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Flags--- 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) --
+ src/LLVM/AST/Type/Function.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.Function+-- Copyright : [2015..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.Function+ where++import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Name+import LLVM.AST.Type.Operand+import LLVM.AST.Type.Representation++import qualified LLVM.AST.Attribute as LLVM+import qualified LLVM.AST.Global as LLVM+import qualified LLVM.AST.Instruction as LLVM+++-- | Attributes for the function call instruction+--+data FunctionAttribute+ = NoReturn+ | NoUnwind+ | ReadOnly+ | ReadNone+ | AlwaysInline+ | NoDuplicate+ | Convergent++-- | Tail call kind for function call instruction+--+data TailCall+ = Tail+ | NoTail+ | MustTail++-- | Parameters for functions+--+data Parameter a where+ Parameter :: PrimType a -> Name a -> Parameter a++-- | Attribute groups are groups of attributes that are referenced by+-- objects within the IR. To use an attribute group, an object must+-- reference its GroupID.+--+data GroupID = GroupID !Word+++-- | Functions are arguments to the 'call' instruction; either global+-- functions or inline assembly.+--+data Function kind args t where+ Body :: Type r -> Maybe TailCall -> kind -> Function kind '[] r+ Lam :: PrimType a -> Operand a -> Function kind args t -> Function kind (a ': args) t++data HList (l :: [*]) where+ HNil :: HList '[]+ HCons :: e -> HList l -> HList (e ': l)+++instance Downcast FunctionAttribute LLVM.FunctionAttribute where+ downcast NoReturn = LLVM.NoReturn+ downcast NoUnwind = LLVM.NoUnwind+ downcast ReadOnly = LLVM.ReadOnly+ downcast ReadNone = LLVM.ReadNone+ downcast AlwaysInline = LLVM.AlwaysInline+ downcast NoDuplicate = LLVM.NoDuplicate+ downcast Convergent = LLVM.Convergent++instance Downcast (Parameter a) LLVM.Parameter where+ downcast (Parameter t n) = LLVM.Parameter (downcast t) (downcast n) attrs+ where+ attrs | PtrPrimType{} <- t = [LLVM.NoAlias, LLVM.NoCapture] -- XXX: alignment+ | otherwise = []++instance Downcast TailCall LLVM.TailCallKind where+ downcast Tail = LLVM.Tail+ downcast NoTail = LLVM.NoTail+ downcast MustTail = LLVM.MustTail++instance Downcast GroupID LLVM.GroupID where+ downcast (GroupID n) = LLVM.GroupID n+
src/LLVM/AST/Type/Global.hs view
@@ -1,14 +1,16 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Global--- 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) --@@ -16,40 +18,30 @@ module LLVM.AST.Type.Global where +import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Function import LLVM.AST.Type.Name-import LLVM.AST.Type.Operand-import LLVM.AST.Type.Representation +import qualified LLVM.AST.Global as LLVM+import qualified LLVM.AST.Name as LLVM+import qualified LLVM.AST.Type as LLVM --- | Parameters for functions----data Parameter a where- Parameter :: PrimType a -> Name a -> Parameter a --- | Attributes for the function call instruction----data FunctionAttribute- = NoReturn- | NoUnwind- | ReadOnly- | ReadNone- | AlwaysInline- | NoDuplicate- | Convergent---- | Attribute groups are groups of attributes that are referenced by--- objects within the IR. To use an attribute group, an object must--- reference its GroupID.----data GroupID = GroupID !Word- -- | A global function definition. ---data GlobalFunction args t where- Body :: Type r -> Label -> GlobalFunction '[] r- Lam :: PrimType a -> Operand a -> GlobalFunction args t -> GlobalFunction (a ': args) t+type GlobalFunction args t = Function Label args t -data HList (l :: [*]) where- HNil :: HList '[]- HCons :: e -> HList l -> HList (e ': l)+instance Downcast (GlobalFunction args t) LLVM.Global where+ downcast f = LLVM.functionDefaults { LLVM.name = nm+ , LLVM.returnType = res+ , LLVM.parameters = (params, False)+ }+ where+ trav :: GlobalFunction args t -> ([LLVM.Type], LLVM.Type, LLVM.Name)+ trav (Body t _ n) = ([], downcast t, downcast n)+ trav (Lam a _ l) = let (as, r, n) = trav l+ in (downcast a : as, r, n)+ --+ (args, res, nm) = trav f+ params = [ LLVM.Parameter t (LLVM.UnName i) [] | t <- args | i <- [0..] ]
+ src/LLVM/AST/Type/InlineAssembly.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_HADDOCK hide #-}+-- |+-- Module : LLVM.AST.Type.InlineAssembly+-- Copyright : [2015..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module LLVM.AST.Type.InlineAssembly (++ module LLVM.AST.Type.InlineAssembly,+ LLVM.Dialect(..),++) where++import LLVM.AST.Type.Downcast++import qualified LLVM.AST.Type as LLVM+import qualified LLVM.AST.InlineAssembly as LLVM++import Data.ByteString+import Data.ByteString.Short+++-- | The 'call' instruction might be a label or inline assembly+--+data InlineAssembly where+ InlineAssembly :: ByteString -- assembly+ -> ShortByteString -- constraints+ -> Bool -- has side effects?+ -> Bool -- align stack?+ -> LLVM.Dialect+ -> InlineAssembly++instance Downcast (LLVM.Type, InlineAssembly) LLVM.InlineAssembly where+ downcast (t, InlineAssembly asm cst s a d) =+ LLVM.InlineAssembly t asm cst s a d+
src/LLVM/AST/Type/Instruction.hs view
@@ -1,14 +1,21 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Instruction--- 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) --@@ -16,21 +23,38 @@ module LLVM.AST.Type.Instruction where -import LLVM.AST.Type.Global+import LLVM.AST.Type.Constant+import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Function+import LLVM.AST.Type.InlineAssembly import LLVM.AST.Type.Name import LLVM.AST.Type.Operand import LLVM.AST.Type.Representation -import LLVM.AST.Type.Instruction.Atomic-import LLVM.AST.Type.Instruction.Compare-import LLVM.AST.Type.Instruction.RMW-import LLVM.AST.Type.Instruction.Volatile+import LLVM.AST.Type.Instruction.Atomic ( Atomicity, MemoryOrdering )+import LLVM.AST.Type.Instruction.Compare ( Ordering(..) )+import LLVM.AST.Type.Instruction.RMW ( RMWOperation )+import LLVM.AST.Type.Instruction.Volatile ( Volatility ) -import Data.Array.Accelerate.Product ( ProdRepr, TupleIdx )+import qualified LLVM.AST.Constant as LLVM ( Constant(GlobalReference, Int) )+import qualified LLVM.AST.AddrSpace as LLVM+import qualified LLVM.AST.CallingConvention as LLVM+import qualified LLVM.AST.FloatingPointPredicate as FP+import qualified LLVM.AST.Instruction as LLVM+import qualified LLVM.AST.IntegerPredicate as IP+import qualified LLVM.AST.Operand as LLVM ( Operand(..), CallableOperand )+import qualified LLVM.AST.ParameterAttribute as LLVM ( ParameterAttribute )+import qualified LLVM.AST.Type as LLVM ( Type(..) ) -import Prelude hiding ( Ordering )+import Data.Array.Accelerate.AST ( PrimBool )+import Data.Array.Accelerate.AST.Idx+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Type+import Data.Primitive.Vec +import Prelude hiding ( Ordering(..), quot, rem, div, isNaN, tail ) + -- | Non-terminating instructions -- -- * <http://llvm.org/docs/LangRef.html#binary-operations>@@ -157,17 +181,16 @@ -- <http://llvm.org/docs/LangRef.html#extractelement-instruction> --- ExtractElement :: VectorType (v e)- -> TupleIdx (ProdRepr (v e)) e- -> Operand (v e)- -> Instruction e+ ExtractElement :: Int32 -- TupleIdx (ProdRepr (Vec n a)) a+ -> Operand (Vec n a)+ -> Instruction a -- <http://llvm.org/docs/LangRef.html#insertelement-instruction> --- InsertElement :: Int32 -- TupleIdx (ProdRepr (v a)) a- -> Operand (v a)+ InsertElement :: Int32 -- TupleIdx (ProdRepr (Vec n a)) a+ -> Operand (Vec n a) -> Operand a- -> Instruction (v a)+ -> Instruction (Vec n a) -- ShuffleVector @@ -175,9 +198,13 @@ -- -------------------- -- <http://llvm.org/docs/LangRef.html#extractvalue-instruction>+ -- ExtractValue is currently restricted to pairs, we might want+ -- to allow larger structures. It is currently however only used+ -- for CmpXchg, which returns a pair so we don't need this for+ -- other structures. -- ExtractValue :: ScalarType t- -> TupleIdx (ProdRepr tup) t+ -> PairIdx tup t -> Operand tup -> Instruction t @@ -220,15 +247,15 @@ CmpXchg :: IntegralType a -> Volatility -> Operand (Ptr a)- -> Operand a -- expected value- -> Operand a -- replacement value- -> Atomicity -- on success- -> MemoryOrdering -- on failure (see docs for restrictions)- -> Instruction (a, Bool)+ -> Operand a -- expected value+ -> Operand a -- replacement value+ -> Atomicity -- on success+ -> MemoryOrdering -- on failure (see docs for restrictions)+ -> Instruction (a, PrimBool) -- should be (a, Bool) -- <http://llvm.org/docs/LangRef.html#atomicrmw-instruction> --- AtomicRMW :: IntegralType a+ AtomicRMW :: NumType a -> Volatility -> RMWOperation -> Operand (Ptr a)@@ -243,6 +270,10 @@ -> Operand a -> Instruction b + IntToBool :: IntegralType a+ -> Operand a+ -> Instruction Bool+ -- <http://llvm.org/docs/LangRef.html#fptrunc-to-instruction> -- FTrunc :: FloatingType a -- precondition: BitSize a > BitSize b@@ -258,6 +289,10 @@ -> Operand a -> Instruction b + BoolToInt :: IntegralType a+ -> Operand Bool+ -> Instruction a+ -- <http://llvm.org/docs/LangRef.html#fpext-to-instruction> -- FExt :: FloatingType a -- precondition: BitSize a < BitSize b@@ -265,6 +300,10 @@ -> Operand a -> Instruction b + BoolToFP :: FloatingType a+ -> Operand Bool+ -> Instruction a+ -- <http://llvm.org/docs/LangRef.html#fptoui-to-instruction> -- <http://llvm.org/docs/LangRef.html#fptosi-to-instruction> --@@ -276,7 +315,7 @@ -- <http://llvm.org/docs/LangRef.html#uitofp-to-instruction> -- <http://llvm.org/docs/LangRef.html#sitofp-to-instruction> --- IntToFP :: Either (IntegralType a) (NonNumType a)+ IntToFP :: IntegralType a -> FloatingType b -> Operand a -> Instruction b@@ -303,15 +342,13 @@ -- -- We treat non-scalar types as signed/unsigned integer values. --- FCmp :: FloatingType a- -> FOrdering+ Cmp :: SingleType a+ -> Ordering -> Operand a -> Operand a -> Instruction Bool - Cmp :: SingleType a- -> Ordering- -> Operand a+ IsNaN :: FloatingType a -> Operand a -> Instruction Bool @@ -323,7 +360,7 @@ -- <http://llvm.org/docs/LangRef.html#call-instruction> --- Call :: GlobalFunction args t+ Call :: Function (Either InlineAssembly Label) args t -> [Either GroupID FunctionAttribute] -> Instruction t @@ -346,4 +383,272 @@ data Named ins a where (:=) :: Name a -> ins a -> Named ins a Do :: ins () -> Named ins ()+++-- | Convert to llvm-hs+--+instance Downcast (Instruction a) LLVM.Instruction where+ downcast = \case+ Add t x y -> add t (downcast x) (downcast y)+ Sub t x y -> sub t (downcast x) (downcast y)+ Mul t x y -> mul t (downcast x) (downcast y)+ Quot t x y -> quot t (downcast x) (downcast y)+ Rem t x y -> rem t (downcast x) (downcast y)+ Div _ x y -> LLVM.FDiv fmf (downcast x) (downcast y) md+ ShiftL _ x i -> LLVM.Shl nsw nuw (downcast x) (downcast i) md+ ShiftRL _ x i -> LLVM.LShr exact (downcast x) (downcast i) md+ ShiftRA _ x i -> LLVM.AShr exact (downcast x) (downcast i) md+ BAnd _ x y -> LLVM.And (downcast x) (downcast y) md+ LAnd x y -> LLVM.And (downcast x) (downcast y) md+ BOr _ x y -> LLVM.Or (downcast x) (downcast y) md+ LOr x y -> LLVM.Or (downcast x) (downcast y) md+ BXor _ x y -> LLVM.Xor (downcast x) (downcast y) md+ LNot x -> LLVM.Xor (downcast x) (LLVM.ConstantOperand (LLVM.Int 1 1)) md+ InsertElement i v x -> LLVM.InsertElement (downcast v) (downcast x) (constant i) md+ ExtractElement i v -> LLVM.ExtractElement (downcast v) (constant i) md+ ExtractValue _ i s -> extractStruct i (downcast s)+ Load _ v p -> LLVM.Load (downcast v) (downcast p) atomicity alignment md+ Store v p x -> LLVM.Store (downcast v) (downcast p) (downcast x) atomicity alignment md+ GetElementPtr n i -> LLVM.GetElementPtr inbounds (downcast n) (downcast i) md+ Fence a -> LLVM.Fence (downcast a) md+ CmpXchg _ v p x y a m -> LLVM.CmpXchg (downcast v) (downcast p) (downcast x) (downcast y) (downcast a) (downcast m) md+ AtomicRMW t v f p x a -> LLVM.AtomicRMW (downcast v) (downcast (t,f)) (downcast p) (downcast x) (downcast a) md+ Trunc _ t x -> LLVM.Trunc (downcast x) (downcast t) md+ IntToBool _ x -> LLVM.Trunc (downcast x) (LLVM.IntegerType 1) md+ FTrunc _ t x -> LLVM.FPTrunc (downcast x) (downcast t) md+ Ext a b x -> ext a b (downcast x)+ BoolToInt a x -> LLVM.ZExt (downcast x) (downcast a) md+ BoolToFP x a -> LLVM.UIToFP (downcast a) (downcast x) md+ FExt _ t x -> LLVM.FPExt (downcast x) (downcast t) md+ FPToInt _ b x -> float2int b (downcast x)+ IntToFP a b x -> int2float a b (downcast x)+ BitCast t x -> LLVM.BitCast (downcast x) (downcast t) md+ PtrCast t x -> LLVM.BitCast (downcast x) (downcast t) md+ Phi t e -> LLVM.Phi (downcast t) (downcast e) md+ Select _ p x y -> LLVM.Select (downcast p) (downcast x) (downcast y) md+ IsNaN _ x -> isNaN (downcast x)+ Cmp t p x y -> cmp t p (downcast x) (downcast y)+ Call f a -> call f a++ where+ nsw :: Bool -- no signed wrap+ nsw = False++ nuw :: Bool -- no unsigned wrap+ nuw = False++ exact :: Bool -- does not lose any information+ exact = False++ inbounds :: Bool+ inbounds = True++ atomicity :: Maybe LLVM.Atomicity+ atomicity = Nothing++ alignment :: Word32+ alignment = 0++ fmf :: LLVM.FastMathFlags+#if MIN_VERSION_llvm_hs_pure(6,0,0)+ fmf = LLVM.FastMathFlags+ { LLVM.allowReassoc = True+ , LLVM.noNaNs = True+ , LLVM.noInfs = True+ , LLVM.noSignedZeros = True+ , LLVM.allowReciprocal = True+ , LLVM.allowContract = True+ , LLVM.approxFunc = True+ }+#else+ fmf = LLVM.UnsafeAlgebra -- allow everything+#endif++ md :: LLVM.InstructionMetadata+ md = []++ constant :: IsScalar a => a -> LLVM.Operand+ constant x = downcast (ConstantOperand (ScalarConstant scalarType x))++ add :: NumType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction+ add IntegralNumType{} x y = LLVM.Add nsw nuw x y md+ add FloatingNumType{} x y = LLVM.FAdd fmf x y md++ sub :: NumType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction+ sub IntegralNumType{} x y = LLVM.Sub nsw nuw x y md+ sub FloatingNumType{} x y = LLVM.FSub fmf x y md++ mul :: NumType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction+ mul IntegralNumType{} x y = LLVM.Mul nsw nuw x y md+ mul FloatingNumType{} x y = LLVM.FMul fmf x y md++ quot :: IntegralType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction+ quot t x y+ | signed t = LLVM.SDiv exact x y md+ | otherwise = LLVM.UDiv exact x y md++ rem :: IntegralType a -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction+ rem t x y+ | signed t = LLVM.SRem x y md+ | otherwise = LLVM.URem x y md++ extractStruct :: PairIdx s t -> LLVM.Operand -> LLVM.Instruction+ extractStruct i s = LLVM.ExtractValue s ix md+ where+ ix = case i of+ PairIdxLeft -> [0]+ PairIdxRight -> [1]++ ext :: BoundedType a -> BoundedType b -> LLVM.Operand -> LLVM.Instruction+ ext a (downcast -> b) x+ | signed a = LLVM.SExt x b md+ | otherwise = LLVM.ZExt x b md++ float2int :: IntegralType b -> LLVM.Operand -> LLVM.Instruction+ float2int t@(downcast -> t') x+ | signed t = LLVM.FPToSI x t' md+ | otherwise = LLVM.FPToUI x t' md++ int2float :: IntegralType a -> FloatingType b -> LLVM.Operand -> LLVM.Instruction+ int2float a (downcast -> b) x+ | signed a = LLVM.SIToFP x b md+ | otherwise = LLVM.UIToFP x b md++ isNaN :: LLVM.Operand -> LLVM.Instruction+ isNaN x = LLVM.FCmp FP.UNO x x md++ cmp :: SingleType a -> Ordering -> LLVM.Operand -> LLVM.Operand -> LLVM.Instruction+ cmp t p x y =+ case t of+ NumSingleType FloatingNumType{} -> LLVM.FCmp (fp p) x y md+ _ | signed t -> LLVM.ICmp (si p) x y md+ | otherwise -> LLVM.ICmp (ui p) x y md+ where+ fp :: Ordering -> FP.FloatingPointPredicate+ fp EQ = FP.OEQ+ fp NE = FP.ONE+ fp LT = FP.OLT+ fp LE = FP.OLE+ fp GT = FP.OGT+ fp GE = FP.OGE++ si :: Ordering -> IP.IntegerPredicate+ si EQ = IP.EQ+ si NE = IP.NE+ si LT = IP.SLT+ si LE = IP.SLE+ si GT = IP.SGT+ si GE = IP.SGE++ ui :: Ordering -> IP.IntegerPredicate+ ui EQ = IP.EQ+ ui NE = IP.NE+ ui LT = IP.ULT+ ui LE = IP.ULE+ ui GT = IP.UGT+ ui GE = IP.UGE++ call :: Function (Either InlineAssembly Label) args t -> [Either GroupID FunctionAttribute] -> LLVM.Instruction+ call f as = LLVM.Call tail LLVM.C [] target argv (downcast as) md+ where+ trav :: Function (Either InlineAssembly Label) args t+ -> ( [LLVM.Type] -- argument types+ , [(LLVM.Operand, [LLVM.ParameterAttribute])] -- argument operands+ , Maybe LLVM.TailCallKind -- calling kind+ , LLVM.Type -- return type+ , LLVM.CallableOperand -- function name or inline assembly+ )+ trav (Body u k o) =+ case o of+ Left asm -> ([], [], downcast k, downcast u, Left (downcast (LLVM.FunctionType ret argt False, asm)))+ Right n -> ([], [], downcast k, downcast u, Right (LLVM.ConstantOperand (LLVM.GlobalReference ptr_fun_ty (downcast n))))+ trav (Lam t x l) =+ let (ts, xs, k, r, n) = trav l+ in (downcast t : ts, (downcast x, []) : xs, k, r, n)++ (argt, argv, tail, ret, target) = trav f+ fun_ty = LLVM.FunctionType ret argt False+ ptr_fun_ty = LLVM.PointerType fun_ty (LLVM.AddrSpace 0)+++instance Downcast (i a) i' => Downcast (Named i a) (LLVM.Named i') where+ downcast (x := op) = downcast x LLVM.:= downcast op+ downcast (Do op) = LLVM.Do (downcast op)+++instance TypeOf Instruction where+ typeOf = \case+ Add _ x _ -> typeOf x+ Sub _ x _ -> typeOf x+ Mul _ x _ -> typeOf x+ Quot _ x _ -> typeOf x+ Rem _ x _ -> typeOf x+ Div _ x _ -> typeOf x+ ShiftL _ x _ -> typeOf x+ ShiftRL _ x _ -> typeOf x+ ShiftRA _ x _ -> typeOf x+ BAnd _ x _ -> typeOf x+ BOr _ x _ -> typeOf x+ BXor _ x _ -> typeOf x+ LAnd x _ -> typeOf x+ LOr x _ -> typeOf x+ LNot x -> typeOf x+ ExtractElement _ x -> typeOfVec x+ InsertElement _ x _ -> typeOf x+ ExtractValue t _ _ -> scalar t+ Load t _ _ -> scalar t+ Store{} -> VoidType+ GetElementPtr x _ -> typeOf x+ Fence{} -> VoidType+ CmpXchg t _ _ _ _ _ _ -> PrimType . StructPrimType $ SingleScalarType (NumSingleType (IntegralNumType t)) `pair` scalarType+ AtomicRMW _ _ _ _ x _ -> typeOf x+ FTrunc _ t _ -> floating t+ FExt _ t _ -> floating t+ Trunc _ t _ -> bounded t+ Ext _ t _ -> bounded t+ FPToInt _ t _ -> integral t+ IntToFP _ t _ -> floating t+ IntToBool _ _ -> type'+ BoolToInt t _ -> integral t+ BoolToFP t _ -> floating t+ BitCast t _ -> scalar t+ PtrCast t _ -> PrimType t+ Cmp{} -> type'+ IsNaN{} -> type'+ Phi t _ -> PrimType t+ Select _ _ x _ -> typeOf x+ Call f _ -> fun f+ where+ typeOfVec :: HasCallStack => Operand (Vec n a) -> Type a+ typeOfVec x+ | PrimType p <- typeOf x+ , ScalarPrimType s <- p+ , VectorScalarType v <- s+ , VectorType _ t <- v+ = PrimType (ScalarPrimType (SingleScalarType t))+ --+ | otherwise+ = internalError "unexpected evaluation"++ scalar :: ScalarType a -> Type a+ scalar = PrimType . ScalarPrimType++ single :: SingleType a -> Type a+ single = scalar . SingleScalarType++ floating :: FloatingType a -> Type a+ floating = single . NumSingleType . FloatingNumType++ integral :: IntegralType a -> Type a+ integral = single . NumSingleType . IntegralNumType++ pair :: ScalarType a -> ScalarType b -> TypeR (a, b)+ pair a b = TupRsingle a `TupRpair` TupRsingle b++ bounded :: BoundedType a -> Type a+ bounded (IntegralBoundedType t) = integral t++ fun :: Function kind args a -> Type a+ fun (Lam _ _ l) = fun l+ fun (Body t _ _) = t
src/LLVM/AST/Type/Instruction/Atomic.hs view
@@ -1,10 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Instruction.Atomic--- 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) --@@ -12,6 +14,10 @@ module LLVM.AST.Type.Instruction.Atomic where +import LLVM.AST.Type.Downcast+import qualified LLVM.AST.Instruction as LLVM++ -- | Atomic instructions take ordering parameters that determine which other -- atomic instructions on the same address they synchronise with. --@@ -41,4 +47,23 @@ -- visibility of the effects of that instruction. -- type Atomicity = (Synchronisation, MemoryOrdering)+++-- | Convert to llvm-hs+--+instance Downcast MemoryOrdering LLVM.MemoryOrdering where+ downcast Unordered = LLVM.Unordered+ downcast Monotonic = LLVM.Monotonic+ downcast Acquire = LLVM.Acquire+ downcast Release = LLVM.Release+ downcast AcquireRelease = LLVM.AcquireRelease+ downcast SequentiallyConsistent = LLVM.SequentiallyConsistent++instance Downcast Synchronisation LLVM.SynchronizationScope where+ downcast SingleThread = LLVM.SingleThread+#if MIN_VERSION_llvm_hs_pure(5,0,0)+ downcast CrossThread = LLVM.System+#else+ downcast CrossThread = LLVM.CrossThread+#endif
src/LLVM/AST/Type/Instruction/Compare.hs view
@@ -1,10 +1,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Instruction.Compare--- 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) --@@ -15,8 +15,4 @@ -- | Ordering predicate for comparison instructions -- data Ordering = EQ | NE | LT | LE | GT | GE---- | Ordering predicate only for floating-point comparison instructions----data FOrdering = OEQ | UNO
src/LLVM/AST/Type/Instruction/RMW.hs view
@@ -1,10 +1,13 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Instruction.RMW--- 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) --@@ -12,6 +15,14 @@ module LLVM.AST.Type.Instruction.RMW where +import Data.Array.Accelerate.Error++import LLVM.AST.Type.Downcast+import LLVM.AST.Type.Representation++import qualified LLVM.AST.RMWOperation as LLVM++ -- | Operations for the 'AtomicRMW' instruction. -- -- <http://llvm.org/docs/LangRef.html#atomicrmw-instruction>@@ -26,4 +37,36 @@ | Xor | Min | Max+++-- | Convert to llvm-hs+--+instance Downcast (NumType a, RMWOperation) LLVM.RMWOperation where+ downcast (IntegralNumType t, rmw) = downcast (t,rmw)+ downcast (FloatingNumType t, rmw) = downcast (t,rmw)++instance Downcast (IntegralType a, RMWOperation) LLVM.RMWOperation where+ downcast (t, rmw) =+ case rmw of+ Exchange -> LLVM.Xchg+ Add -> LLVM.Add+ Sub -> LLVM.Sub+ And -> LLVM.And+ Or -> LLVM.Or+ Xor -> LLVM.Xor+ Nand -> LLVM.Nand+ Min | signed t -> LLVM.Min+ | otherwise -> LLVM.UMin+ Max | signed t -> LLVM.Max+ | otherwise -> LLVM.UMax++instance Downcast (FloatingType a, RMWOperation) LLVM.RMWOperation where+ downcast (_, rmw) =+ case rmw of+ Exchange -> LLVM.Xchg+#if MIN_VERSION_llvm_hs_pure(10,0,0)+ Add -> LLVM.FAdd+ Sub -> LLVM.FSub+#endif+ _ -> internalError "unsupported operand type to RMWOperation"
src/LLVM/AST/Type/Instruction/Volatile.hs view
@@ -1,10 +1,11 @@+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Instruction.Volatile--- 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) --@@ -12,6 +13,9 @@ module LLVM.AST.Type.Instruction.Volatile where +import LLVM.AST.Type.Downcast++ -- | Loads and stores may be marked as 'volatile'. The LLVM optimiser will not -- change the number of volatile operations or their order with respect to other -- volatile operations, but may change the order of volatile operations relative@@ -23,4 +27,8 @@ -- <http://llvm.org/docs/LangRef.html#volatile-memory-accesses> -- data Volatility = Volatile | NonVolatile++instance Downcast Volatility Bool where+ downcast Volatile = True+ downcast NonVolatile = False
src/LLVM/AST/Type/Metadata.hs view
@@ -1,11 +1,14 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Metadata--- 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) --@@ -13,6 +16,8 @@ module LLVM.AST.Type.Metadata where +import LLVM.AST.Type.Downcast+ import qualified LLVM.AST.Constant as LLVM import qualified LLVM.AST.Operand as LLVM @@ -31,3 +36,25 @@ = MetadataStringOperand {-# UNPACK #-} !ShortByteString | MetadataConstantOperand !LLVM.Constant | MetadataNodeOperand !MetadataNode+++-- | Convert to llvm-hs+--+instance Downcast Metadata LLVM.Metadata where+ downcast (MetadataStringOperand s) = LLVM.MDString s+ downcast (MetadataConstantOperand o) = LLVM.MDValue (LLVM.ConstantOperand o)+ downcast (MetadataNodeOperand n) = LLVM.MDNode (downcast n)++#if MIN_VERSION_llvm_hs_pure(6,1,0)+instance Downcast MetadataNode (LLVM.MDRef LLVM.MDNode) where+ downcast (MetadataNode n) = LLVM.MDInline (downcast n)+ downcast (MetadataNodeReference r) = LLVM.MDRef r++instance Downcast [Maybe Metadata] LLVM.MDNode where+ downcast = LLVM.MDTuple . map downcast+#else+instance Downcast MetadataNode LLVM.MetadataNode where+ downcast (MetadataNode n) = LLVM.MetadataNode (downcast n)+ downcast (MetadataNodeReference r) = LLVM.MetadataNodeReference r+#endif+
src/LLVM/AST/Type/Name.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RoleAnnotations #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Name--- 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) --@@ -17,14 +17,16 @@ import Data.ByteString.Short ( ShortByteString ) import Data.Data-#if __GLASGOW_HASKELL__ >= 800 import Data.Semigroup-#endif import Data.String import Data.Word import Prelude +import LLVM.AST.Type.Downcast +import qualified LLVM.AST.Name as LLVM++ -- | Objects of various sorts in LLVM IR are identified by address in the LLVM -- C++ API, and may be given a string name. When printed to (resp. read from) -- human-readable LLVM assembly, objects without string names are numbered@@ -75,12 +77,19 @@ instance IsString Label where fromString = Label . fromString -#if __GLASGOW_HASKELL__ >= 800 instance Semigroup Label where Label x <> Label y = Label (x <> y)-#endif instance Monoid Label where- mempty = Label mempty- mappend (Label x) (Label y) = Label (mappend x y)+ mempty = Label mempty+++-- | Convert to llvm-hs+--+instance Downcast (Name a) LLVM.Name where+ downcast (Name s) = LLVM.Name s+ downcast (UnName n) = LLVM.UnName n++instance Downcast Label LLVM.Name where+ downcast (Label l) = LLVM.Name l
src/LLVM/AST/Type/Operand.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Operand--- 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) --@@ -17,13 +19,27 @@ ) where import LLVM.AST.Type.Constant+import LLVM.AST.Type.Downcast import LLVM.AST.Type.Name import LLVM.AST.Type.Representation +import qualified LLVM.AST.Operand as LLVM + -- | An 'Operand' is roughly anything that is an argument to an 'Instruction' -- data Operand a where LocalReference :: Type a -> Name a -> Operand a ConstantOperand :: Constant a -> Operand a+++-- | Convert to llvm-hs+--+instance Downcast (Operand a) LLVM.Operand where+ downcast (LocalReference t n) = LLVM.LocalReference (downcast t) (downcast n)+ downcast (ConstantOperand c) = LLVM.ConstantOperand (downcast c)++instance TypeOf Operand where+ typeOf (LocalReference t _) = t+ typeOf (ConstantOperand c) = typeOf c
src/LLVM/AST/Type/Representation.hs view
@@ -1,12 +1,14 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Representation--- 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) --@@ -21,10 +23,13 @@ ) where import Data.Array.Accelerate.Type-import Data.Array.Accelerate.Product+import Data.Array.Accelerate.Representation.Type import LLVM.AST.Type.AddrSpace+import LLVM.AST.Type.Downcast +import qualified LLVM.AST.Type as LLVM+ import Foreign.Ptr import Text.Printf @@ -64,9 +69,10 @@ PrimType :: PrimType a -> Type a data PrimType a where+ BoolPrimType :: PrimType Bool ScalarPrimType :: ScalarType a -> PrimType a -- scalar value types (things in registers) PtrPrimType :: PrimType a -> AddrSpace -> PrimType (Ptr a) -- pointers (XXX: volatility?)- StructPrimType :: TupleType (ProdRepr a) -> PrimType a -- opaque structures (required for CmpXchg)+ StructPrimType :: TypeR a -> PrimType a -- opaque structures (required for CmpXchg) ArrayPrimType :: Word64 -> ScalarType a -> PrimType a -- static arrays -- | All types@@ -108,28 +114,7 @@ instance IsType Word64 where type' = PrimType primType -instance IsType CShort where- type' = PrimType primType--instance IsType CUShort where- type' = PrimType primType--instance IsType CInt where- type' = PrimType primType--instance IsType CUInt where- type' = PrimType primType--instance IsType CLong where- type' = PrimType primType--instance IsType CULong where- type' = PrimType primType--instance IsType CLLong where- type' = PrimType primType--instance IsType CULLong where+instance IsType Half where type' = PrimType primType instance IsType Float where@@ -138,27 +123,6 @@ instance IsType Double where type' = PrimType primType -instance IsType CFloat where- type' = PrimType primType--instance IsType CDouble where- type' = PrimType primType--instance IsType Bool where- type' = PrimType primType--instance IsType Char where- type' = PrimType primType--instance IsType CChar where- type' = PrimType primType--instance IsType CSChar where- type' = PrimType primType--instance IsType CUChar where- type' = PrimType primType- instance IsType (Ptr Int) where type' = PrimType primType @@ -189,56 +153,14 @@ instance IsType (Ptr Word64) where type' = PrimType primType -instance IsType (Ptr CShort) where- type' = PrimType primType--instance IsType (Ptr CUShort) where- type' = PrimType primType--instance IsType (Ptr CInt) where- type' = PrimType primType--instance IsType (Ptr CUInt) where- type' = PrimType primType--instance IsType (Ptr CLong) where- type' = PrimType primType--instance IsType (Ptr CULong) where- type' = PrimType primType--instance IsType (Ptr CLLong) where- type' = PrimType primType--instance IsType (Ptr CULLong) where- type' = PrimType primType- instance IsType (Ptr Float) where type' = PrimType primType instance IsType (Ptr Double) where type' = PrimType primType -instance IsType (Ptr CFloat) where- type' = PrimType primType--instance IsType (Ptr CDouble) where- type' = PrimType primType--instance IsType (Ptr Bool) where- type' = PrimType primType--instance IsType (Ptr Char) where- type' = PrimType primType--instance IsType (Ptr CChar) where- type' = PrimType primType--instance IsType (Ptr CSChar) where- type' = PrimType primType--instance IsType (Ptr CUChar) where- type' = PrimType primType+instance IsType Bool where+ type' = PrimType BoolPrimType -- | All primitive types@@ -277,28 +199,7 @@ instance IsPrim Word64 where primType = ScalarPrimType scalarType -instance IsPrim CShort where- primType = ScalarPrimType scalarType--instance IsPrim CUShort where- primType = ScalarPrimType scalarType--instance IsPrim CInt where- primType = ScalarPrimType scalarType--instance IsPrim CUInt where- primType = ScalarPrimType scalarType--instance IsPrim CLong where- primType = ScalarPrimType scalarType--instance IsPrim CULong where- primType = ScalarPrimType scalarType--instance IsPrim CLLong where- primType = ScalarPrimType scalarType--instance IsPrim CULLong where+instance IsPrim Half where primType = ScalarPrimType scalarType instance IsPrim Float where@@ -307,27 +208,6 @@ instance IsPrim Double where primType = ScalarPrimType scalarType -instance IsPrim CFloat where- primType = ScalarPrimType scalarType--instance IsPrim CDouble where- primType = ScalarPrimType scalarType--instance IsPrim Bool where- primType = ScalarPrimType scalarType--instance IsPrim Char where- primType = ScalarPrimType scalarType--instance IsPrim CChar where- primType = ScalarPrimType scalarType--instance IsPrim CSChar where- primType = ScalarPrimType scalarType--instance IsPrim CUChar where- primType = ScalarPrimType scalarType- instance IsPrim (Ptr Int) where primType = PtrPrimType primType defaultAddrSpace @@ -358,28 +238,7 @@ instance IsPrim (Ptr Word64) where primType = PtrPrimType primType defaultAddrSpace -instance IsPrim (Ptr CShort) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CUShort) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CInt) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CUInt) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CLong) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CULong) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CLLong) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CULLong) where+instance IsPrim (Ptr Half) where primType = PtrPrimType primType defaultAddrSpace instance IsPrim (Ptr Float) where@@ -388,33 +247,15 @@ instance IsPrim (Ptr Double) where primType = PtrPrimType primType defaultAddrSpace -instance IsPrim (Ptr CFloat) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CDouble) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr Bool) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr Char) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CChar) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CSChar) where- primType = PtrPrimType primType defaultAddrSpace--instance IsPrim (Ptr CUChar) where- primType = PtrPrimType primType defaultAddrSpace-+instance IsPrim Bool where+ primType = BoolPrimType instance Show (Type a) where show VoidType = "()" show (PrimType t) = show t instance Show (PrimType a) where+ show BoolPrimType = "Bool" show (ScalarPrimType t) = show t show (StructPrimType t) = show t show (ArrayPrimType n t) = printf "[%d x %s]" n (show t)@@ -425,4 +266,68 @@ | otherwise = printf "[addrspace %d]" n -- p | PtrPrimType{} <- t = printf "(%s)" (show t) -- | otherwise = show t+++-- | Does the concrete type represent signed or unsigned values?+--+class IsSigned dict where+ signed :: dict a -> Bool+ signed = not . unsigned+ --+ unsigned :: dict a -> Bool+ unsigned = not . signed++instance IsSigned ScalarType where+ signed (SingleScalarType t) = signed t+ signed (VectorScalarType t) = signed t++instance IsSigned SingleType where+ signed (NumSingleType t) = signed t++instance IsSigned VectorType where+ signed (VectorType _ t) = signed t++instance IsSigned BoundedType where+ signed (IntegralBoundedType t) = signed t++instance IsSigned NumType where+ signed (IntegralNumType t) = signed t+ signed (FloatingNumType t) = signed t++instance IsSigned IntegralType where+ signed = \case+ TypeInt{} -> True+ TypeInt8{} -> True+ TypeInt16{} -> True+ TypeInt32{} -> True+ TypeInt64{} -> True+ _ -> False++instance IsSigned FloatingType where+ signed _ = True+++-- | Recover the type of a container+--+class TypeOf f where+ typeOf :: f a -> Type a+++-- | Convert to llvm-hs+--+instance Downcast (Type a) LLVM.Type where+ downcast VoidType = LLVM.VoidType+ downcast (PrimType t) = downcast t++instance Downcast (PrimType a) LLVM.Type where+ downcast BoolPrimType = LLVM.IntegerType 1+ downcast (ScalarPrimType t) = downcast t+ downcast (PtrPrimType t a) = LLVM.PointerType (downcast t) a+ downcast (ArrayPrimType n t) = LLVM.ArrayType n (downcast t)+ downcast (StructPrimType t) = LLVM.StructureType False (go t)+ where+ go :: TypeR t -> [LLVM.Type]+ go TupRunit = []+ go (TupRsingle s) = [downcast s]+ go (TupRpair ta tb) = go ta ++ go tb
src/LLVM/AST/Type/Terminator.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module : LLVM.AST.Type.Terminator--- 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) --@@ -16,8 +18,11 @@ import LLVM.AST.Type.Constant import LLVM.AST.Type.Name import LLVM.AST.Type.Operand+import LLVM.AST.Type.Downcast +import qualified LLVM.AST.Instruction as LLVM + -- | <http://llvm.org/docs/LangRef.html#terminators> -- -- TLM: well, I don't think the types of these terminators make any sense. When@@ -35,6 +40,7 @@ -- RetVal :: Operand a -> Terminator a+ -- <http://llvm.org/docs/LangRef.html#br-instruction> -- Br :: Label@@ -53,4 +59,18 @@ -> Label -> [(Constant a, Label)] -> Terminator ()+++-- | Convert to llvm-hs+--+instance Downcast (Terminator a) LLVM.Terminator where+ downcast = \case+ Ret -> LLVM.Ret Nothing md+ RetVal x -> LLVM.Ret (Just (downcast x)) md+ Br l -> LLVM.Br (downcast l) md+ CondBr p t f -> LLVM.CondBr (downcast p) (downcast t) (downcast f) md+ Switch p d a -> LLVM.Switch (downcast p) (downcast d) (downcast a) md+ where+ md :: LLVM.InstructionMetadata+ md = []