diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,20 @@ -An LLVM backend for the Accelerate Array Language -================================================= +
+henlo, my name is Theia -[![Travis](https://img.shields.io/travis/AccelerateHS/accelerate-llvm/master.svg?label=linux)](https://travis-ci.org/AccelerateHS/accelerate-llvm) -[![AppVeyor](https://img.shields.io/appveyor/ci/tmcdonell/accelerate-llvm/master.svg?label=windows)](https://ci.appveyor.com/project/tmcdonell/accelerate-llvm) +# LLVM backends for the Accelerate array language + +[![GitHub CI](https://github.com/tmcdonell/accelerate-llvm/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate-llvm/actions) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +
[![Stackage LTS](https://stackage.org/package/accelerate-llvm/badge/lts)](https://stackage.org/lts/package/accelerate-llvm) [![Stackage Nightly](https://stackage.org/package/accelerate-llvm/badge/nightly)](https://stackage.org/nightly/package/accelerate-llvm) [![Hackage](https://img.shields.io/hackage/v/accelerate-llvm.svg)](https://hackage.haskell.org/package/accelerate-llvm) +
[![Docker Automated build](https://img.shields.io/docker/automated/tmcdonell/accelerate-llvm.svg)](https://hub.docker.com/r/tmcdonell/accelerate-llvm/) [![Docker status](https://images.microbadger.com/badges/image/tmcdonell/accelerate-llvm.svg)](https://microbadger.com/images/tmcdonell/accelerate-llvm) +
+ 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 diff --git a/accelerate-llvm.cabal b/accelerate-llvm.cabal --- a/accelerate-llvm.cabal +++ b/accelerate-llvm.cabal @@ -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 +maintainer: Trevor L. McDonell 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 diff --git a/src/Control/Parallel/Meta.hs b/src/Control/Parallel/Meta.hs deleted file mode 100644 --- a/src/Control/Parallel/Meta.hs +++ /dev/null @@ -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 --- 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 ---} - diff --git a/src/Control/Parallel/Meta/Resource/Backoff.hs b/src/Control/Parallel/Meta/Resource/Backoff.hs deleted file mode 100644 --- a/src/Control/Parallel/Meta/Resource/Backoff.hs +++ /dev/null @@ -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 --- 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. --- --- - -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) - diff --git a/src/Control/Parallel/Meta/Resource/SMP.hs b/src/Control/Parallel/Meta/Resource/SMP.hs deleted file mode 100644 --- a/src/Control/Parallel/Meta/Resource/SMP.hs +++ /dev/null @@ -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 --- 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. --- --- - -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' - diff --git a/src/Control/Parallel/Meta/Resource/Single.hs b/src/Control/Parallel/Meta/Resource/Single.hs deleted file mode 100644 --- a/src/Control/Parallel/Meta/Resource/Single.hs +++ /dev/null @@ -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 --- 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)) - diff --git a/src/Control/Parallel/Meta/Trans/LBS.hs b/src/Control/Parallel/Meta/Trans/LBS.hs deleted file mode 100644 --- a/src/Control/Parallel/Meta/Trans/LBS.hs +++ /dev/null @@ -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 --- 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) - diff --git a/src/Control/Parallel/Meta/Worker.hs b/src/Control/Parallel/Meta/Worker.hs deleted file mode 100644 --- a/src/Control/Parallel/Meta/Worker.hs +++ /dev/null @@ -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 --- 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) - diff --git a/src/Data/Array/Accelerate/LLVM/AST.hs b/src/Data/Array/Accelerate/LLVM/AST.hs --- a/src/Data/Array/Accelerate/LLVM/AST.hs +++ b/src/Data/Array/Accelerate/LLVM/AST.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Analysis/Match.hs b/src/Data/Array/Accelerate/LLVM/Analysis/Match.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Analysis/Match.hs +++ /dev/null @@ -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 --- 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 - diff --git a/src/Data/Array/Accelerate/LLVM/Array/Data.hs b/src/Data/Array/Accelerate/LLVM/Array/Data.hs --- a/src/Data/Array/Accelerate/LLVM/Array/Data.hs +++ b/src/Data/Array/Accelerate/LLVM/Array/Data.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen.hs b/src/Data/Array/Accelerate/LLVM/CodeGen.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Array.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Array.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Array.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Array.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 +--} diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Base.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Base.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Base.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Base.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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)) diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Constant.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Constant.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Constant.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Constant.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Downcast.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Downcast.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Downcast.hs +++ /dev/null @@ -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 --- 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 - diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Environment.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Environment.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Environment.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Environment.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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) diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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) diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs-boot b/src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs-boot new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Exp.hs-boot @@ -0,0 +1,20 @@ +-- | +-- Module : Data.Array.Accelerate.LLVM.CodeGen.Exp-boot +-- Copyright : [2015..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- 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 + diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/IR.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/IR.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/IR.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/IR.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Intrinsic.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Loop.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Loop.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Loop.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Loop.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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)] diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Module.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Module.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Module.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Module.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 = "" - 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) } diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot b/src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Monad.hs-boot @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 } diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Permute.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Permute.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Permute.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Permute.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Ptr.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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" diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Skeleton.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Stencil.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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) diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Sugar.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 } diff --git a/src/Data/Array/Accelerate/LLVM/CodeGen/Type.hs b/src/Data/Array/Accelerate/LLVM/CodeGen/Type.hs --- a/src/Data/Array/Accelerate/LLVM/CodeGen/Type.hs +++ b/src/Data/Array/Accelerate/LLVM/CodeGen/Type.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Compile.hs b/src/Data/Array/Accelerate/LLVM/Compile.hs --- a/src/Data/Array/Accelerate/LLVM/Compile.hs +++ b/src/Data/Array/Accelerate/LLVM/Compile.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Compile/Cache.hs b/src/Data/Array/Accelerate/LLVM/Compile/Cache.hs --- a/src/Data/Array/Accelerate/LLVM/Compile/Cache.hs +++ b/src/Data/Array/Accelerate/LLVM/Compile/Cache.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Embed.hs b/src/Data/Array/Accelerate/LLVM/Embed.hs --- a/src/Data/Array/Accelerate/LLVM/Embed.hs +++ b/src/Data/Array/Accelerate/LLVM/Embed.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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) ||] diff --git a/src/Data/Array/Accelerate/LLVM/Execute.hs b/src/Data/Array/Accelerate/LLVM/Execute.hs --- a/src/Data/Array/Accelerate/LLVM/Execute.hs +++ b/src/Data/Array/Accelerate/LLVM/Execute.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Execute/Async.hs b/src/Data/Array/Accelerate/LLVM/Execute/Async.hs --- a/src/Data/Array/Accelerate/LLVM/Execute/Async.hs +++ b/src/Data/Array/Accelerate/LLVM/Execute/Async.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Execute/Environment.hs b/src/Data/Array/Accelerate/LLVM/Execute/Environment.hs --- a/src/Data/Array/Accelerate/LLVM/Execute/Environment.hs +++ b/src/Data/Array/Accelerate/LLVM/Execute/Environment.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Execute/Marshal.hs b/src/Data/Array/Accelerate/LLVM/Execute/Marshal.hs --- a/src/Data/Array/Accelerate/LLVM/Execute/Marshal.hs +++ b/src/Data/Array/Accelerate/LLVM/Execute/Marshal.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Extra.hs b/src/Data/Array/Accelerate/LLVM/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/LLVM/Extra.hs @@ -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 +-- 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 + diff --git a/src/Data/Array/Accelerate/LLVM/Foreign.hs b/src/Data/Array/Accelerate/LLVM/Foreign.hs --- a/src/Data/Array/Accelerate/LLVM/Foreign.hs +++ b/src/Data/Array/Accelerate/LLVM/Foreign.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Link.hs b/src/Data/Array/Accelerate/LLVM/Link.hs --- a/src/Data/Array/Accelerate/LLVM/Link.hs +++ b/src/Data/Array/Accelerate/LLVM/Link.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Link/Cache.hs b/src/Data/Array/Accelerate/LLVM/Link/Cache.hs --- a/src/Data/Array/Accelerate/LLVM/Link/Cache.hs +++ b/src/Data/Array/Accelerate/LLVM/Link/Cache.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/LLVM/State.hs b/src/Data/Array/Accelerate/LLVM/State.hs --- a/src/Data/Array/Accelerate/LLVM/State.hs +++ b/src/Data/Array/Accelerate/LLVM/State.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 ) diff --git a/src/Data/Array/Accelerate/LLVM/Target.hs b/src/Data/Array/Accelerate/LLVM/Target.hs --- a/src/Data/Array/Accelerate/LLVM/Target.hs +++ b/src/Data/Array/Accelerate/LLVM/Target.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Array/Accelerate/LLVM/Util.hs b/src/Data/Array/Accelerate/LLVM/Util.hs deleted file mode 100644 --- a/src/Data/Array/Accelerate/LLVM/Util.hs +++ /dev/null @@ -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 --- 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 - diff --git a/src/Data/ByteString/Short/Char8.hs b/src/Data/ByteString/Short/Char8.hs --- a/src/Data/ByteString/Short/Char8.hs +++ b/src/Data/ByteString/Short/Char8.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/ByteString/Short/Extra.hs b/src/Data/ByteString/Short/Extra.hs --- a/src/Data/ByteString/Short/Extra.hs +++ b/src/Data/ByteString/Short/Extra.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/Data/Range.hs b/src/Data/Range.hs deleted file mode 100644 --- a/src/Data/Range.hs +++ /dev/null @@ -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 --- 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 - diff --git a/src/LLVM/AST/Type/AddrSpace.hs b/src/LLVM/AST/Type/AddrSpace.hs --- a/src/LLVM/AST/Type/AddrSpace.hs +++ b/src/LLVM/AST/Type/AddrSpace.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/LLVM/AST/Type/Constant.hs b/src/LLVM/AST/Type/Constant.hs --- a/src/LLVM/AST/Type/Constant.hs +++ b/src/LLVM/AST/Type/Constant.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/LLVM/AST/Type/Downcast.hs b/src/LLVM/AST/Type/Downcast.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Type/Downcast.hs @@ -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 +-- 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 + diff --git a/src/LLVM/AST/Type/Flags.hs b/src/LLVM/AST/Type/Flags.hs --- a/src/LLVM/AST/Type/Flags.hs +++ b/src/LLVM/AST/Type/Flags.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/LLVM/AST/Type/Function.hs b/src/LLVM/AST/Type/Function.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Type/Function.hs @@ -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 +-- 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 + diff --git a/src/LLVM/AST/Type/Global.hs b/src/LLVM/AST/Type/Global.hs --- a/src/LLVM/AST/Type/Global.hs +++ b/src/LLVM/AST/Type/Global.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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..] ] diff --git a/src/LLVM/AST/Type/InlineAssembly.hs b/src/LLVM/AST/Type/InlineAssembly.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Type/InlineAssembly.hs @@ -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 +-- 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 + diff --git a/src/LLVM/AST/Type/Instruction.hs b/src/LLVM/AST/Type/Instruction.hs --- a/src/LLVM/AST/Type/Instruction.hs +++ b/src/LLVM/AST/Type/Instruction.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 -- -- * @@ -157,17 +181,16 @@ -- -- - 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 -- -- - 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 @@ -- -------------------- -- + -- 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) -- -- - 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 + -- -- FTrunc :: FloatingType a -- precondition: BitSize a > BitSize b @@ -258,6 +289,10 @@ -> Operand a -> Instruction b + BoolToInt :: IntegralType a + -> Operand Bool + -> Instruction a + -- -- FExt :: FloatingType a -- precondition: BitSize a < BitSize b @@ -265,6 +300,10 @@ -> Operand a -> Instruction b + BoolToFP :: FloatingType a + -> Operand Bool + -> Instruction a + -- -- -- @@ -276,7 +315,7 @@ -- -- -- - 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 @@ -- -- - 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 diff --git a/src/LLVM/AST/Type/Instruction/Atomic.hs b/src/LLVM/AST/Type/Instruction/Atomic.hs --- a/src/LLVM/AST/Type/Instruction/Atomic.hs +++ b/src/LLVM/AST/Type/Instruction/Atomic.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/LLVM/AST/Type/Instruction/Compare.hs b/src/LLVM/AST/Type/Instruction/Compare.hs --- a/src/LLVM/AST/Type/Instruction/Compare.hs +++ b/src/LLVM/AST/Type/Instruction/Compare.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/LLVM/AST/Type/Instruction/RMW.hs b/src/LLVM/AST/Type/Instruction/RMW.hs --- a/src/LLVM/AST/Type/Instruction/RMW.hs +++ b/src/LLVM/AST/Type/Instruction/RMW.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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. -- -- @@ -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" diff --git a/src/LLVM/AST/Type/Instruction/Volatile.hs b/src/LLVM/AST/Type/Instruction/Volatile.hs --- a/src/LLVM/AST/Type/Instruction/Volatile.hs +++ b/src/LLVM/AST/Type/Instruction/Volatile.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 @@ -- -- data Volatility = Volatile | NonVolatile + +instance Downcast Volatility Bool where + downcast Volatile = True + downcast NonVolatile = False diff --git a/src/LLVM/AST/Type/Metadata.hs b/src/LLVM/AST/Type/Metadata.hs --- a/src/LLVM/AST/Type/Metadata.hs +++ b/src/LLVM/AST/Type/Metadata.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 + diff --git a/src/LLVM/AST/Type/Name.hs b/src/LLVM/AST/Type/Name.hs --- a/src/LLVM/AST/Type/Name.hs +++ b/src/LLVM/AST/Type/Name.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/LLVM/AST/Type/Operand.hs b/src/LLVM/AST/Type/Operand.hs --- a/src/LLVM/AST/Type/Operand.hs +++ b/src/LLVM/AST/Type/Operand.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/LLVM/AST/Type/Representation.hs b/src/LLVM/AST/Type/Representation.hs --- a/src/LLVM/AST/Type/Representation.hs +++ b/src/LLVM/AST/Type/Representation.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 diff --git a/src/LLVM/AST/Type/Terminator.hs b/src/LLVM/AST/Type/Terminator.hs --- a/src/LLVM/AST/Type/Terminator.hs +++ b/src/LLVM/AST/Type/Terminator.hs @@ -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 +-- Maintainer : Trevor L. McDonell -- 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 + -- | -- -- TLM: well, I don't think the types of these terminators make any sense. When @@ -35,6 +40,7 @@ -- RetVal :: Operand a -> Terminator a + -- -- 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 = []